diff --git a/Makefile b/Makefile index 335cf47..861db3a 100755 --- a/Makefile +++ b/Makefile @@ -84,7 +84,7 @@ ifeq ($(OS), WIN32) EXT = .exe else LINKER_FLAGS = $(QFLAGS) -L/usr/local/lib -pthread -rdynamic - ELIBS = engine pthread quickjs glfw3 GL c m dl + ELIBS = engine pthread quickjs glfw3 asound GL c m dl CLIBS = endif diff --git a/source/engine/ffi.c b/source/engine/ffi.c index c11f836..90c8504 100644 --- a/source/engine/ffi.c +++ b/source/engine/ffi.c @@ -31,8 +31,6 @@ #include "HandmadeMath.h" -#include "miniaudio.h" - static JSValue globalThis; #define BYTE_TO_BINARY_PATTERN "%c%c%c%c%c%c%c%c" @@ -1179,7 +1177,7 @@ JSValue duk_sys_cmd(JSContext *js, JSValueConst this, int argc, JSValueConst *ar break; case 2: - sim_stop(); + sim_pause(); break; case 3: diff --git a/source/engine/miniaudio.h b/source/engine/miniaudio.h deleted file mode 100644 index a530aa4..0000000 --- a/source/engine/miniaudio.h +++ /dev/null @@ -1,92927 +0,0 @@ -/* -Audio playback and capture library. Choice of public domain or MIT-0. See license statements at the end of this file. -miniaudio - v0.11.12 - 2023-03-19 - -David Reid - mackron@gmail.com - -Website: https://miniaud.io -Documentation: https://miniaud.io/docs -GitHub: https://github.com/mackron/miniaudio -*/ - -/* -1. Introduction -=============== -miniaudio is a single file library for audio playback and capture. To use it, do the following in -one .c file: - - ```c - #define MINIAUDIO_IMPLEMENTATION - #include "miniaudio.h" - ``` - -You can do `#include "miniaudio.h"` in other parts of the program just like any other header. - -miniaudio includes both low level and high level APIs. The low level API is good for those who want -to do all of their mixing themselves and only require a light weight interface to the underlying -audio device. The high level API is good for those who have complex mixing and effect requirements. - -In miniaudio, objects are transparent structures. Unlike many other libraries, there are no handles -to opaque objects which means you need to allocate memory for objects yourself. In the examples -presented in this documentation you will often see objects declared on the stack. You need to be -careful when translating these examples to your own code so that you don't accidentally declare -your objects on the stack and then cause them to become invalid once the function returns. In -addition, you must ensure the memory address of your objects remain the same throughout their -lifetime. You therefore cannot be making copies of your objects. - -A config/init pattern is used throughout the entire library. The idea is that you set up a config -object and pass that into the initialization routine. The advantage to this system is that the -config object can be initialized with logical defaults and new properties added to it without -breaking the API. The config object can be allocated on the stack and does not need to be -maintained after initialization of the corresponding object. - - -1.1. Low Level API ------------------- -The low level API gives you access to the raw audio data of an audio device. It supports playback, -capture, full-duplex and loopback (WASAPI only). You can enumerate over devices to determine which -physical device(s) you want to connect to. - -The low level API uses the concept of a "device" as the abstraction for physical devices. The idea -is that you choose a physical device to emit or capture audio from, and then move data to/from the -device when miniaudio tells you to. Data is delivered to and from devices asynchronously via a -callback which you specify when initializing the device. - -When initializing the device you first need to configure it. The device configuration allows you to -specify things like the format of the data delivered via the callback, the size of the internal -buffer and the ID of the device you want to emit or capture audio from. - -Once you have the device configuration set up you can initialize the device. When initializing a -device you need to allocate memory for the device object beforehand. This gives the application -complete control over how the memory is allocated. In the example below we initialize a playback -device on the stack, but you could allocate it on the heap if that suits your situation better. - - ```c - void data_callback(ma_device* pDevice, void* pOutput, const void* pInput, ma_uint32 frameCount) - { - // In playback mode copy data to pOutput. In capture mode read data from pInput. In full-duplex mode, both - // pOutput and pInput will be valid and you can move data from pInput into pOutput. Never process more than - // frameCount frames. - } - - int main() - { - ma_device_config config = ma_device_config_init(ma_device_type_playback); - config.playback.format = ma_format_f32; // Set to ma_format_unknown to use the device's native format. - config.playback.channels = 2; // Set to 0 to use the device's native channel count. - config.sampleRate = 48000; // Set to 0 to use the device's native sample rate. - config.dataCallback = data_callback; // This function will be called when miniaudio needs more data. - config.pUserData = pMyCustomData; // Can be accessed from the device object (device.pUserData). - - ma_device device; - if (ma_device_init(NULL, &config, &device) != MA_SUCCESS) { - return -1; // Failed to initialize the device. - } - - ma_device_start(&device); // The device is sleeping by default so you'll need to start it manually. - - // Do something here. Probably your program's main loop. - - ma_device_uninit(&device); // This will stop the device so no need to do that manually. - return 0; - } - ``` - -In the example above, `data_callback()` is where audio data is written and read from the device. -The idea is in playback mode you cause sound to be emitted from the speakers by writing audio data -to the output buffer (`pOutput` in the example). In capture mode you read data from the input -buffer (`pInput`) to extract sound captured by the microphone. The `frameCount` parameter tells you -how many frames can be written to the output buffer and read from the input buffer. A "frame" is -one sample for each channel. For example, in a stereo stream (2 channels), one frame is 2 -samples: one for the left, one for the right. The channel count is defined by the device config. -The size in bytes of an individual sample is defined by the sample format which is also specified -in the device config. Multi-channel audio data is always interleaved, which means the samples for -each frame are stored next to each other in memory. For example, in a stereo stream the first pair -of samples will be the left and right samples for the first frame, the second pair of samples will -be the left and right samples for the second frame, etc. - -The configuration of the device is defined by the `ma_device_config` structure. The config object -is always initialized with `ma_device_config_init()`. It's important to always initialize the -config with this function as it initializes it with logical defaults and ensures your program -doesn't break when new members are added to the `ma_device_config` structure. The example above -uses a fairly simple and standard device configuration. The call to `ma_device_config_init()` takes -a single parameter, which is whether or not the device is a playback, capture, duplex or loopback -device (loopback devices are not supported on all backends). The `config.playback.format` member -sets the sample format which can be one of the following (all formats are native-endian): - - +---------------+----------------------------------------+---------------------------+ - | Symbol | Description | Range | - +---------------+----------------------------------------+---------------------------+ - | ma_format_f32 | 32-bit floating point | [-1, 1] | - | ma_format_s16 | 16-bit signed integer | [-32768, 32767] | - | ma_format_s24 | 24-bit signed integer (tightly packed) | [-8388608, 8388607] | - | ma_format_s32 | 32-bit signed integer | [-2147483648, 2147483647] | - | ma_format_u8 | 8-bit unsigned integer | [0, 255] | - +---------------+----------------------------------------+---------------------------+ - -The `config.playback.channels` member sets the number of channels to use with the device. The -channel count cannot exceed MA_MAX_CHANNELS. The `config.sampleRate` member sets the sample rate -(which must be the same for both playback and capture in full-duplex configurations). This is -usually set to 44100 or 48000, but can be set to anything. It's recommended to keep this between -8000 and 384000, however. - -Note that leaving the format, channel count and/or sample rate at their default values will result -in the internal device's native configuration being used which is useful if you want to avoid the -overhead of miniaudio's automatic data conversion. - -In addition to the sample format, channel count and sample rate, the data callback and user data -pointer are also set via the config. The user data pointer is not passed into the callback as a -parameter, but is instead set to the `pUserData` member of `ma_device` which you can access -directly since all miniaudio structures are transparent. - -Initializing the device is done with `ma_device_init()`. This will return a result code telling you -what went wrong, if anything. On success it will return `MA_SUCCESS`. After initialization is -complete the device will be in a stopped state. To start it, use `ma_device_start()`. -Uninitializing the device will stop it, which is what the example above does, but you can also stop -the device with `ma_device_stop()`. To resume the device simply call `ma_device_start()` again. -Note that it's important to never stop or start the device from inside the callback. This will -result in a deadlock. Instead you set a variable or signal an event indicating that the device -needs to stop and handle it in a different thread. The following APIs must never be called inside -the callback: - - ```c - ma_device_init() - ma_device_init_ex() - ma_device_uninit() - ma_device_start() - ma_device_stop() - ``` - -You must never try uninitializing and reinitializing a device inside the callback. You must also -never try to stop and start it from inside the callback. There are a few other things you shouldn't -do in the callback depending on your requirements, however this isn't so much a thread-safety -thing, but rather a real-time processing thing which is beyond the scope of this introduction. - -The example above demonstrates the initialization of a playback device, but it works exactly the -same for capture. All you need to do is change the device type from `ma_device_type_playback` to -`ma_device_type_capture` when setting up the config, like so: - - ```c - ma_device_config config = ma_device_config_init(ma_device_type_capture); - config.capture.format = MY_FORMAT; - config.capture.channels = MY_CHANNEL_COUNT; - ``` - -In the data callback you just read from the input buffer (`pInput` in the example above) and leave -the output buffer alone (it will be set to NULL when the device type is set to -`ma_device_type_capture`). - -These are the available device types and how you should handle the buffers in the callback: - - +-------------------------+--------------------------------------------------------+ - | Device Type | Callback Behavior | - +-------------------------+--------------------------------------------------------+ - | ma_device_type_playback | Write to output buffer, leave input buffer untouched. | - | ma_device_type_capture | Read from input buffer, leave output buffer untouched. | - | ma_device_type_duplex | Read from input buffer, write to output buffer. | - | ma_device_type_loopback | Read from input buffer, leave output buffer untouched. | - +-------------------------+--------------------------------------------------------+ - -You will notice in the example above that the sample format and channel count is specified -separately for playback and capture. This is to support different data formats between the playback -and capture devices in a full-duplex system. An example may be that you want to capture audio data -as a monaural stream (one channel), but output sound to a stereo speaker system. Note that if you -use different formats between playback and capture in a full-duplex configuration you will need to -convert the data yourself. There are functions available to help you do this which will be -explained later. - -The example above did not specify a physical device to connect to which means it will use the -operating system's default device. If you have multiple physical devices connected and you want to -use a specific one you will need to specify the device ID in the configuration, like so: - - ```c - config.playback.pDeviceID = pMyPlaybackDeviceID; // Only if requesting a playback or duplex device. - config.capture.pDeviceID = pMyCaptureDeviceID; // Only if requesting a capture, duplex or loopback device. - ``` - -To retrieve the device ID you will need to perform device enumeration, however this requires the -use of a new concept called the "context". Conceptually speaking the context sits above the device. -There is one context to many devices. The purpose of the context is to represent the backend at a -more global level and to perform operations outside the scope of an individual device. Mainly it is -used for performing run-time linking against backend libraries, initializing backends and -enumerating devices. The example below shows how to enumerate devices. - - ```c - ma_context context; - if (ma_context_init(NULL, 0, NULL, &context) != MA_SUCCESS) { - // Error. - } - - ma_device_info* pPlaybackInfos; - ma_uint32 playbackCount; - ma_device_info* pCaptureInfos; - ma_uint32 captureCount; - if (ma_context_get_devices(&context, &pPlaybackInfos, &playbackCount, &pCaptureInfos, &captureCount) != MA_SUCCESS) { - // Error. - } - - // Loop over each device info and do something with it. Here we just print the name with their index. You may want - // to give the user the opportunity to choose which device they'd prefer. - for (ma_uint32 iDevice = 0; iDevice < playbackCount; iDevice += 1) { - printf("%d - %s\n", iDevice, pPlaybackInfos[iDevice].name); - } - - ma_device_config config = ma_device_config_init(ma_device_type_playback); - config.playback.pDeviceID = &pPlaybackInfos[chosenPlaybackDeviceIndex].id; - config.playback.format = MY_FORMAT; - config.playback.channels = MY_CHANNEL_COUNT; - config.sampleRate = MY_SAMPLE_RATE; - config.dataCallback = data_callback; - config.pUserData = pMyCustomData; - - ma_device device; - if (ma_device_init(&context, &config, &device) != MA_SUCCESS) { - // Error - } - - ... - - ma_device_uninit(&device); - ma_context_uninit(&context); - ``` - -The first thing we do in this example is initialize a `ma_context` object with `ma_context_init()`. -The first parameter is a pointer to a list of `ma_backend` values which are used to override the -default backend priorities. When this is NULL, as in this example, miniaudio's default priorities -are used. The second parameter is the number of backends listed in the array pointed to by the -first parameter. The third parameter is a pointer to a `ma_context_config` object which can be -NULL, in which case defaults are used. The context configuration is used for setting the logging -callback, custom memory allocation callbacks, user-defined data and some backend-specific -configurations. - -Once the context has been initialized you can enumerate devices. In the example above we use the -simpler `ma_context_get_devices()`, however you can also use a callback for handling devices by -using `ma_context_enumerate_devices()`. When using `ma_context_get_devices()` you provide a pointer -to a pointer that will, upon output, be set to a pointer to a buffer containing a list of -`ma_device_info` structures. You also provide a pointer to an unsigned integer that will receive -the number of items in the returned buffer. Do not free the returned buffers as their memory is -managed internally by miniaudio. - -The `ma_device_info` structure contains an `id` member which is the ID you pass to the device -config. It also contains the name of the device which is useful for presenting a list of devices -to the user via the UI. - -When creating your own context you will want to pass it to `ma_device_init()` when initializing the -device. Passing in NULL, like we do in the first example, will result in miniaudio creating the -context for you, which you don't want to do since you've already created a context. Note that -internally the context is only tracked by it's pointer which means you must not change the location -of the `ma_context` object. If this is an issue, consider using `malloc()` to allocate memory for -the context. - - -1.2. High Level API -------------------- -The high level API consists of three main parts: - - * Resource management for loading and streaming sounds. - * A node graph for advanced mixing and effect processing. - * A high level "engine" that wraps around the resource manager and node graph. - -The resource manager (`ma_resource_manager`) is used for loading sounds. It supports loading sounds -fully into memory and also streaming. It will also deal with reference counting for you which -avoids the same sound being loaded multiple times. - -The node graph is used for mixing and effect processing. The idea is that you connect a number of -nodes into the graph by connecting each node's outputs to another node's inputs. Each node can -implement it's own effect. By chaining nodes together, advanced mixing and effect processing can -be achieved. - -The engine encapsulates both the resource manager and the node graph to create a simple, easy to -use high level API. The resource manager and node graph APIs are covered in more later sections of -this manual. - -The code below shows how you can initialize an engine using it's default configuration. - - ```c - ma_result result; - ma_engine engine; - - result = ma_engine_init(NULL, &engine); - if (result != MA_SUCCESS) { - return result; // Failed to initialize the engine. - } - ``` - -This creates an engine instance which will initialize a device internally which you can access with -`ma_engine_get_device()`. It will also initialize a resource manager for you which can be accessed -with `ma_engine_get_resource_manager()`. The engine itself is a node graph (`ma_node_graph`) which -means you can pass a pointer to the engine object into any of the `ma_node_graph` APIs (with a -cast). Alternatively, you can use `ma_engine_get_node_graph()` instead of a cast. - -Note that all objects in miniaudio, including the `ma_engine` object in the example above, are -transparent structures. There are no handles to opaque structures in miniaudio which means you need -to be mindful of how you declare them. In the example above we are declaring it on the stack, but -this will result in the struct being invalidated once the function encapsulating it returns. If -allocating the engine on the heap is more appropriate, you can easily do so with a standard call -to `malloc()` or whatever heap allocation routine you like: - - ```c - ma_engine* pEngine = malloc(sizeof(*pEngine)); - ``` - -The `ma_engine` API uses the same config/init pattern used all throughout miniaudio. To configure -an engine, you can fill out a `ma_engine_config` object and pass it into the first parameter of -`ma_engine_init()`: - - ```c - ma_result result; - ma_engine engine; - ma_engine_config engineConfig; - - engineConfig = ma_engine_config_init(); - engineConfig.pResourceManager = &myCustomResourceManager; // <-- Initialized as some earlier stage. - - result = ma_engine_init(&engineConfig, &engine); - if (result != MA_SUCCESS) { - return result; - } - ``` - -This creates an engine instance using a custom config. In this particular example it's showing how -you can specify a custom resource manager rather than having the engine initialize one internally. -This is particularly useful if you want to have multiple engine's share the same resource manager. - -The engine must be uninitialized with `ma_engine_uninit()` when it's no longer needed. - -By default the engine will be started, but nothing will be playing because no sounds have been -initialized. The easiest but least flexible way of playing a sound is like so: - - ```c - ma_engine_play_sound(&engine, "my_sound.wav", NULL); - ``` - -This plays what miniaudio calls an "inline" sound. It plays the sound once, and then puts the -internal sound up for recycling. The last parameter is used to specify which sound group the sound -should be associated with which will be explained later. This particular way of playing a sound is -simple, but lacks flexibility and features. A more flexible way of playing a sound is to first -initialize a sound: - - ```c - ma_result result; - ma_sound sound; - - result = ma_sound_init_from_file(&engine, "my_sound.wav", 0, NULL, NULL, &sound); - if (result != MA_SUCCESS) { - return result; - } - - ma_sound_start(&sound); - ``` - -This returns a `ma_sound` object which represents a single instance of the specified sound file. If -you want to play the same file multiple times simultaneously, you need to create one sound for each -instance. - -Sounds should be uninitialized with `ma_sound_uninit()`. - -Sounds are not started by default. Start a sound with `ma_sound_start()` and stop it with -`ma_sound_stop()`. When a sound is stopped, it is not rewound to the start. Use -`ma_sound_seek_to_pcm_frame(&sound, 0)` to seek back to the start of a sound. By default, starting -and stopping sounds happens immediately, but sometimes it might be convenient to schedule the sound -the be started and/or stopped at a specific time. This can be done with the following functions: - - ```c - ma_sound_set_start_time_in_pcm_frames() - ma_sound_set_start_time_in_milliseconds() - ma_sound_set_stop_time_in_pcm_frames() - ma_sound_set_stop_time_in_milliseconds() - ``` - -The start/stop time needs to be specified based on the absolute timer which is controlled by the -engine. The current global time time in PCM frames can be retrieved with `ma_engine_get_time()`. -The engine's global time can be changed with `ma_engine_set_time()` for synchronization purposes if -required. Note that scheduling a start time still requires an explicit call to `ma_sound_start()` -before anything will play: - - ```c - ma_sound_set_start_time_in_pcm_frames(&sound, ma_engine_get_time(&engine) + (ma_engine_get_sample_rate(&engine) * 2); - ma_sound_start(&sound); - ``` - -The third parameter of `ma_sound_init_from_file()` is a set of flags that control how the sound be -loaded and a few options on which features should be enabled for that sound. By default, the sound -is synchronously loaded fully into memory straight from the file system without any kind of -decoding. If you want to decode the sound before storing it in memory, you need to specify the -`MA_SOUND_FLAG_DECODE` flag. This is useful if you want to incur the cost of decoding at an earlier -stage, such as a loading stage. Without this option, decoding will happen dynamically at mixing -time which might be too expensive on the audio thread. - -If you want to load the sound asynchronously, you can specify the `MA_SOUND_FLAG_ASYNC` flag. This -will result in `ma_sound_init_from_file()` returning quickly, but the sound will not start playing -until the sound has had some audio decoded. - -The fourth parameter is a pointer to sound group. A sound group is used as a mechanism to organise -sounds into groups which have their own effect processing and volume control. An example is a game -which might have separate groups for sfx, voice and music. Each of these groups have their own -independent volume control. Use `ma_sound_group_init()` or `ma_sound_group_init_ex()` to initialize -a sound group. - -Sounds and sound groups are nodes in the engine's node graph and can be plugged into any `ma_node` -API. This makes it possible to connect sounds and sound groups to effect nodes to produce complex -effect chains. - -A sound can have it's volume changed with `ma_sound_set_volume()`. If you prefer decibel volume -control you can use `ma_volume_db_to_linear()` to convert from decibel representation to linear. - -Panning and pitching is supported with `ma_sound_set_pan()` and `ma_sound_set_pitch()`. If you know -a sound will never have it's pitch changed with `ma_sound_set_pitch()` or via the doppler effect, -you can specify the `MA_SOUND_FLAG_NO_PITCH` flag when initializing the sound for an optimization. - -By default, sounds and sound groups have spatialization enabled. If you don't ever want to -spatialize your sounds, initialize the sound with the `MA_SOUND_FLAG_NO_SPATIALIZATION` flag. The -spatialization model is fairly simple and is roughly on feature parity with OpenAL. HRTF and -environmental occlusion are not currently supported, but planned for the future. The supported -features include: - - * Sound and listener positioning and orientation with cones - * Attenuation models: none, inverse, linear and exponential - * Doppler effect - -Sounds can be faded in and out with `ma_sound_set_fade_in_pcm_frames()`. - -To check if a sound is currently playing, you can use `ma_sound_is_playing()`. To check if a sound -is at the end, use `ma_sound_at_end()`. Looping of a sound can be controlled with -`ma_sound_set_looping()`. Use `ma_sound_is_looping()` to check whether or not the sound is looping. - - - -2. Building -=========== -miniaudio should work cleanly out of the box without the need to download or install any -dependencies. See below for platform-specific details. - -Note that GCC and Clang require `-msse2`, `-mavx2`, etc. for SIMD optimizations. - - -2.1. Windows ------------- -The Windows build should compile cleanly on all popular compilers without the need to configure any -include paths nor link to any libraries. - -The UWP build may require linking to mmdevapi.lib if you get errors about an unresolved external -symbol for `ActivateAudioInterfaceAsync()`. - - -2.2. macOS and iOS ------------------- -The macOS build should compile cleanly without the need to download any dependencies nor link to -any libraries or frameworks. The iOS build needs to be compiled as Objective-C and will need to -link the relevant frameworks but should compile cleanly out of the box with Xcode. Compiling -through the command line requires linking to `-lpthread` and `-lm`. - -Due to the way miniaudio links to frameworks at runtime, your application may not pass Apple's -notarization process. To fix this there are two options. The first is to use the -`MA_NO_RUNTIME_LINKING` option, like so: - - ```c - #ifdef __APPLE__ - #define MA_NO_RUNTIME_LINKING - #endif - #define MINIAUDIO_IMPLEMENTATION - #include "miniaudio.h" - ``` - -This will require linking with `-framework CoreFoundation -framework CoreAudio -framework AudioToolbox`. -If you get errors about AudioToolbox, try with `-framework AudioUnit` instead. You may get this when -using older versions of iOS. Alternatively, if you would rather keep using runtime linking you can -add the following to your entitlements.xcent file: - - ``` - com.apple.security.cs.allow-dyld-environment-variables - - com.apple.security.cs.allow-unsigned-executable-memory - - ``` - -See this discussion for more info: https://github.com/mackron/miniaudio/issues/203. - - -2.3. Linux ----------- -The Linux build only requires linking to `-ldl`, `-lpthread` and `-lm`. You do not need any -development packages. You may need to link with `-latomic` if you're compiling for 32-bit ARM. - - -2.4. BSD --------- -The BSD build only requires linking to `-lpthread` and `-lm`. NetBSD uses audio(4), OpenBSD uses -sndio and FreeBSD uses OSS. You may need to link with `-latomic` if you're compiling for 32-bit -ARM. - - -2.5. Android ------------- -AAudio is the highest priority backend on Android. This should work out of the box without needing -any kind of compiler configuration. Support for AAudio starts with Android 8 which means older -versions will fall back to OpenSL|ES which requires API level 16+. - -There have been reports that the OpenSL|ES backend fails to initialize on some Android based -devices due to `dlopen()` failing to open "libOpenSLES.so". If this happens on your platform -you'll need to disable run-time linking with `MA_NO_RUNTIME_LINKING` and link with -lOpenSLES. - - -2.6. Emscripten ---------------- -The Emscripten build emits Web Audio JavaScript directly and should compile cleanly out of the box. -You cannot use `-std=c*` compiler flags, nor `-ansi`. - - -2.7. Build Options ------------------- -`#define` these options before including miniaudio.h. - - +----------------------------------+--------------------------------------------------------------------+ - | Option | Description | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_WASAPI | Disables the WASAPI backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_DSOUND | Disables the DirectSound backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_WINMM | Disables the WinMM backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_ALSA | Disables the ALSA backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_PULSEAUDIO | Disables the PulseAudio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_JACK | Disables the JACK backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_COREAUDIO | Disables the Core Audio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_SNDIO | Disables the sndio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_AUDIO4 | Disables the audio(4) backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_OSS | Disables the OSS backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_AAUDIO | Disables the AAudio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_OPENSL | Disables the OpenSL|ES backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_WEBAUDIO | Disables the Web Audio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_NULL | Disables the null backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_ONLY_SPECIFIC_BACKENDS | Disables all backends by default and requires `MA_ENABLE_*` to | - | | enable specific backends. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_WASAPI | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the WASAPI backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_DSOUND | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the DirectSound backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_WINMM | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the WinMM backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_ALSA | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the ALSA backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_PULSEAUDIO | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the PulseAudio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_JACK | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the JACK backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_COREAUDIO | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the Core Audio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_SNDIO | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the sndio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_AUDIO4 | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the audio(4) backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_OSS | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the OSS backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_AAUDIO | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the AAudio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_OPENSL | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the OpenSL|ES backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_WEBAUDIO | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the Web Audio backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_ENABLE_NULL | Used in conjunction with MA_ENABLE_ONLY_SPECIFIC_BACKENDS to | - | | enable the null backend. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_DECODING | Disables decoding APIs. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_ENCODING | Disables encoding APIs. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_WAV | Disables the built-in WAV decoder and encoder. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_FLAC | Disables the built-in FLAC decoder. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_MP3 | Disables the built-in MP3 decoder. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_DEVICE_IO | Disables playback and recording. This will disable `ma_context` | - | | and `ma_device` APIs. This is useful if you only want to use | - | | miniaudio's data conversion and/or decoding APIs. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_RESOURCE_MANAGER | Disables the resource manager. When using the engine this will | - | | also disable the following functions: | - | | | - | | ``` | - | | ma_sound_init_from_file() | - | | ma_sound_init_from_file_w() | - | | ma_sound_init_copy() | - | | ma_engine_play_sound_ex() | - | | ma_engine_play_sound() | - | | ``` | - | | | - | | The only way to initialize a `ma_sound` object is to initialize it | - | | from a data source. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_NODE_GRAPH | Disables the node graph API. This will also disable the engine API | - | | because it depends on the node graph. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_ENGINE | Disables the engine API. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_THREADING | Disables the `ma_thread`, `ma_mutex`, `ma_semaphore` and | - | | `ma_event` APIs. This option is useful if you only need to use | - | | miniaudio for data conversion, decoding and/or encoding. Some | - | | families of APIs require threading which means the following | - | | options must also be set: | - | | | - | | ``` | - | | MA_NO_DEVICE_IO | - | | ``` | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_GENERATION | Disables generation APIs such a `ma_waveform` and `ma_noise`. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_SSE2 | Disables SSE2 optimizations. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_AVX2 | Disables AVX2 optimizations. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_NEON | Disables NEON optimizations. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_NO_RUNTIME_LINKING | Disables runtime linking. This is useful for passing Apple's | - | | notarization process. When enabling this, you may need to avoid | - | | using `-std=c89` or `-std=c99` on Linux builds or else you may end | - | | up with compilation errors due to conflicts with `timespec` and | - | | `timeval` data types. | - | | | - | | You may need to enable this if your target platform does not allow | - | | runtime linking via `dlopen()`. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_DEBUG_OUTPUT | Enable `printf()` output of debug logs (`MA_LOG_LEVEL_DEBUG`). | - +----------------------------------+--------------------------------------------------------------------+ - | MA_COINIT_VALUE | Windows only. The value to pass to internal calls to | - | | `CoInitializeEx()`. Defaults to `COINIT_MULTITHREADED`. | - +----------------------------------+--------------------------------------------------------------------+ - | MA_API | Controls how public APIs should be decorated. Default is `extern`. | - +----------------------------------+--------------------------------------------------------------------+ - - -3. Definitions -============== -This section defines common terms used throughout miniaudio. Unfortunately there is often ambiguity -in the use of terms throughout the audio space, so this section is intended to clarify how miniaudio -uses each term. - -3.1. Sample ------------ -A sample is a single unit of audio data. If the sample format is f32, then one sample is one 32-bit -floating point number. - -3.2. Frame / PCM Frame ----------------------- -A frame is a group of samples equal to the number of channels. For a stereo stream a frame is 2 -samples, a mono frame is 1 sample, a 5.1 surround sound frame is 6 samples, etc. The terms "frame" -and "PCM frame" are the same thing in miniaudio. Note that this is different to a compressed frame. -If ever miniaudio needs to refer to a compressed frame, such as a FLAC frame, it will always -clarify what it's referring to with something like "FLAC frame". - -3.3. Channel ------------- -A stream of monaural audio that is emitted from an individual speaker in a speaker system, or -received from an individual microphone in a microphone system. A stereo stream has two channels (a -left channel, and a right channel), a 5.1 surround sound system has 6 channels, etc. Some audio -systems refer to a channel as a complex audio stream that's mixed with other channels to produce -the final mix - this is completely different to miniaudio's use of the term "channel" and should -not be confused. - -3.4. Sample Rate ----------------- -The sample rate in miniaudio is always expressed in Hz, such as 44100, 48000, etc. It's the number -of PCM frames that are processed per second. - -3.5. Formats ------------- -Throughout miniaudio you will see references to different sample formats: - - +---------------+----------------------------------------+---------------------------+ - | Symbol | Description | Range | - +---------------+----------------------------------------+---------------------------+ - | ma_format_f32 | 32-bit floating point | [-1, 1] | - | ma_format_s16 | 16-bit signed integer | [-32768, 32767] | - | ma_format_s24 | 24-bit signed integer (tightly packed) | [-8388608, 8388607] | - | ma_format_s32 | 32-bit signed integer | [-2147483648, 2147483647] | - | ma_format_u8 | 8-bit unsigned integer | [0, 255] | - +---------------+----------------------------------------+---------------------------+ - -All formats are native-endian. - - - -4. Data Sources -=============== -The data source abstraction in miniaudio is used for retrieving audio data from some source. A few -examples include `ma_decoder`, `ma_noise` and `ma_waveform`. You will need to be familiar with data -sources in order to make sense of some of the higher level concepts in miniaudio. - -The `ma_data_source` API is a generic interface for reading from a data source. Any object that -implements the data source interface can be plugged into any `ma_data_source` function. - -To read data from a data source: - - ```c - ma_result result; - ma_uint64 framesRead; - - result = ma_data_source_read_pcm_frames(pDataSource, pFramesOut, frameCount, &framesRead); - if (result != MA_SUCCESS) { - return result; // Failed to read data from the data source. - } - ``` - -If you don't need the number of frames that were successfully read you can pass in `NULL` to the -`pFramesRead` parameter. If this returns a value less than the number of frames requested it means -the end of the file has been reached. `MA_AT_END` will be returned only when the number of frames -read is 0. - -When calling any data source function, with the exception of `ma_data_source_init()` and -`ma_data_source_uninit()`, you can pass in any object that implements a data source. For example, -you could plug in a decoder like so: - - ```c - ma_result result; - ma_uint64 framesRead; - ma_decoder decoder; // <-- This would be initialized with `ma_decoder_init_*()`. - - result = ma_data_source_read_pcm_frames(&decoder, pFramesOut, frameCount, &framesRead); - if (result != MA_SUCCESS) { - return result; // Failed to read data from the decoder. - } - ``` - -If you want to seek forward you can pass in `NULL` to the `pFramesOut` parameter. Alternatively you -can use `ma_data_source_seek_pcm_frames()`. - -To seek to a specific PCM frame: - - ```c - result = ma_data_source_seek_to_pcm_frame(pDataSource, frameIndex); - if (result != MA_SUCCESS) { - return result; // Failed to seek to PCM frame. - } - ``` - -You can retrieve the total length of a data source in PCM frames, but note that some data sources -may not have the notion of a length, such as noise and waveforms, and others may just not have a -way of determining the length such as some decoders. To retrieve the length: - - ```c - ma_uint64 length; - - result = ma_data_source_get_length_in_pcm_frames(pDataSource, &length); - if (result != MA_SUCCESS) { - return result; // Failed to retrieve the length. - } - ``` - -Care should be taken when retrieving the length of a data source where the underlying decoder is -pulling data from a data stream with an undefined length, such as internet radio or some kind of -broadcast. If you do this, `ma_data_source_get_length_in_pcm_frames()` may never return. - -The current position of the cursor in PCM frames can also be retrieved: - - ```c - ma_uint64 cursor; - - result = ma_data_source_get_cursor_in_pcm_frames(pDataSource, &cursor); - if (result != MA_SUCCESS) { - return result; // Failed to retrieve the cursor. - } - ``` - -You will often need to know the data format that will be returned after reading. This can be -retrieved like so: - - ```c - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_channel channelMap[MA_MAX_CHANNELS]; - - result = ma_data_source_get_data_format(pDataSource, &format, &channels, &sampleRate, channelMap, MA_MAX_CHANNELS); - if (result != MA_SUCCESS) { - return result; // Failed to retrieve data format. - } - ``` - -If you do not need a specific data format property, just pass in NULL to the respective parameter. - -There may be cases where you want to implement something like a sound bank where you only want to -read data within a certain range of the underlying data. To do this you can use a range: - - ```c - result = ma_data_source_set_range_in_pcm_frames(pDataSource, rangeBegInFrames, rangeEndInFrames); - if (result != MA_SUCCESS) { - return result; // Failed to set the range. - } - ``` - -This is useful if you have a sound bank where many sounds are stored in the same file and you want -the data source to only play one of those sub-sounds. Note that once the range is set, everything -that takes a position, such as cursors and loop points, should always be relatvie to the start of -the range. When the range is set, any previously defined loop point will be reset. - -Custom loop points can also be used with data sources. By default, data sources will loop after -they reach the end of the data source, but if you need to loop at a specific location, you can do -the following: - - ```c - result = ma_data_set_loop_point_in_pcm_frames(pDataSource, loopBegInFrames, loopEndInFrames); - if (result != MA_SUCCESS) { - return result; // Failed to set the loop point. - } - ``` - -The loop point is relative to the current range. - -It's sometimes useful to chain data sources together so that a seamless transition can be achieved. -To do this, you can use chaining: - - ```c - ma_decoder decoder1; - ma_decoder decoder2; - - // ... initialize decoders with ma_decoder_init_*() ... - - result = ma_data_source_set_next(&decoder1, &decoder2); - if (result != MA_SUCCESS) { - return result; // Failed to set the next data source. - } - - result = ma_data_source_read_pcm_frames(&decoder1, pFramesOut, frameCount, pFramesRead); - if (result != MA_SUCCESS) { - return result; // Failed to read from the decoder. - } - ``` - -In the example above we're using decoders. When reading from a chain, you always want to read from -the top level data source in the chain. In the example above, `decoder1` is the top level data -source in the chain. When `decoder1` reaches the end, `decoder2` will start seamlessly without any -gaps. - -Note that when looping is enabled, only the current data source will be looped. You can loop the -entire chain by linking in a loop like so: - - ```c - ma_data_source_set_next(&decoder1, &decoder2); // decoder1 -> decoder2 - ma_data_source_set_next(&decoder2, &decoder1); // decoder2 -> decoder1 (loop back to the start). - ``` - -Note that setting up chaining is not thread safe, so care needs to be taken if you're dynamically -changing links while the audio thread is in the middle of reading. - -Do not use `ma_decoder_seek_to_pcm_frame()` as a means to reuse a data source to play multiple -instances of the same sound simultaneously. This can be extremely inefficient depending on the type -of data source and can result in glitching due to subtle changes to the state of internal filters. -Instead, initialize multiple data sources for each instance. - - -4.1. Custom Data Sources ------------------------- -You can implement a custom data source by implementing the functions in `ma_data_source_vtable`. -Your custom object must have `ma_data_source_base` as it's first member: - - ```c - struct my_data_source - { - ma_data_source_base base; - ... - }; - ``` - -In your initialization routine, you need to call `ma_data_source_init()` in order to set up the -base object (`ma_data_source_base`): - - ```c - static ma_result my_data_source_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) - { - // Read data here. Output in the same format returned by my_data_source_get_data_format(). - } - - static ma_result my_data_source_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) - { - // Seek to a specific PCM frame here. Return MA_NOT_IMPLEMENTED if seeking is not supported. - } - - static ma_result my_data_source_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) - { - // Return the format of the data here. - } - - static ma_result my_data_source_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) - { - // Retrieve the current position of the cursor here. Return MA_NOT_IMPLEMENTED and set *pCursor to 0 if there is no notion of a cursor. - } - - static ma_result my_data_source_get_length(ma_data_source* pDataSource, ma_uint64* pLength) - { - // Retrieve the length in PCM frames here. Return MA_NOT_IMPLEMENTED and set *pLength to 0 if there is no notion of a length or if the length is unknown. - } - - static g_my_data_source_vtable = - { - my_data_source_read, - my_data_source_seek, - my_data_source_get_data_format, - my_data_source_get_cursor, - my_data_source_get_length - }; - - ma_result my_data_source_init(my_data_source* pMyDataSource) - { - ma_result result; - ma_data_source_config baseConfig; - - baseConfig = ma_data_source_config_init(); - baseConfig.vtable = &g_my_data_source_vtable; - - result = ma_data_source_init(&baseConfig, &pMyDataSource->base); - if (result != MA_SUCCESS) { - return result; - } - - // ... do the initialization of your custom data source here ... - - return MA_SUCCESS; - } - - void my_data_source_uninit(my_data_source* pMyDataSource) - { - // ... do the uninitialization of your custom data source here ... - - // You must uninitialize the base data source. - ma_data_source_uninit(&pMyDataSource->base); - } - ``` - -Note that `ma_data_source_init()` and `ma_data_source_uninit()` are never called directly outside -of the custom data source. It's up to the custom data source itself to call these within their own -init/uninit functions. - - - -5. Engine -========= -The `ma_engine` API is a high level API for managing and mixing sounds and effect processing. The -`ma_engine` object encapsulates a resource manager and a node graph, both of which will be -explained in more detail later. - -Sounds are called `ma_sound` and are created from an engine. Sounds can be associated with a mixing -group called `ma_sound_group` which are also created from the engine. Both `ma_sound` and -`ma_sound_group` objects are nodes within the engine's node graph. - -When the engine is initialized, it will normally create a device internally. If you would rather -manage the device yourself, you can do so and just pass a pointer to it via the engine config when -you initialize the engine. You can also just use the engine without a device, which again can be -configured via the engine config. - -The most basic way to initialize the engine is with a default config, like so: - - ```c - ma_result result; - ma_engine engine; - - result = ma_engine_init(NULL, &engine); - if (result != MA_SUCCESS) { - return result; // Failed to initialize the engine. - } - ``` - -This will result in the engine initializing a playback device using the operating system's default -device. This will be sufficient for many use cases, but if you need more flexibility you'll want to -configure the engine with an engine config: - - ```c - ma_result result; - ma_engine engine; - ma_engine_config engineConfig; - - engineConfig = ma_engine_config_init(); - engineConfig.pDevice = &myDevice; - - result = ma_engine_init(&engineConfig, &engine); - if (result != MA_SUCCESS) { - return result; // Failed to initialize the engine. - } - ``` - -In the example above we're passing in a pre-initialized device. Since the caller is the one in -control of the device's data callback, it's their responsibility to manually call -`ma_engine_read_pcm_frames()` from inside their data callback: - - ```c - void playback_data_callback(ma_device* pDevice, void* pOutput, const void* pInput, ma_uint32 frameCount) - { - ma_engine_read_pcm_frames(&g_Engine, pOutput, frameCount, NULL); - } - ``` - -You can also use the engine independent of a device entirely: - - ```c - ma_result result; - ma_engine engine; - ma_engine_config engineConfig; - - engineConfig = ma_engine_config_init(); - engineConfig.noDevice = MA_TRUE; - engineConfig.channels = 2; // Must be set when not using a device. - engineConfig.sampleRate = 48000; // Must be set when not using a device. - - result = ma_engine_init(&engineConfig, &engine); - if (result != MA_SUCCESS) { - return result; // Failed to initialize the engine. - } - ``` - -Note that when you're not using a device, you must set the channel count and sample rate in the -config or else miniaudio won't know what to use (miniaudio will use the device to determine this -normally). When not using a device, you need to use `ma_engine_read_pcm_frames()` to process audio -data from the engine. This kind of setup is useful if you want to do something like offline -processing or want to use a different audio system for playback such as SDL. - -When a sound is loaded it goes through a resource manager. By default the engine will initialize a -resource manager internally, but you can also specify a pre-initialized resource manager: - - ```c - ma_result result; - ma_engine engine1; - ma_engine engine2; - ma_engine_config engineConfig; - - engineConfig = ma_engine_config_init(); - engineConfig.pResourceManager = &myResourceManager; - - ma_engine_init(&engineConfig, &engine1); - ma_engine_init(&engineConfig, &engine2); - ``` - -In this example we are initializing two engines, both of which are sharing the same resource -manager. This is especially useful for saving memory when loading the same file across multiple -engines. If you were not to use a shared resource manager, each engine instance would use their own -which would result in any sounds that are used between both engine's being loaded twice. By using -a shared resource manager, it would only be loaded once. Using multiple engine's is useful when you -need to output to multiple playback devices, such as in a local multiplayer game where each player -is using their own set of headphones. - -By default an engine will be in a started state. To make it so the engine is not automatically -started you can configure it as such: - - ```c - engineConfig.noAutoStart = MA_TRUE; - - // The engine will need to be started manually. - ma_engine_start(&engine); - - // Later on the engine can be stopped with ma_engine_stop(). - ma_engine_stop(&engine); - ``` - -The concept of starting or stopping an engine is only relevant when using the engine with a -device. Attempting to start or stop an engine that is not associated with a device will result in -`MA_INVALID_OPERATION`. - -The master volume of the engine can be controlled with `ma_engine_set_volume()` which takes a -linear scale, with 0 resulting in silence and anything above 1 resulting in amplification. If you -prefer decibel based volume control, use `ma_volume_db_to_linear()` to convert from dB to linear. - -When a sound is spatialized, it is done so relative to a listener. An engine can be configured to -have multiple listeners which can be configured via the config: - - ```c - engineConfig.listenerCount = 2; - ``` - -The maximum number of listeners is restricted to `MA_ENGINE_MAX_LISTENERS`. By default, when a -sound is spatialized, it will be done so relative to the closest listener. You can also pin a sound -to a specific listener which will be explained later. Listener's have a position, direction, cone, -and velocity (for doppler effect). A listener is referenced by an index, the meaning of which is up -to the caller (the index is 0 based and cannot go beyond the listener count, minus 1). The -position, direction and velocity are all specified in absolute terms: - - ```c - ma_engine_listener_set_position(&engine, listenerIndex, worldPosX, worldPosY, worldPosZ); - ``` - -The direction of the listener represents it's forward vector. The listener's up vector can also be -specified and defaults to +1 on the Y axis. - - ```c - ma_engine_listener_set_direction(&engine, listenerIndex, forwardX, forwardY, forwardZ); - ma_engine_listener_set_world_up(&engine, listenerIndex, 0, 1, 0); - ``` - -The engine supports directional attenuation. The listener can have a cone the controls how sound is -attenuated based on the listener's direction. When a sound is between the inner and outer cones, it -will be attenuated between 1 and the cone's outer gain: - - ```c - ma_engine_listener_set_cone(&engine, listenerIndex, innerAngleInRadians, outerAngleInRadians, outerGain); - ``` - -When a sound is inside the inner code, no directional attenuation is applied. When the sound is -outside of the outer cone, the attenuation will be set to `outerGain` in the example above. When -the sound is in between the inner and outer cones, the attenuation will be interpolated between 1 -and the outer gain. - -The engine's coordinate system follows the OpenGL coordinate system where positive X points right, -positive Y points up and negative Z points forward. - -The simplest and least flexible way to play a sound is like so: - - ```c - ma_engine_play_sound(&engine, "my_sound.wav", pGroup); - ``` - -This is a "fire and forget" style of function. The engine will manage the `ma_sound` object -internally. When the sound finishes playing, it'll be put up for recycling. For more flexibility -you'll want to initialize a sound object: - - ```c - ma_sound sound; - - result = ma_sound_init_from_file(&engine, "my_sound.wav", flags, pGroup, NULL, &sound); - if (result != MA_SUCCESS) { - return result; // Failed to load sound. - } - ``` - -Sounds need to be uninitialized with `ma_sound_uninit()`. - -The example above loads a sound from a file. If the resource manager has been disabled you will not -be able to use this function and instead you'll need to initialize a sound directly from a data -source: - - ```c - ma_sound sound; - - result = ma_sound_init_from_data_source(&engine, &dataSource, flags, pGroup, &sound); - if (result != MA_SUCCESS) { - return result; - } - ``` - -Each `ma_sound` object represents a single instance of the sound. If you want to play the same -sound multiple times at the same time, you need to initialize a separate `ma_sound` object. - -For the most flexibility when initializing sounds, use `ma_sound_init_ex()`. This uses miniaudio's -standard config/init pattern: - - ```c - ma_sound sound; - ma_sound_config soundConfig; - - soundConfig = ma_sound_config_init(); - soundConfig.pFilePath = NULL; // Set this to load from a file path. - soundConfig.pDataSource = NULL; // Set this to initialize from an existing data source. - soundConfig.pInitialAttachment = &someNodeInTheNodeGraph; - soundConfig.initialAttachmentInputBusIndex = 0; - soundConfig.channelsIn = 1; - soundConfig.channelsOut = 0; // Set to 0 to use the engine's native channel count. - - result = ma_sound_init_ex(&soundConfig, &sound); - if (result != MA_SUCCESS) { - return result; - } - ``` - -In the example above, the sound is being initialized without a file nor a data source. This is -valid, in which case the sound acts as a node in the middle of the node graph. This means you can -connect other sounds to this sound and allow it to act like a sound group. Indeed, this is exactly -what a `ma_sound_group` is. - -When loading a sound, you specify a set of flags that control how the sound is loaded and what -features are enabled for that sound. When no flags are set, the sound will be fully loaded into -memory in exactly the same format as how it's stored on the file system. The resource manager will -allocate a block of memory and then load the file directly into it. When reading audio data, it -will be decoded dynamically on the fly. In order to save processing time on the audio thread, it -might be beneficial to pre-decode the sound. You can do this with the `MA_SOUND_FLAG_DECODE` flag: - - ```c - ma_sound_init_from_file(&engine, "my_sound.wav", MA_SOUND_FLAG_DECODE, pGroup, NULL, &sound); - ``` - -By default, sounds will be loaded synchronously, meaning `ma_sound_init_*()` will not return until -the sound has been fully loaded. If this is prohibitive you can instead load sounds asynchronously -by specifying the `MA_SOUND_FLAG_ASYNC` flag: - - ```c - ma_sound_init_from_file(&engine, "my_sound.wav", MA_SOUND_FLAG_DECODE | MA_SOUND_FLAG_ASYNC, pGroup, NULL, &sound); - ``` - -This will result in `ma_sound_init_*()` returning quickly, but the sound won't yet have been fully -loaded. When you start the sound, it won't output anything until some sound is available. The sound -will start outputting audio before the sound has been fully decoded when the `MA_SOUND_FLAG_DECODE` -is specified. - -If you need to wait for an asynchronously loaded sound to be fully loaded, you can use a fence. A -fence in miniaudio is a simple synchronization mechanism which simply blocks until it's internal -counter hit's zero. You can specify a fence like so: - - ```c - ma_result result; - ma_fence fence; - ma_sound sounds[4]; - - result = ma_fence_init(&fence); - if (result != MA_SUCCESS) { - return result; - } - - // Load some sounds asynchronously. - for (int iSound = 0; iSound < 4; iSound += 1) { - ma_sound_init_from_file(&engine, mySoundFilesPaths[iSound], MA_SOUND_FLAG_DECODE | MA_SOUND_FLAG_ASYNC, pGroup, &fence, &sounds[iSound]); - } - - // ... do some other stuff here in the mean time ... - - // Wait for all sounds to finish loading. - ma_fence_wait(&fence); - ``` - -If loading the entire sound into memory is prohibitive, you can also configure the engine to stream -the audio data: - - ```c - ma_sound_init_from_file(&engine, "my_sound.wav", MA_SOUND_FLAG_STREAM, pGroup, NULL, &sound); - ``` - -When streaming sounds, 2 seconds worth of audio data is stored in memory. Although it should work -fine, it's inefficient to use streaming for short sounds. Streaming is useful for things like music -tracks in games. - -When loading a sound from a file path, the engine will reference count the file to prevent it from -being loaded if it's already in memory. When you uninitialize a sound, the reference count will be -decremented, and if it hits zero, the sound will be unloaded from memory. This reference counting -system is not used for streams. The engine will use a 64-bit hash of the file name when comparing -file paths which means there's a small chance you might encounter a name collision. If this is an -issue, you'll need to use a different name for one of the colliding file paths, or just not load -from files and instead load from a data source. - -You can use `ma_sound_init_copy()` to initialize a copy of another sound. Note, however, that this -only works for sounds that were initialized with `ma_sound_init_from_file()` and without the -`MA_SOUND_FLAG_STREAM` flag. - -When you initialize a sound, if you specify a sound group the sound will be attached to that group -automatically. If you set it to NULL, it will be automatically attached to the engine's endpoint. -If you would instead rather leave the sound unattached by default, you can can specify the -`MA_SOUND_FLAG_NO_DEFAULT_ATTACHMENT` flag. This is useful if you want to set up a complex node -graph. - -Sounds are not started by default. To start a sound, use `ma_sound_start()`. Stop a sound with -`ma_sound_stop()`. - -Sounds can have their volume controlled with `ma_sound_set_volume()` in the same way as the -engine's master volume. - -Sounds support stereo panning and pitching. Set the pan with `ma_sound_set_pan()`. Setting the pan -to 0 will result in an unpanned sound. Setting it to -1 will shift everything to the left, whereas -+1 will shift it to the right. The pitch can be controlled with `ma_sound_set_pitch()`. A larger -value will result in a higher pitch. The pitch must be greater than 0. - -The engine supports 3D spatialization of sounds. By default sounds will have spatialization -enabled, but if a sound does not need to be spatialized it's best to disable it. There are two ways -to disable spatialization of a sound: - - ```c - // Disable spatialization at initialization time via a flag: - ma_sound_init_from_file(&engine, "my_sound.wav", MA_SOUND_FLAG_NO_SPATIALIZATION, NULL, NULL, &sound); - - // Dynamically disable or enable spatialization post-initialization: - ma_sound_set_spatialization_enabled(&sound, isSpatializationEnabled); - ``` - -By default sounds will be spatialized based on the closest listener. If a sound should always be -spatialized relative to a specific listener it can be pinned to one: - - ```c - ma_sound_set_pinned_listener_index(&sound, listenerIndex); - ``` - -Like listeners, sounds have a position. By default, the position of a sound is in absolute space, -but it can be changed to be relative to a listener: - - ```c - ma_sound_set_positioning(&sound, ma_positioning_relative); - ``` - -Note that relative positioning of a sound only makes sense if there is either only one listener, or -the sound is pinned to a specific listener. To set the position of a sound: - - ```c - ma_sound_set_position(&sound, posX, posY, posZ); - ``` - -The direction works the same way as a listener and represents the sound's forward direction: - - ```c - ma_sound_set_direction(&sound, forwardX, forwardY, forwardZ); - ``` - -Sound's also have a cone for controlling directional attenuation. This works exactly the same as -listeners: - - ```c - ma_sound_set_cone(&sound, innerAngleInRadians, outerAngleInRadians, outerGain); - ``` - -The velocity of a sound is used for doppler effect and can be set as such: - - ```c - ma_sound_set_velocity(&sound, velocityX, velocityY, velocityZ); - ``` - -The engine supports different attenuation models which can be configured on a per-sound basis. By -default the attenuation model is set to `ma_attenuation_model_inverse` which is the equivalent to -OpenAL's `AL_INVERSE_DISTANCE_CLAMPED`. Configure the attenuation model like so: - - ```c - ma_sound_set_attenuation_model(&sound, ma_attenuation_model_inverse); - ``` - -The supported attenuation models include the following: - - +----------------------------------+----------------------------------------------+ - | ma_attenuation_model_none | No distance attenuation. | - +----------------------------------+----------------------------------------------+ - | ma_attenuation_model_inverse | Equivalent to `AL_INVERSE_DISTANCE_CLAMPED`. | - +----------------------------------+----------------------------------------------+ - | ma_attenuation_model_linear | Linear attenuation. | - +----------------------------------+----------------------------------------------+ - | ma_attenuation_model_exponential | Exponential attenuation. | - +----------------------------------+----------------------------------------------+ - -To control how quickly a sound rolls off as it moves away from the listener, you need to configure -the rolloff: - - ```c - ma_sound_set_rolloff(&sound, rolloff); - ``` - -You can control the minimum and maximum gain to apply from spatialization: - - ```c - ma_sound_set_min_gain(&sound, minGain); - ma_sound_set_max_gain(&sound, maxGain); - ``` - -Likewise, in the calculation of attenuation, you can control the minimum and maximum distances for -the attenuation calculation. This is useful if you want to ensure sounds don't drop below a certain -volume after the listener moves further away and to have sounds play a maximum volume when the -listener is within a certain distance: - - ```c - ma_sound_set_min_distance(&sound, minDistance); - ma_sound_set_max_distance(&sound, maxDistance); - ``` - -The engine's spatialization system supports doppler effect. The doppler factor can be configure on -a per-sound basis like so: - - ```c - ma_sound_set_doppler_factor(&sound, dopplerFactor); - ``` - -You can fade sounds in and out with `ma_sound_set_fade_in_pcm_frames()` and -`ma_sound_set_fade_in_milliseconds()`. Set the volume to -1 to use the current volume as the -starting volume: - - ```c - // Fade in over 1 second. - ma_sound_set_fade_in_milliseconds(&sound, 0, 1, 1000); - - // ... sometime later ... - - // Fade out over 1 second, starting from the current volume. - ma_sound_set_fade_in_milliseconds(&sound, -1, 0, 1000); - ``` - -By default sounds will start immediately, but sometimes for timing and synchronization purposes it -can be useful to schedule a sound to start or stop: - - ```c - // Start the sound in 1 second from now. - ma_sound_set_start_time_in_pcm_frames(&sound, ma_engine_get_time(&engine) + (ma_engine_get_sample_rate(&engine) * 1)); - - // Stop the sound in 2 seconds from now. - ma_sound_set_stop_time_in_pcm_frames(&sound, ma_engine_get_time(&engine) + (ma_engine_get_sample_rate(&engine) * 2)); - ``` - -Note that scheduling a start time still requires an explicit call to `ma_sound_start()` before -anything will play. - -The time is specified in global time which is controlled by the engine. You can get the engine's -current time with `ma_engine_get_time()`. The engine's global time is incremented automatically as -audio data is read, but it can be reset with `ma_engine_set_time()` in case it needs to be -resynchronized for some reason. - -To determine whether or not a sound is currently playing, use `ma_sound_is_playing()`. This will -take the scheduled start and stop times into account. - -Whether or not a sound should loop can be controlled with `ma_sound_set_looping()`. Sounds will not -be looping by default. Use `ma_sound_is_looping()` to determine whether or not a sound is looping. - -Use `ma_sound_at_end()` to determine whether or not a sound is currently at the end. For a looping -sound this should never return true. Alternatively, you can configure a callback that will be fired -when the sound reaches the end. Note that the callback is fired from the audio thread which means -you cannot be uninitializing sound from the callback. To set the callback you can use -`ma_sound_set_end_callback()`. Alternatively, if you're using `ma_sound_init_ex()`, you can pass it -into the config like so: - - ```c - soundConfig.endCallback = my_end_callback; - soundConfig.pEndCallbackUserData = pMyEndCallbackUserData; - ``` - -The end callback is declared like so: - - ```c - void my_end_callback(void* pUserData, ma_sound* pSound) - { - ... - } - ``` - -Internally a sound wraps around a data source. Some APIs exist to control the underlying data -source, mainly for convenience: - - ```c - ma_sound_seek_to_pcm_frame(&sound, frameIndex); - ma_sound_get_data_format(&sound, &format, &channels, &sampleRate, pChannelMap, channelMapCapacity); - ma_sound_get_cursor_in_pcm_frames(&sound, &cursor); - ma_sound_get_length_in_pcm_frames(&sound, &length); - ``` - -Sound groups have the same API as sounds, only they are called `ma_sound_group`, and since they do -not have any notion of a data source, anything relating to a data source is unavailable. - -Internally, sound data is loaded via the `ma_decoder` API which means by default it only supports -file formats that have built-in support in miniaudio. You can extend this to support any kind of -file format through the use of custom decoders. To do this you'll need to use a self-managed -resource manager and configure it appropriately. See the "Resource Management" section below for -details on how to set this up. - - -6. Resource Management -====================== -Many programs will want to manage sound resources for things such as reference counting and -streaming. This is supported by miniaudio via the `ma_resource_manager` API. - -The resource manager is mainly responsible for the following: - - * Loading of sound files into memory with reference counting. - * Streaming of sound data. - -When loading a sound file, the resource manager will give you back a `ma_data_source` compatible -object called `ma_resource_manager_data_source`. This object can be passed into any -`ma_data_source` API which is how you can read and seek audio data. When loading a sound file, you -specify whether or not you want the sound to be fully loaded into memory (and optionally -pre-decoded) or streamed. When loading into memory, you can also specify whether or not you want -the data to be loaded asynchronously. - -The example below is how you can initialize a resource manager using it's default configuration: - - ```c - ma_resource_manager_config config; - ma_resource_manager resourceManager; - - config = ma_resource_manager_config_init(); - result = ma_resource_manager_init(&config, &resourceManager); - if (result != MA_SUCCESS) { - ma_device_uninit(&device); - printf("Failed to initialize the resource manager."); - return -1; - } - ``` - -You can configure the format, channels and sample rate of the decoded audio data. By default it -will use the file's native data format, but you can configure it to use a consistent format. This -is useful for offloading the cost of data conversion to load time rather than dynamically -converting at mixing time. To do this, you configure the decoded format, channels and sample rate -like the code below: - - ```c - config = ma_resource_manager_config_init(); - config.decodedFormat = device.playback.format; - config.decodedChannels = device.playback.channels; - config.decodedSampleRate = device.sampleRate; - ``` - -In the code above, the resource manager will be configured so that any decoded audio data will be -pre-converted at load time to the device's native data format. If instead you used defaults and -the data format of the file did not match the device's data format, you would need to convert the -data at mixing time which may be prohibitive in high-performance and large scale scenarios like -games. - -Internally the resource manager uses the `ma_decoder` API to load sounds. This means by default it -only supports decoders that are built into miniaudio. It's possible to support additional encoding -formats through the use of custom decoders. To do so, pass in your `ma_decoding_backend_vtable` -vtables into the resource manager config: - - ```c - ma_decoding_backend_vtable* pCustomBackendVTables[] = - { - &g_ma_decoding_backend_vtable_libvorbis, - &g_ma_decoding_backend_vtable_libopus - }; - - ... - - resourceManagerConfig.ppCustomDecodingBackendVTables = pCustomBackendVTables; - resourceManagerConfig.customDecodingBackendCount = sizeof(pCustomBackendVTables) / sizeof(pCustomBackendVTables[0]); - resourceManagerConfig.pCustomDecodingBackendUserData = NULL; - ``` - -This system can allow you to support any kind of file format. See the "Decoding" section for -details on how to implement custom decoders. The miniaudio repository includes examples for Opus -via libopus and libopusfile and Vorbis via libvorbis and libvorbisfile. - -Asynchronicity is achieved via a job system. When an operation needs to be performed, such as the -decoding of a page, a job will be posted to a queue which will then be processed by a job thread. -By default there will be only one job thread running, but this can be configured, like so: - - ```c - config = ma_resource_manager_config_init(); - config.jobThreadCount = MY_JOB_THREAD_COUNT; - ``` - -By default job threads are managed internally by the resource manager, however you can also self -manage your job threads if, for example, you want to integrate the job processing into your -existing job infrastructure, or if you simply don't like the way the resource manager does it. To -do this, just set the job thread count to 0 and process jobs manually. To process jobs, you first -need to retrieve a job using `ma_resource_manager_next_job()` and then process it using -`ma_job_process()`: - - ```c - config = ma_resource_manager_config_init(); - config.jobThreadCount = 0; // Don't manage any job threads internally. - config.flags = MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING; // Optional. Makes `ma_resource_manager_next_job()` non-blocking. - - // ... Initialize your custom job threads ... - - void my_custom_job_thread(...) - { - for (;;) { - ma_job job; - ma_result result = ma_resource_manager_next_job(pMyResourceManager, &job); - if (result != MA_SUCCESS) { - if (result == MA_NO_DATA_AVAILABLE) { - // No jobs are available. Keep going. Will only get this if the resource manager was initialized - // with MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING. - continue; - } else if (result == MA_CANCELLED) { - // MA_JOB_TYPE_QUIT was posted. Exit. - break; - } else { - // Some other error occurred. - break; - } - } - - ma_job_process(&job); - } - } - ``` - -In the example above, the `MA_JOB_TYPE_QUIT` event is the used as the termination -indicator, but you can use whatever you would like to terminate the thread. The call to -`ma_resource_manager_next_job()` is blocking by default, but can be configured to be non-blocking -by initializing the resource manager with the `MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING` configuration -flag. Note that the `MA_JOB_TYPE_QUIT` will never be removed from the job queue. This -is to give every thread the opportunity to catch the event and terminate naturally. - -When loading a file, it's sometimes convenient to be able to customize how files are opened and -read instead of using standard `fopen()`, `fclose()`, etc. which is what miniaudio will use by -default. This can be done by setting `pVFS` member of the resource manager's config: - - ```c - // Initialize your custom VFS object. See documentation for VFS for information on how to do this. - my_custom_vfs vfs = my_custom_vfs_init(); - - config = ma_resource_manager_config_init(); - config.pVFS = &vfs; - ``` - -This is particularly useful in programs like games where you want to read straight from an archive -rather than the normal file system. If you do not specify a custom VFS, the resource manager will -use the operating system's normal file operations. - -To load a sound file and create a data source, call `ma_resource_manager_data_source_init()`. When -loading a sound you need to specify the file path and options for how the sounds should be loaded. -By default a sound will be loaded synchronously. The returned data source is owned by the caller -which means the caller is responsible for the allocation and freeing of the data source. Below is -an example for initializing a data source: - - ```c - ma_resource_manager_data_source dataSource; - ma_result result = ma_resource_manager_data_source_init(pResourceManager, pFilePath, flags, &dataSource); - if (result != MA_SUCCESS) { - // Error. - } - - // ... - - // A ma_resource_manager_data_source object is compatible with the `ma_data_source` API. To read data, just call - // the `ma_data_source_read_pcm_frames()` like you would with any normal data source. - result = ma_data_source_read_pcm_frames(&dataSource, pDecodedData, frameCount, &framesRead); - if (result != MA_SUCCESS) { - // Failed to read PCM frames. - } - - // ... - - ma_resource_manager_data_source_uninit(pResourceManager, &dataSource); - ``` - -The `flags` parameter specifies how you want to perform loading of the sound file. It can be a -combination of the following flags: - - ``` - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT - ``` - -When no flags are specified (set to 0), the sound will be fully loaded into memory, but not -decoded, meaning the raw file data will be stored in memory, and then dynamically decoded when -`ma_data_source_read_pcm_frames()` is called. To instead decode the audio data before storing it in -memory, use the `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE` flag. By default, the sound file will -be loaded synchronously, meaning `ma_resource_manager_data_source_init()` will only return after -the entire file has been loaded. This is good for simplicity, but can be prohibitively slow. You -can instead load the sound asynchronously using the `MA_RESOURCE_MANAGER_DATA_SOURCE_ASYNC` flag. -This will result in `ma_resource_manager_data_source_init()` returning quickly, but no data will be -returned by `ma_data_source_read_pcm_frames()` until some data is available. When no data is -available because the asynchronous decoding hasn't caught up, `MA_BUSY` will be returned by -`ma_data_source_read_pcm_frames()`. - -For large sounds, it's often prohibitive to store the entire file in memory. To mitigate this, you -can instead stream audio data which you can do by specifying the -`MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM` flag. When streaming, data will be decoded in 1 -second pages. When a new page needs to be decoded, a job will be posted to the job queue and then -subsequently processed in a job thread. - -For in-memory sounds, reference counting is used to ensure the data is loaded only once. This means -multiple calls to `ma_resource_manager_data_source_init()` with the same file path will result in -the file data only being loaded once. Each call to `ma_resource_manager_data_source_init()` must be -matched up with a call to `ma_resource_manager_data_source_uninit()`. Sometimes it can be useful -for a program to register self-managed raw audio data and associate it with a file path. Use the -`ma_resource_manager_register_*()` and `ma_resource_manager_unregister_*()` APIs to do this. -`ma_resource_manager_register_decoded_data()` is used to associate a pointer to raw, self-managed -decoded audio data in the specified data format with the specified name. Likewise, -`ma_resource_manager_register_encoded_data()` is used to associate a pointer to raw self-managed -encoded audio data (the raw file data) with the specified name. Note that these names need not be -actual file paths. When `ma_resource_manager_data_source_init()` is called (without the -`MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM` flag), the resource manager will look for these -explicitly registered data buffers and, if found, will use it as the backing data for the data -source. Note that the resource manager does *not* make a copy of this data so it is up to the -caller to ensure the pointer stays valid for it's lifetime. Use -`ma_resource_manager_unregister_data()` to unregister the self-managed data. You can also use -`ma_resource_manager_register_file()` and `ma_resource_manager_unregister_file()` to register and -unregister a file. It does not make sense to use the `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM` -flag with a self-managed data pointer. - - -6.1. Asynchronous Loading and Synchronization ---------------------------------------------- -When loading asynchronously, it can be useful to poll whether or not loading has finished. Use -`ma_resource_manager_data_source_result()` to determine this. For in-memory sounds, this will -return `MA_SUCCESS` when the file has been *entirely* decoded. If the sound is still being decoded, -`MA_BUSY` will be returned. Otherwise, some other error code will be returned if the sound failed -to load. For streaming data sources, `MA_SUCCESS` will be returned when the first page has been -decoded and the sound is ready to be played. If the first page is still being decoded, `MA_BUSY` -will be returned. Otherwise, some other error code will be returned if the sound failed to load. - -In addition to polling, you can also use a simple synchronization object called a "fence" to wait -for asynchronously loaded sounds to finish. This is called `ma_fence`. The advantage to using a -fence is that it can be used to wait for a group of sounds to finish loading rather than waiting -for sounds on an individual basis. There are two stages to loading a sound: - - * Initialization of the internal decoder; and - * Completion of decoding of the file (the file is fully decoded) - -You can specify separate fences for each of the different stages. Waiting for the initialization -of the internal decoder is important for when you need to know the sample format, channels and -sample rate of the file. - -The example below shows how you could use a fence when loading a number of sounds: - - ```c - // This fence will be released when all sounds are finished loading entirely. - ma_fence fence; - ma_fence_init(&fence); - - // This will be passed into the initialization routine for each sound. - ma_resource_manager_pipeline_notifications notifications = ma_resource_manager_pipeline_notifications_init(); - notifications.done.pFence = &fence; - - // Now load a bunch of sounds: - for (iSound = 0; iSound < soundCount; iSound += 1) { - ma_resource_manager_data_source_init(pResourceManager, pSoundFilePaths[iSound], flags, ¬ifications, &pSoundSources[iSound]); - } - - // ... DO SOMETHING ELSE WHILE SOUNDS ARE LOADING ... - - // Wait for loading of sounds to finish. - ma_fence_wait(&fence); - ``` - -In the example above we used a fence for waiting until the entire file has been fully decoded. If -you only need to wait for the initialization of the internal decoder to complete, you can use the -`init` member of the `ma_resource_manager_pipeline_notifications` object: - - ```c - notifications.init.pFence = &fence; - ``` - -If a fence is not appropriate for your situation, you can instead use a callback that is fired on -an individual sound basis. This is done in a very similar way to fences: - - ```c - typedef struct - { - ma_async_notification_callbacks cb; - void* pMyData; - } my_notification; - - void my_notification_callback(ma_async_notification* pNotification) - { - my_notification* pMyNotification = (my_notification*)pNotification; - - // Do something in response to the sound finishing loading. - } - - ... - - my_notification myCallback; - myCallback.cb.onSignal = my_notification_callback; - myCallback.pMyData = pMyData; - - ma_resource_manager_pipeline_notifications notifications = ma_resource_manager_pipeline_notifications_init(); - notifications.done.pNotification = &myCallback; - - ma_resource_manager_data_source_init(pResourceManager, "my_sound.wav", flags, ¬ifications, &mySound); - ``` - -In the example above we just extend the `ma_async_notification_callbacks` object and pass an -instantiation into the `ma_resource_manager_pipeline_notifications` in the same way as we did with -the fence, only we set `pNotification` instead of `pFence`. You can set both of these at the same -time and they should both work as expected. If using the `pNotification` system, you need to ensure -your `ma_async_notification_callbacks` object stays valid. - - - -6.2. Resource Manager Implementation Details --------------------------------------------- -Resources are managed in two main ways: - - * By storing the entire sound inside an in-memory buffer (referred to as a data buffer) - * By streaming audio data on the fly (referred to as a data stream) - -A resource managed data source (`ma_resource_manager_data_source`) encapsulates a data buffer or -data stream, depending on whether or not the data source was initialized with the -`MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM` flag. If so, it will make use of a -`ma_resource_manager_data_stream` object. Otherwise it will use a `ma_resource_manager_data_buffer` -object. Both of these objects are data sources which means they can be used with any -`ma_data_source_*()` API. - -Another major feature of the resource manager is the ability to asynchronously decode audio files. -This relieves the audio thread of time-consuming decoding which can negatively affect scalability -due to the audio thread needing to complete it's work extremely quickly to avoid glitching. -Asynchronous decoding is achieved through a job system. There is a central multi-producer, -multi-consumer, fixed-capacity job queue. When some asynchronous work needs to be done, a job is -posted to the queue which is then read by a job thread. The number of job threads can be -configured for improved scalability, and job threads can all run in parallel without needing to -worry about the order of execution (how this is achieved is explained below). - -When a sound is being loaded asynchronously, playback can begin before the sound has been fully -decoded. This enables the application to start playback of the sound quickly, while at the same -time allowing to resource manager to keep loading in the background. Since there may be less -threads than the number of sounds being loaded at a given time, a simple scheduling system is used -to keep decoding time balanced and fair. The resource manager solves this by splitting decoding -into chunks called pages. By default, each page is 1 second long. When a page has been decoded, a -new job will be posted to start decoding the next page. By dividing up decoding into pages, an -individual sound shouldn't ever delay every other sound from having their first page decoded. Of -course, when loading many sounds at the same time, there will always be an amount of time required -to process jobs in the queue so in heavy load situations there will still be some delay. To -determine if a data source is ready to have some frames read, use -`ma_resource_manager_data_source_get_available_frames()`. This will return the number of frames -available starting from the current position. - - -6.2.1. Job Queue ----------------- -The resource manager uses a job queue which is multi-producer, multi-consumer, and fixed-capacity. -This job queue is not currently lock-free, and instead uses a spinlock to achieve thread-safety. -Only a fixed number of jobs can be allocated and inserted into the queue which is done through a -lock-free data structure for allocating an index into a fixed sized array, with reference counting -for mitigation of the ABA problem. The reference count is 32-bit. - -For many types of jobs it's important that they execute in a specific order. In these cases, jobs -are executed serially. For the resource manager, serial execution of jobs is only required on a -per-object basis (per data buffer or per data stream). Each of these objects stores an execution -counter. When a job is posted it is associated with an execution counter. When the job is -processed, it checks if the execution counter of the job equals the execution counter of the -owning object and if so, processes the job. If the counters are not equal, the job will be posted -back onto the job queue for later processing. When the job finishes processing the execution order -of the main object is incremented. This system means the no matter how many job threads are -executing, decoding of an individual sound will always get processed serially. The advantage to -having multiple threads comes into play when loading multiple sounds at the same time. - -The resource manager's job queue is not 100% lock-free and will use a spinlock to achieve -thread-safety for a very small section of code. This is only relevant when the resource manager -uses more than one job thread. If only using a single job thread, which is the default, the -lock should never actually wait in practice. The amount of time spent locking should be quite -short, but it's something to be aware of for those who have pedantic lock-free requirements and -need to use more than one job thread. There are plans to remove this lock in a future version. - -In addition, posting a job will release a semaphore, which on Win32 is implemented with -`ReleaseSemaphore` and on POSIX platforms via a condition variable: - - ```c - pthread_mutex_lock(&pSemaphore->lock); - { - pSemaphore->value += 1; - pthread_cond_signal(&pSemaphore->cond); - } - pthread_mutex_unlock(&pSemaphore->lock); - ``` - -Again, this is relevant for those with strict lock-free requirements in the audio thread. To avoid -this, you can use non-blocking mode (via the `MA_JOB_QUEUE_FLAG_NON_BLOCKING` -flag) and implement your own job processing routine (see the "Resource Manager" section above for -details on how to do this). - - - -6.2.2. Data Buffers -------------------- -When the `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM` flag is excluded at initialization time, the -resource manager will try to load the data into an in-memory data buffer. Before doing so, however, -it will first check if the specified file is already loaded. If so, it will increment a reference -counter and just use the already loaded data. This saves both time and memory. When the data buffer -is uninitialized, the reference counter will be decremented. If the counter hits zero, the file -will be unloaded. This is a detail to keep in mind because it could result in excessive loading and -unloading of a sound. For example, the following sequence will result in a file be loaded twice, -once after the other: - - ```c - ma_resource_manager_data_source_init(pResourceManager, "my_file", ..., &myDataBuffer0); // Refcount = 1. Initial load. - ma_resource_manager_data_source_uninit(pResourceManager, &myDataBuffer0); // Refcount = 0. Unloaded. - - ma_resource_manager_data_source_init(pResourceManager, "my_file", ..., &myDataBuffer1); // Refcount = 1. Reloaded because previous uninit() unloaded it. - ma_resource_manager_data_source_uninit(pResourceManager, &myDataBuffer1); // Refcount = 0. Unloaded. - ``` - -A binary search tree (BST) is used for storing data buffers as it has good balance between -efficiency and simplicity. The key of the BST is a 64-bit hash of the file path that was passed -into `ma_resource_manager_data_source_init()`. The advantage of using a hash is that it saves -memory over storing the entire path, has faster comparisons, and results in a mostly balanced BST -due to the random nature of the hash. The disadvantages are that file names are case-sensitive and -there's a small chance of name collisions. If case-sensitivity is an issue, you should normalize -your file names to upper- or lower-case before initializing your data sources. If name collisions -become an issue, you'll need to change the name of one of the colliding names or just not use the -resource manager. - -When a sound file has not already been loaded and the `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC` -flag is excluded, the file will be decoded synchronously by the calling thread. There are two -options for controlling how the audio is stored in the data buffer - encoded or decoded. When the -`MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE` option is excluded, the raw file data will be stored -in memory. Otherwise the sound will be decoded before storing it in memory. Synchronous loading is -a very simple and standard process of simply adding an item to the BST, allocating a block of -memory and then decoding (if `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE` is specified). - -When the `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC` flag is specified, loading of the data buffer -is done asynchronously. In this case, a job is posted to the queue to start loading and then the -function immediately returns, setting an internal result code to `MA_BUSY`. This result code is -returned when the program calls `ma_resource_manager_data_source_result()`. When decoding has fully -completed `MA_SUCCESS` will be returned. This can be used to know if loading has fully completed. - -When loading asynchronously, a single job is posted to the queue of the type -`MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER_NODE`. This involves making a copy of the file path and -associating it with job. When the job is processed by the job thread, it will first load the file -using the VFS associated with the resource manager. When using a custom VFS, it's important that it -be completely thread-safe because it will be used from one or more job threads at the same time. -Individual files should only ever be accessed by one thread at a time, however. After opening the -file via the VFS, the job will determine whether or not the file is being decoded. If not, it -simply allocates a block of memory and loads the raw file contents into it and returns. On the -other hand, when the file is being decoded, it will first allocate a decoder on the heap and -initialize it. Then it will check if the length of the file is known. If so it will allocate a -block of memory to store the decoded output and initialize it to silence. If the size is unknown, -it will allocate room for one page. After memory has been allocated, the first page will be -decoded. If the sound is shorter than a page, the result code will be set to `MA_SUCCESS` and the -completion event will be signalled and loading is now complete. If, however, there is more to -decode, a job with the code `MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE` is posted. This job -will decode the next page and perform the same process if it reaches the end. If there is more to -decode, the job will post another `MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE` job which will -keep on happening until the sound has been fully decoded. For sounds of an unknown length, each -page will be linked together as a linked list. Internally this is implemented via the -`ma_paged_audio_buffer` object. - - -6.2.3. Data Streams -------------------- -Data streams only ever store two pages worth of data for each instance. They are most useful for -large sounds like music tracks in games that would consume too much memory if fully decoded in -memory. After every frame from a page has been read, a job will be posted to load the next page -which is done from the VFS. - -For data streams, the `MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC` flag will determine whether or -not initialization of the data source waits until the two pages have been decoded. When unset, -`ma_resource_manager_data_source_init()` will wait until the two pages have been loaded, otherwise -it will return immediately. - -When frames are read from a data stream using `ma_resource_manager_data_source_read_pcm_frames()`, -`MA_BUSY` will be returned if there are no frames available. If there are some frames available, -but less than the number requested, `MA_SUCCESS` will be returned, but the actual number of frames -read will be less than the number requested. Due to the asynchronous nature of data streams, -seeking is also asynchronous. If the data stream is in the middle of a seek, `MA_BUSY` will be -returned when trying to read frames. - -When `ma_resource_manager_data_source_read_pcm_frames()` results in a page getting fully consumed -a job is posted to load the next page. This will be posted from the same thread that called -`ma_resource_manager_data_source_read_pcm_frames()`. - -Data streams are uninitialized by posting a job to the queue, but the function won't return until -that job has been processed. The reason for this is that the caller owns the data stream object and -therefore miniaudio needs to ensure everything completes before handing back control to the caller. -Also, if the data stream is uninitialized while pages are in the middle of decoding, they must -complete before destroying any underlying object and the job system handles this cleanly. - -Note that when a new page needs to be loaded, a job will be posted to the resource manager's job -thread from the audio thread. You must keep in mind the details mentioned in the "Job Queue" -section above regarding locking when posting an event if you require a strictly lock-free audio -thread. - - - -7. Node Graph -============= -miniaudio's routing infrastructure follows a node graph paradigm. The idea is that you create a -node whose outputs are attached to inputs of another node, thereby creating a graph. There are -different types of nodes, with each node in the graph processing input data to produce output, -which is then fed through the chain. Each node in the graph can apply their own custom effects. At -the start of the graph will usually be one or more data source nodes which have no inputs and -instead pull their data from a data source. At the end of the graph is an endpoint which represents -the end of the chain and is where the final output is ultimately extracted from. - -Each node has a number of input buses and a number of output buses. An output bus from a node is -attached to an input bus of another. Multiple nodes can connect their output buses to another -node's input bus, in which case their outputs will be mixed before processing by the node. Below is -a diagram that illustrates a hypothetical node graph setup: - - ``` - >>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Data flows left to right >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - - +---------------+ +-----------------+ - | Data Source 1 =----+ +----------+ +----= Low Pass Filter =----+ - +---------------+ | | =----+ +-----------------+ | +----------+ - +----= Splitter | +----= ENDPOINT | - +---------------+ | | =----+ +-----------------+ | +----------+ - | Data Source 2 =----+ +----------+ +----= Echo / Delay =----+ - +---------------+ +-----------------+ - ``` - -In the above graph, it starts with two data sources whose outputs are attached to the input of a -splitter node. It's at this point that the two data sources are mixed. After mixing, the splitter -performs it's processing routine and produces two outputs which is simply a duplication of the -input stream. One output is attached to a low pass filter, whereas the other output is attached to -a echo/delay. The outputs of the the low pass filter and the echo are attached to the endpoint, and -since they're both connected to the same input bus, they'll be mixed. - -Each input bus must be configured to accept the same number of channels, but the number of channels -used by input buses can be different to the number of channels for output buses in which case -miniaudio will automatically convert the input data to the output channel count before processing. -The number of channels of an output bus of one node must match the channel count of the input bus -it's attached to. The channel counts cannot be changed after the node has been initialized. If you -attempt to attach an output bus to an input bus with a different channel count, attachment will -fail. - -To use a node graph, you first need to initialize a `ma_node_graph` object. This is essentially a -container around the entire graph. The `ma_node_graph` object is required for some thread-safety -issues which will be explained later. A `ma_node_graph` object is initialized using miniaudio's -standard config/init system: - - ```c - ma_node_graph_config nodeGraphConfig = ma_node_graph_config_init(myChannelCount); - - result = ma_node_graph_init(&nodeGraphConfig, NULL, &nodeGraph); // Second parameter is a pointer to allocation callbacks. - if (result != MA_SUCCESS) { - // Failed to initialize node graph. - } - ``` - -When you initialize the node graph, you're specifying the channel count of the endpoint. The -endpoint is a special node which has one input bus and one output bus, both of which have the -same channel count, which is specified in the config. Any nodes that connect directly to the -endpoint must be configured such that their output buses have the same channel count. When you read -audio data from the node graph, it'll have the channel count you specified in the config. To read -data from the graph: - - ```c - ma_uint32 framesRead; - result = ma_node_graph_read_pcm_frames(&nodeGraph, pFramesOut, frameCount, &framesRead); - if (result != MA_SUCCESS) { - // Failed to read data from the node graph. - } - ``` - -When you read audio data, miniaudio starts at the node graph's endpoint node which then pulls in -data from it's input attachments, which in turn recursively pull in data from their inputs, and so -on. At the start of the graph there will be some kind of data source node which will have zero -inputs and will instead read directly from a data source. The base nodes don't literally need to -read from a `ma_data_source` object, but they will always have some kind of underlying object that -sources some kind of audio. The `ma_data_source_node` node can be used to read from a -`ma_data_source`. Data is always in floating-point format and in the number of channels you -specified when the graph was initialized. The sample rate is defined by the underlying data sources. -It's up to you to ensure they use a consistent and appropriate sample rate. - -The `ma_node` API is designed to allow custom nodes to be implemented with relative ease, but -miniaudio includes a few stock nodes for common functionality. This is how you would initialize a -node which reads directly from a data source (`ma_data_source_node`) which is an example of one -of the stock nodes that comes with miniaudio: - - ```c - ma_data_source_node_config config = ma_data_source_node_config_init(pMyDataSource); - - ma_data_source_node dataSourceNode; - result = ma_data_source_node_init(&nodeGraph, &config, NULL, &dataSourceNode); - if (result != MA_SUCCESS) { - // Failed to create data source node. - } - ``` - -The data source node will use the output channel count to determine the channel count of the output -bus. There will be 1 output bus and 0 input buses (data will be drawn directly from the data -source). The data source must output to floating-point (`ma_format_f32`) or else an error will be -returned from `ma_data_source_node_init()`. - -By default the node will not be attached to the graph. To do so, use `ma_node_attach_output_bus()`: - - ```c - result = ma_node_attach_output_bus(&dataSourceNode, 0, ma_node_graph_get_endpoint(&nodeGraph), 0); - if (result != MA_SUCCESS) { - // Failed to attach node. - } - ``` - -The code above connects the data source node directly to the endpoint. Since the data source node -has only a single output bus, the index will always be 0. Likewise, the endpoint only has a single -input bus which means the input bus index will also always be 0. - -To detach a specific output bus, use `ma_node_detach_output_bus()`. To detach all output buses, use -`ma_node_detach_all_output_buses()`. If you want to just move the output bus from one attachment to -another, you do not need to detach first. You can just call `ma_node_attach_output_bus()` and it'll -deal with it for you. - -Less frequently you may want to create a specialized node. This will be a node where you implement -your own processing callback to apply a custom effect of some kind. This is similar to initializing -one of the stock node types, only this time you need to specify a pointer to a vtable containing a -pointer to the processing function and the number of input and output buses. Example: - - ```c - static void my_custom_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) - { - // Do some processing of ppFramesIn (one stream of audio data per input bus) - const float* pFramesIn_0 = ppFramesIn[0]; // Input bus @ index 0. - const float* pFramesIn_1 = ppFramesIn[1]; // Input bus @ index 1. - float* pFramesOut_0 = ppFramesOut[0]; // Output bus @ index 0. - - // Do some processing. On input, `pFrameCountIn` will be the number of input frames in each - // buffer in `ppFramesIn` and `pFrameCountOut` will be the capacity of each of the buffers - // in `ppFramesOut`. On output, `pFrameCountIn` should be set to the number of input frames - // your node consumed and `pFrameCountOut` should be set the number of output frames that - // were produced. - // - // You should process as many frames as you can. If your effect consumes input frames at the - // same rate as output frames (always the case, unless you're doing resampling), you need - // only look at `ppFramesOut` and process that exact number of frames. If you're doing - // resampling, you'll need to be sure to set both `pFrameCountIn` and `pFrameCountOut` - // properly. - } - - static ma_node_vtable my_custom_node_vtable = - { - my_custom_node_process_pcm_frames, // The function that will be called to process your custom node. This is where you'd implement your effect processing. - NULL, // Optional. A callback for calculating the number of input frames that are required to process a specified number of output frames. - 2, // 2 input buses. - 1, // 1 output bus. - 0 // Default flags. - }; - - ... - - // Each bus needs to have a channel count specified. To do this you need to specify the channel - // counts in an array and then pass that into the node config. - ma_uint32 inputChannels[2]; // Equal in size to the number of input channels specified in the vtable. - ma_uint32 outputChannels[1]; // Equal in size to the number of output channels specified in the vtable. - - inputChannels[0] = channelsIn; - inputChannels[1] = channelsIn; - outputChannels[0] = channelsOut; - - ma_node_config nodeConfig = ma_node_config_init(); - nodeConfig.vtable = &my_custom_node_vtable; - nodeConfig.pInputChannels = inputChannels; - nodeConfig.pOutputChannels = outputChannels; - - ma_node_base node; - result = ma_node_init(&nodeGraph, &nodeConfig, NULL, &node); - if (result != MA_SUCCESS) { - // Failed to initialize node. - } - ``` - -When initializing a custom node, as in the code above, you'll normally just place your vtable in -static space. The number of input and output buses are specified as part of the vtable. If you need -a variable number of buses on a per-node bases, the vtable should have the relevant bus count set -to `MA_NODE_BUS_COUNT_UNKNOWN`. In this case, the bus count should be set in the node config: - - ```c - static ma_node_vtable my_custom_node_vtable = - { - my_custom_node_process_pcm_frames, // The function that will be called process your custom node. This is where you'd implement your effect processing. - NULL, // Optional. A callback for calculating the number of input frames that are required to process a specified number of output frames. - MA_NODE_BUS_COUNT_UNKNOWN, // The number of input buses is determined on a per-node basis. - 1, // 1 output bus. - 0 // Default flags. - }; - - ... - - ma_node_config nodeConfig = ma_node_config_init(); - nodeConfig.vtable = &my_custom_node_vtable; - nodeConfig.inputBusCount = myBusCount; // <-- Since the vtable specifies MA_NODE_BUS_COUNT_UNKNOWN, the input bus count should be set here. - nodeConfig.pInputChannels = inputChannels; // <-- Make sure there are nodeConfig.inputBusCount elements in this array. - nodeConfig.pOutputChannels = outputChannels; // <-- The vtable specifies 1 output bus, so there must be 1 element in this array. - ``` - -In the above example it's important to never set the `inputBusCount` and `outputBusCount` members -to anything other than their defaults if the vtable specifies an explicit count. They can only be -set if the vtable specifies MA_NODE_BUS_COUNT_UNKNOWN in the relevant bus count. - -Most often you'll want to create a structure to encapsulate your node with some extra data. You -need to make sure the `ma_node_base` object is your first member of the structure: - - ```c - typedef struct - { - ma_node_base base; // <-- Make sure this is always the first member. - float someCustomData; - } my_custom_node; - ``` - -By doing this, your object will be compatible with all `ma_node` APIs and you can attach it to the -graph just like any other node. - -In the custom processing callback (`my_custom_node_process_pcm_frames()` in the example above), the -number of channels for each bus is what was specified by the config when the node was initialized -with `ma_node_init()`. In addition, all attachments to each of the input buses will have been -pre-mixed by miniaudio. The config allows you to specify different channel counts for each -individual input and output bus. It's up to the effect to handle it appropriate, and if it can't, -return an error in it's initialization routine. - -Custom nodes can be assigned some flags to describe their behaviour. These are set via the vtable -and include the following: - - +-----------------------------------------+---------------------------------------------------+ - | Flag Name | Description | - +-----------------------------------------+---------------------------------------------------+ - | MA_NODE_FLAG_PASSTHROUGH | Useful for nodes that do not do any kind of audio | - | | processing, but are instead used for tracking | - | | time, handling events, etc. Also used by the | - | | internal endpoint node. It reads directly from | - | | the input bus to the output bus. Nodes with this | - | | flag must have exactly 1 input bus and 1 output | - | | bus, and both buses must have the same channel | - | | counts. | - +-----------------------------------------+---------------------------------------------------+ - | MA_NODE_FLAG_CONTINUOUS_PROCESSING | Causes the processing callback to be called even | - | | when no data is available to be read from input | - | | attachments. When a node has at least one input | - | | bus, but there are no inputs attached or the | - | | inputs do not deliver any data, the node's | - | | processing callback will not get fired. This flag | - | | will make it so the callback is always fired | - | | regardless of whether or not any input data is | - | | received. This is useful for effects like | - | | echos where there will be a tail of audio data | - | | that still needs to be processed even when the | - | | original data sources have reached their ends. It | - | | may also be useful for nodes that must always | - | | have their processing callback fired when there | - | | are no inputs attached. | - +-----------------------------------------+---------------------------------------------------+ - | MA_NODE_FLAG_ALLOW_NULL_INPUT | Used in conjunction with | - | | `MA_NODE_FLAG_CONTINUOUS_PROCESSING`. When this | - | | is set, the `ppFramesIn` parameter of the | - | | processing callback will be set to NULL when | - | | there are no input frames are available. When | - | | this is unset, silence will be posted to the | - | | processing callback. | - +-----------------------------------------+---------------------------------------------------+ - | MA_NODE_FLAG_DIFFERENT_PROCESSING_RATES | Used to tell miniaudio that input and output | - | | frames are processed at different rates. You | - | | should set this for any nodes that perform | - | | resampling. | - +-----------------------------------------+---------------------------------------------------+ - | MA_NODE_FLAG_SILENT_OUTPUT | Used to tell miniaudio that a node produces only | - | | silent output. This is useful for nodes where you | - | | don't want the output to contribute to the final | - | | mix. An example might be if you want split your | - | | stream and have one branch be output to a file. | - | | When using this flag, you should avoid writing to | - | | the output buffer of the node's processing | - | | callback because miniaudio will ignore it anyway. | - +-----------------------------------------+---------------------------------------------------+ - - -If you need to make a copy of an audio stream for effect processing you can use a splitter node -called `ma_splitter_node`. This takes has 1 input bus and splits the stream into 2 output buses. -You can use it like this: - - ```c - ma_splitter_node_config splitterNodeConfig = ma_splitter_node_config_init(channels); - - ma_splitter_node splitterNode; - result = ma_splitter_node_init(&nodeGraph, &splitterNodeConfig, NULL, &splitterNode); - if (result != MA_SUCCESS) { - // Failed to create node. - } - - // Attach your output buses to two different input buses (can be on two different nodes). - ma_node_attach_output_bus(&splitterNode, 0, ma_node_graph_get_endpoint(&nodeGraph), 0); // Attach directly to the endpoint. - ma_node_attach_output_bus(&splitterNode, 1, &myEffectNode, 0); // Attach to input bus 0 of some effect node. - ``` - -The volume of an output bus can be configured on a per-bus basis: - - ```c - ma_node_set_output_bus_volume(&splitterNode, 0, 0.5f); - ma_node_set_output_bus_volume(&splitterNode, 1, 0.5f); - ``` - -In the code above we're using the splitter node from before and changing the volume of each of the -copied streams. - -You can start and stop a node with the following: - - ```c - ma_node_set_state(&splitterNode, ma_node_state_started); // The default state. - ma_node_set_state(&splitterNode, ma_node_state_stopped); - ``` - -By default the node is in a started state, but since it won't be connected to anything won't -actually be invoked by the node graph until it's connected. When you stop a node, data will not be -read from any of it's input connections. You can use this property to stop a group of sounds -atomically. - -You can configure the initial state of a node in it's config: - - ```c - nodeConfig.initialState = ma_node_state_stopped; - ``` - -Note that for the stock specialized nodes, all of their configs will have a `nodeConfig` member -which is the config to use with the base node. This is where the initial state can be configured -for specialized nodes: - - ```c - dataSourceNodeConfig.nodeConfig.initialState = ma_node_state_stopped; - ``` - -When using a specialized node like `ma_data_source_node` or `ma_splitter_node`, be sure to not -modify the `vtable` member of the `nodeConfig` object. - - -7.1. Timing ------------ -The node graph supports starting and stopping nodes at scheduled times. This is especially useful -for data source nodes where you want to get the node set up, but only start playback at a specific -time. There are two clocks: local and global. - -A local clock is per-node, whereas the global clock is per graph. Scheduling starts and stops can -only be done based on the global clock because the local clock will not be running while the node -is stopped. The global clocks advances whenever `ma_node_graph_read_pcm_frames()` is called. On the -other hand, the local clock only advances when the node's processing callback is fired, and is -advanced based on the output frame count. - -To retrieve the global time, use `ma_node_graph_get_time()`. The global time can be set with -`ma_node_graph_set_time()` which might be useful if you want to do seeking on a global timeline. -Getting and setting the local time is similar. Use `ma_node_get_time()` to retrieve the local time, -and `ma_node_set_time()` to set the local time. The global and local times will be advanced by the -audio thread, so care should be taken to avoid data races. Ideally you should avoid calling these -outside of the node processing callbacks which are always run on the audio thread. - -There is basic support for scheduling the starting and stopping of nodes. You can only schedule one -start and one stop at a time. This is mainly intended for putting nodes into a started or stopped -state in a frame-exact manner. Without this mechanism, starting and stopping of a node is limited -to the resolution of a call to `ma_node_graph_read_pcm_frames()` which would typically be in blocks -of several milliseconds. The following APIs can be used for scheduling node states: - - ```c - ma_node_set_state_time() - ma_node_get_state_time() - ``` - -The time is absolute and must be based on the global clock. An example is below: - - ```c - ma_node_set_state_time(&myNode, ma_node_state_started, sampleRate*1); // Delay starting to 1 second. - ma_node_set_state_time(&myNode, ma_node_state_stopped, sampleRate*5); // Delay stopping to 5 seconds. - ``` - -An example for changing the state using a relative time. - - ```c - ma_node_set_state_time(&myNode, ma_node_state_started, sampleRate*1 + ma_node_graph_get_time(&myNodeGraph)); - ma_node_set_state_time(&myNode, ma_node_state_stopped, sampleRate*5 + ma_node_graph_get_time(&myNodeGraph)); - ``` - -Note that due to the nature of multi-threading the times may not be 100% exact. If this is an -issue, consider scheduling state changes from within a processing callback. An idea might be to -have some kind of passthrough trigger node that is used specifically for tracking time and handling -events. - - - -7.2. Thread Safety and Locking ------------------------------- -When processing audio, it's ideal not to have any kind of locking in the audio thread. Since it's -expected that `ma_node_graph_read_pcm_frames()` would be run on the audio thread, it does so -without the use of any locks. This section discusses the implementation used by miniaudio and goes -over some of the compromises employed by miniaudio to achieve this goal. Note that the current -implementation may not be ideal - feedback and critiques are most welcome. - -The node graph API is not *entirely* lock-free. Only `ma_node_graph_read_pcm_frames()` is expected -to be lock-free. Attachment, detachment and uninitialization of nodes use locks to simplify the -implementation, but are crafted in a way such that such locking is not required when reading audio -data from the graph. Locking in these areas are achieved by means of spinlocks. - -The main complication with keeping `ma_node_graph_read_pcm_frames()` lock-free stems from the fact -that a node can be uninitialized, and it's memory potentially freed, while in the middle of being -processed on the audio thread. There are times when the audio thread will be referencing a node, -which means the uninitialization process of a node needs to make sure it delays returning until the -audio thread is finished so that control is not handed back to the caller thereby giving them a -chance to free the node's memory. - -When the audio thread is processing a node, it does so by reading from each of the output buses of -the node. In order for a node to process data for one of it's output buses, it needs to read from -each of it's input buses, and so on an so forth. It follows that once all output buses of a node -are detached, the node as a whole will be disconnected and no further processing will occur unless -it's output buses are reattached, which won't be happening when the node is being uninitialized. -By having `ma_node_detach_output_bus()` wait until the audio thread is finished with it, we can -simplify a few things, at the expense of making `ma_node_detach_output_bus()` a bit slower. By -doing this, the implementation of `ma_node_uninit()` becomes trivial - just detach all output -nodes, followed by each of the attachments to each of it's input nodes, and then do any final clean -up. - -With the above design, the worst-case scenario is `ma_node_detach_output_bus()` taking as long as -it takes to process the output bus being detached. This will happen if it's called at just the -wrong moment where the audio thread has just iterated it and has just started processing. The -caller of `ma_node_detach_output_bus()` will stall until the audio thread is finished, which -includes the cost of recursively processing it's inputs. This is the biggest compromise made with -the approach taken by miniaudio for it's lock-free processing system. The cost of detaching nodes -earlier in the pipeline (data sources, for example) will be cheaper than the cost of detaching -higher level nodes, such as some kind of final post-processing endpoint. If you need to do mass -detachments, detach starting from the lowest level nodes and work your way towards the final -endpoint node (but don't try detaching the node graph's endpoint). If the audio thread is not -running, detachment will be fast and detachment in any order will be the same. The reason nodes -need to wait for their input attachments to complete is due to the potential for desyncs between -data sources. If the node was to terminate processing mid way through processing it's inputs, -there's a chance that some of the underlying data sources will have been read, but then others not. -That will then result in a potential desynchronization when detaching and reattaching higher-level -nodes. A possible solution to this is to have an option when detaching to terminate processing -before processing all input attachments which should be fairly simple. - -Another compromise, albeit less significant, is locking when attaching and detaching nodes. This -locking is achieved by means of a spinlock in order to reduce memory overhead. A lock is present -for each input bus and output bus. When an output bus is connected to an input bus, both the output -bus and input bus is locked. This locking is specifically for attaching and detaching across -different threads and does not affect `ma_node_graph_read_pcm_frames()` in any way. The locking and -unlocking is mostly self-explanatory, but a slightly less intuitive aspect comes into it when -considering that iterating over attachments must not break as a result of attaching or detaching a -node while iteration is occurring. - -Attaching and detaching are both quite simple. When an output bus of a node is attached to an input -bus of another node, it's added to a linked list. Basically, an input bus is a linked list, where -each item in the list is and output bus. We have some intentional (and convenient) restrictions on -what can done with the linked list in order to simplify the implementation. First of all, whenever -something needs to iterate over the list, it must do so in a forward direction. Backwards iteration -is not supported. Also, items can only be added to the start of the list. - -The linked list is a doubly-linked list where each item in the list (an output bus) holds a pointer -to the next item in the list, and another to the previous item. A pointer to the previous item is -only required for fast detachment of the node - it is never used in iteration. This is an -important property because it means from the perspective of iteration, attaching and detaching of -an item can be done with a single atomic assignment. This is exploited by both the attachment and -detachment process. When attaching the node, the first thing that is done is the setting of the -local "next" and "previous" pointers of the node. After that, the item is "attached" to the list -by simply performing an atomic exchange with the head pointer. After that, the node is "attached" -to the list from the perspective of iteration. Even though the "previous" pointer of the next item -hasn't yet been set, from the perspective of iteration it's been attached because iteration will -only be happening in a forward direction which means the "previous" pointer won't actually ever get -used. The same general process applies to detachment. See `ma_node_attach_output_bus()` and -`ma_node_detach_output_bus()` for the implementation of this mechanism. - - - -8. Decoding -=========== -The `ma_decoder` API is used for reading audio files. Decoders are completely decoupled from -devices and can be used independently. The following formats are supported: - - +---------+------------------+----------+ - | Format | Decoding Backend | Built-In | - +---------+------------------+----------+ - | WAV | dr_wav | Yes | - | MP3 | dr_mp3 | Yes | - | FLAC | dr_flac | Yes | - | Vorbis | stb_vorbis | No | - +---------+------------------+----------+ - -Vorbis is supported via stb_vorbis which can be enabled by including the header section before the -implementation of miniaudio, like the following: - - ```c - #define STB_VORBIS_HEADER_ONLY - #include "extras/stb_vorbis.c" // Enables Vorbis decoding. - - #define MINIAUDIO_IMPLEMENTATION - #include "miniaudio.h" - - // The stb_vorbis implementation must come after the implementation of miniaudio. - #undef STB_VORBIS_HEADER_ONLY - #include "extras/stb_vorbis.c" - ``` - -A copy of stb_vorbis is included in the "extras" folder in the miniaudio repository (https://github.com/mackron/miniaudio). - -Built-in decoders are amalgamated into the implementation section of miniaudio. You can disable the -built-in decoders by specifying one or more of the following options before the miniaudio -implementation: - - ```c - #define MA_NO_WAV - #define MA_NO_MP3 - #define MA_NO_FLAC - ``` - -Disabling built-in decoding libraries is useful if you use these libraries independently of the -`ma_decoder` API. - -A decoder can be initialized from a file with `ma_decoder_init_file()`, a block of memory with -`ma_decoder_init_memory()`, or from data delivered via callbacks with `ma_decoder_init()`. Here is -an example for loading a decoder from a file: - - ```c - ma_decoder decoder; - ma_result result = ma_decoder_init_file("MySong.mp3", NULL, &decoder); - if (result != MA_SUCCESS) { - return false; // An error occurred. - } - - ... - - ma_decoder_uninit(&decoder); - ``` - -When initializing a decoder, you can optionally pass in a pointer to a `ma_decoder_config` object -(the `NULL` argument in the example above) which allows you to configure the output format, channel -count, sample rate and channel map: - - ```c - ma_decoder_config config = ma_decoder_config_init(ma_format_f32, 2, 48000); - ``` - -When passing in `NULL` for decoder config in `ma_decoder_init*()`, the output format will be the -same as that defined by the decoding backend. - -Data is read from the decoder as PCM frames. This will output the number of PCM frames actually -read. If this is less than the requested number of PCM frames it means you've reached the end. The -return value will be `MA_AT_END` if no samples have been read and the end has been reached. - - ```c - ma_result result = ma_decoder_read_pcm_frames(pDecoder, pFrames, framesToRead, &framesRead); - if (framesRead < framesToRead) { - // Reached the end. - } - ``` - -You can also seek to a specific frame like so: - - ```c - ma_result result = ma_decoder_seek_to_pcm_frame(pDecoder, targetFrame); - if (result != MA_SUCCESS) { - return false; // An error occurred. - } - ``` - -If you want to loop back to the start, you can simply seek back to the first PCM frame: - - ```c - ma_decoder_seek_to_pcm_frame(pDecoder, 0); - ``` - -When loading a decoder, miniaudio uses a trial and error technique to find the appropriate decoding -backend. This can be unnecessarily inefficient if the type is already known. In this case you can -use `encodingFormat` variable in the device config to specify a specific encoding format you want -to decode: - - ```c - decoderConfig.encodingFormat = ma_encoding_format_wav; - ``` - -See the `ma_encoding_format` enum for possible encoding formats. - -The `ma_decoder_init_file()` API will try using the file extension to determine which decoding -backend to prefer. - - -8.1. Custom Decoders --------------------- -It's possible to implement a custom decoder and plug it into miniaudio. This is extremely useful -when you want to use the `ma_decoder` API, but need to support an encoding format that's not one of -the stock formats supported by miniaudio. This can be put to particularly good use when using the -`ma_engine` and/or `ma_resource_manager` APIs because they use `ma_decoder` internally. If, for -example, you wanted to support Opus, you can do so with a custom decoder (there if a reference -Opus decoder in the "extras" folder of the miniaudio repository which uses libopus + libopusfile). - -A custom decoder must implement a data source. A vtable called `ma_decoding_backend_vtable` needs -to be implemented which is then passed into the decoder config: - - ```c - ma_decoding_backend_vtable* pCustomBackendVTables[] = - { - &g_ma_decoding_backend_vtable_libvorbis, - &g_ma_decoding_backend_vtable_libopus - }; - - ... - - decoderConfig = ma_decoder_config_init_default(); - decoderConfig.pCustomBackendUserData = NULL; - decoderConfig.ppCustomBackendVTables = pCustomBackendVTables; - decoderConfig.customBackendCount = sizeof(pCustomBackendVTables) / sizeof(pCustomBackendVTables[0]); - ``` - -The `ma_decoding_backend_vtable` vtable has the following functions: - - ``` - onInit - onInitFile - onInitFileW - onInitMemory - onUninit - ``` - -There are only two functions that must be implemented - `onInit` and `onUninit`. The other -functions can be implemented for a small optimization for loading from a file path or memory. If -these are not specified, miniaudio will deal with it for you via a generic implementation. - -When you initialize a custom data source (by implementing the `onInit` function in the vtable) you -will need to output a pointer to a `ma_data_source` which implements your custom decoder. See the -section about data sources for details on how to implement this. Alternatively, see the -"custom_decoders" example in the miniaudio repository. - -The `onInit` function takes a pointer to some callbacks for the purpose of reading raw audio data -from some arbitrary source. You'll use these functions to read from the raw data and perform the -decoding. When you call them, you will pass in the `pReadSeekTellUserData` pointer to the relevant -parameter. - -The `pConfig` parameter in `onInit` can be used to configure the backend if appropriate. It's only -used as a hint and can be ignored. However, if any of the properties are relevant to your decoder, -an optimal implementation will handle the relevant properties appropriately. - -If memory allocation is required, it should be done so via the specified allocation callbacks if -possible (the `pAllocationCallbacks` parameter). - -If an error occurs when initializing the decoder, you should leave `ppBackend` unset, or set to -NULL, and make sure everything is cleaned up appropriately and an appropriate result code returned. -When multiple custom backends are specified, miniaudio will cycle through the vtables in the order -they're listed in the array that's passed into the decoder config so it's important that your -initialization routine is clean. - -When a decoder is uninitialized, the `onUninit` callback will be fired which will give you an -opportunity to clean up and internal data. - - - -9. Encoding -=========== -The `ma_encoding` API is used for writing audio files. The only supported output format is WAV -which is achieved via dr_wav which is amalgamated into the implementation section of miniaudio. -This can be disabled by specifying the following option before the implementation of miniaudio: - - ```c - #define MA_NO_WAV - ``` - -An encoder can be initialized to write to a file with `ma_encoder_init_file()` or from data -delivered via callbacks with `ma_encoder_init()`. Below is an example for initializing an encoder -to output to a file. - - ```c - ma_encoder_config config = ma_encoder_config_init(ma_encoding_format_wav, FORMAT, CHANNELS, SAMPLE_RATE); - ma_encoder encoder; - ma_result result = ma_encoder_init_file("my_file.wav", &config, &encoder); - if (result != MA_SUCCESS) { - // Error - } - - ... - - ma_encoder_uninit(&encoder); - ``` - -When initializing an encoder you must specify a config which is initialized with -`ma_encoder_config_init()`. Here you must specify the file type, the output sample format, output -channel count and output sample rate. The following file types are supported: - - +------------------------+-------------+ - | Enum | Description | - +------------------------+-------------+ - | ma_encoding_format_wav | WAV | - +------------------------+-------------+ - -If the format, channel count or sample rate is not supported by the output file type an error will -be returned. The encoder will not perform data conversion so you will need to convert it before -outputting any audio data. To output audio data, use `ma_encoder_write_pcm_frames()`, like in the -example below: - - ```c - framesWritten = ma_encoder_write_pcm_frames(&encoder, pPCMFramesToWrite, framesToWrite); - ``` - -Encoders must be uninitialized with `ma_encoder_uninit()`. - - - -10. Data Conversion -=================== -A data conversion API is included with miniaudio which supports the majority of data conversion -requirements. This supports conversion between sample formats, channel counts (with channel -mapping) and sample rates. - - -10.1. Sample Format Conversion ------------------------------- -Conversion between sample formats is achieved with the `ma_pcm_*_to_*()`, `ma_pcm_convert()` and -`ma_convert_pcm_frames_format()` APIs. Use `ma_pcm_*_to_*()` to convert between two specific -formats. Use `ma_pcm_convert()` to convert based on a `ma_format` variable. Use -`ma_convert_pcm_frames_format()` to convert PCM frames where you want to specify the frame count -and channel count as a variable instead of the total sample count. - - -10.1.1. Dithering ------------------ -Dithering can be set using the ditherMode parameter. - -The different dithering modes include the following, in order of efficiency: - - +-----------+--------------------------+ - | Type | Enum Token | - +-----------+--------------------------+ - | None | ma_dither_mode_none | - | Rectangle | ma_dither_mode_rectangle | - | Triangle | ma_dither_mode_triangle | - +-----------+--------------------------+ - -Note that even if the dither mode is set to something other than `ma_dither_mode_none`, it will be -ignored for conversions where dithering is not needed. Dithering is available for the following -conversions: - - ``` - s16 -> u8 - s24 -> u8 - s32 -> u8 - f32 -> u8 - s24 -> s16 - s32 -> s16 - f32 -> s16 - ``` - -Note that it is not an error to pass something other than ma_dither_mode_none for conversions where -dither is not used. It will just be ignored. - - - -10.2. Channel Conversion ------------------------- -Channel conversion is used for channel rearrangement and conversion from one channel count to -another. The `ma_channel_converter` API is used for channel conversion. Below is an example of -initializing a simple channel converter which converts from mono to stereo. - - ```c - ma_channel_converter_config config = ma_channel_converter_config_init( - ma_format, // Sample format - 1, // Input channels - NULL, // Input channel map - 2, // Output channels - NULL, // Output channel map - ma_channel_mix_mode_default); // The mixing algorithm to use when combining channels. - - result = ma_channel_converter_init(&config, NULL, &converter); - if (result != MA_SUCCESS) { - // Error. - } - ``` - -To perform the conversion simply call `ma_channel_converter_process_pcm_frames()` like so: - - ```c - ma_result result = ma_channel_converter_process_pcm_frames(&converter, pFramesOut, pFramesIn, frameCount); - if (result != MA_SUCCESS) { - // Error. - } - ``` - -It is up to the caller to ensure the output buffer is large enough to accommodate the new PCM -frames. - -Input and output PCM frames are always interleaved. Deinterleaved layouts are not supported. - - -10.2.1. Channel Mapping ------------------------ -In addition to converting from one channel count to another, like the example above, the channel -converter can also be used to rearrange channels. When initializing the channel converter, you can -optionally pass in channel maps for both the input and output frames. If the channel counts are the -same, and each channel map contains the same channel positions with the exception that they're in -a different order, a simple shuffling of the channels will be performed. If, however, there is not -a 1:1 mapping of channel positions, or the channel counts differ, the input channels will be mixed -based on a mixing mode which is specified when initializing the `ma_channel_converter_config` -object. - -When converting from mono to multi-channel, the mono channel is simply copied to each output -channel. When going the other way around, the audio of each output channel is simply averaged and -copied to the mono channel. - -In more complicated cases blending is used. The `ma_channel_mix_mode_simple` mode will drop excess -channels and silence extra channels. For example, converting from 4 to 2 channels, the 3rd and 4th -channels will be dropped, whereas converting from 2 to 4 channels will put silence into the 3rd and -4th channels. - -The `ma_channel_mix_mode_rectangle` mode uses spacial locality based on a rectangle to compute a -simple distribution between input and output. Imagine sitting in the middle of a room, with -speakers on the walls representing channel positions. The `MA_CHANNEL_FRONT_LEFT` position can be -thought of as being in the corner of the front and left walls. - -Finally, the `ma_channel_mix_mode_custom_weights` mode can be used to use custom user-defined -weights. Custom weights can be passed in as the last parameter of -`ma_channel_converter_config_init()`. - -Predefined channel maps can be retrieved with `ma_channel_map_init_standard()`. This takes a -`ma_standard_channel_map` enum as it's first parameter, which can be one of the following: - - +-----------------------------------+-----------------------------------------------------------+ - | Name | Description | - +-----------------------------------+-----------------------------------------------------------+ - | ma_standard_channel_map_default | Default channel map used by miniaudio. See below. | - | ma_standard_channel_map_microsoft | Channel map used by Microsoft's bitfield channel maps. | - | ma_standard_channel_map_alsa | Default ALSA channel map. | - | ma_standard_channel_map_rfc3551 | RFC 3551. Based on AIFF. | - | ma_standard_channel_map_flac | FLAC channel map. | - | ma_standard_channel_map_vorbis | Vorbis channel map. | - | ma_standard_channel_map_sound4 | FreeBSD's sound(4). | - | ma_standard_channel_map_sndio | sndio channel map. http://www.sndio.org/tips.html. | - | ma_standard_channel_map_webaudio | https://webaudio.github.io/web-audio-api/#ChannelOrdering | - +-----------------------------------+-----------------------------------------------------------+ - -Below are the channel maps used by default in miniaudio (`ma_standard_channel_map_default`): - - +---------------+---------------------------------+ - | Channel Count | Mapping | - +---------------+---------------------------------+ - | 1 (Mono) | 0: MA_CHANNEL_MONO | - +---------------+---------------------------------+ - | 2 (Stereo) | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT | - +---------------+---------------------------------+ - | 3 | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT
| - | | 2: MA_CHANNEL_FRONT_CENTER | - +---------------+---------------------------------+ - | 4 (Surround) | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT
| - | | 2: MA_CHANNEL_FRONT_CENTER
| - | | 3: MA_CHANNEL_BACK_CENTER | - +---------------+---------------------------------+ - | 5 | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT
| - | | 2: MA_CHANNEL_FRONT_CENTER
| - | | 3: MA_CHANNEL_BACK_LEFT
| - | | 4: MA_CHANNEL_BACK_RIGHT | - +---------------+---------------------------------+ - | 6 (5.1) | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT
| - | | 2: MA_CHANNEL_FRONT_CENTER
| - | | 3: MA_CHANNEL_LFE
| - | | 4: MA_CHANNEL_SIDE_LEFT
| - | | 5: MA_CHANNEL_SIDE_RIGHT | - +---------------+---------------------------------+ - | 7 | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT
| - | | 2: MA_CHANNEL_FRONT_CENTER
| - | | 3: MA_CHANNEL_LFE
| - | | 4: MA_CHANNEL_BACK_CENTER
| - | | 4: MA_CHANNEL_SIDE_LEFT
| - | | 5: MA_CHANNEL_SIDE_RIGHT | - +---------------+---------------------------------+ - | 8 (7.1) | 0: MA_CHANNEL_FRONT_LEFT
| - | | 1: MA_CHANNEL_FRONT_RIGHT
| - | | 2: MA_CHANNEL_FRONT_CENTER
| - | | 3: MA_CHANNEL_LFE
| - | | 4: MA_CHANNEL_BACK_LEFT
| - | | 5: MA_CHANNEL_BACK_RIGHT
| - | | 6: MA_CHANNEL_SIDE_LEFT
| - | | 7: MA_CHANNEL_SIDE_RIGHT | - +---------------+---------------------------------+ - | Other | All channels set to 0. This | - | | is equivalent to the same | - | | mapping as the device. | - +---------------+---------------------------------+ - - - -10.3. Resampling ----------------- -Resampling is achieved with the `ma_resampler` object. To create a resampler object, do something -like the following: - - ```c - ma_resampler_config config = ma_resampler_config_init( - ma_format_s16, - channels, - sampleRateIn, - sampleRateOut, - ma_resample_algorithm_linear); - - ma_resampler resampler; - ma_result result = ma_resampler_init(&config, &resampler); - if (result != MA_SUCCESS) { - // An error occurred... - } - ``` - -Do the following to uninitialize the resampler: - - ```c - ma_resampler_uninit(&resampler); - ``` - -The following example shows how data can be processed - - ```c - ma_uint64 frameCountIn = 1000; - ma_uint64 frameCountOut = 2000; - ma_result result = ma_resampler_process_pcm_frames(&resampler, pFramesIn, &frameCountIn, pFramesOut, &frameCountOut); - if (result != MA_SUCCESS) { - // An error occurred... - } - - // At this point, frameCountIn contains the number of input frames that were consumed and frameCountOut contains the - // number of output frames written. - ``` - -To initialize the resampler you first need to set up a config (`ma_resampler_config`) with -`ma_resampler_config_init()`. You need to specify the sample format you want to use, the number of -channels, the input and output sample rate, and the algorithm. - -The sample format can be either `ma_format_s16` or `ma_format_f32`. If you need a different format -you will need to perform pre- and post-conversions yourself where necessary. Note that the format -is the same for both input and output. The format cannot be changed after initialization. - -The resampler supports multiple channels and is always interleaved (both input and output). The -channel count cannot be changed after initialization. - -The sample rates can be anything other than zero, and are always specified in hertz. They should be -set to something like 44100, etc. The sample rate is the only configuration property that can be -changed after initialization. - -The miniaudio resampler has built-in support for the following algorithms: - - +-----------+------------------------------+ - | Algorithm | Enum Token | - +-----------+------------------------------+ - | Linear | ma_resample_algorithm_linear | - | Custom | ma_resample_algorithm_custom | - +-----------+------------------------------+ - -The algorithm cannot be changed after initialization. - -Processing always happens on a per PCM frame basis and always assumes interleaved input and output. -De-interleaved processing is not supported. To process frames, use -`ma_resampler_process_pcm_frames()`. On input, this function takes the number of output frames you -can fit in the output buffer and the number of input frames contained in the input buffer. On -output these variables contain the number of output frames that were written to the output buffer -and the number of input frames that were consumed in the process. You can pass in NULL for the -input buffer in which case it will be treated as an infinitely large buffer of zeros. The output -buffer can also be NULL, in which case the processing will be treated as seek. - -The sample rate can be changed dynamically on the fly. You can change this with explicit sample -rates with `ma_resampler_set_rate()` and also with a decimal ratio with -`ma_resampler_set_rate_ratio()`. The ratio is in/out. - -Sometimes it's useful to know exactly how many input frames will be required to output a specific -number of frames. You can calculate this with `ma_resampler_get_required_input_frame_count()`. -Likewise, it's sometimes useful to know exactly how many frames would be output given a certain -number of input frames. You can do this with `ma_resampler_get_expected_output_frame_count()`. - -Due to the nature of how resampling works, the resampler introduces some latency. This can be -retrieved in terms of both the input rate and the output rate with -`ma_resampler_get_input_latency()` and `ma_resampler_get_output_latency()`. - - -10.3.1. Resampling Algorithms ------------------------------ -The choice of resampling algorithm depends on your situation and requirements. - - -10.3.1.1. Linear Resampling ---------------------------- -The linear resampler is the fastest, but comes at the expense of poorer quality. There is, however, -some control over the quality of the linear resampler which may make it a suitable option depending -on your requirements. - -The linear resampler performs low-pass filtering before or after downsampling or upsampling, -depending on the sample rates you're converting between. When decreasing the sample rate, the -low-pass filter will be applied before downsampling. When increasing the rate it will be performed -after upsampling. By default a fourth order low-pass filter will be applied. This can be configured -via the `lpfOrder` configuration variable. Setting this to 0 will disable filtering. - -The low-pass filter has a cutoff frequency which defaults to half the sample rate of the lowest of -the input and output sample rates (Nyquist Frequency). - -The API for the linear resampler is the same as the main resampler API, only it's called -`ma_linear_resampler`. - - -10.3.2. Custom Resamplers -------------------------- -You can implement a custom resampler by using the `ma_resample_algorithm_custom` resampling -algorithm and setting a vtable in the resampler config: - - ```c - ma_resampler_config config = ma_resampler_config_init(..., ma_resample_algorithm_custom); - config.pBackendVTable = &g_customResamplerVTable; - ``` - -Custom resamplers are useful if the stock algorithms are not appropriate for your use case. You -need to implement the required functions in `ma_resampling_backend_vtable`. Note that not all -functions in the vtable need to be implemented, but if it's possible to implement, they should be. - -You can use the `ma_linear_resampler` object for an example on how to implement the vtable. The -`onGetHeapSize` callback is used to calculate the size of any internal heap allocation the custom -resampler will need to make given the supplied config. When you initialize the resampler via the -`onInit` callback, you'll be given a pointer to a heap allocation which is where you should store -the heap allocated data. You should not free this data in `onUninit` because miniaudio will manage -it for you. - -The `onProcess` callback is where the actual resampling takes place. On input, `pFrameCountIn` -points to a variable containing the number of frames in the `pFramesIn` buffer and -`pFrameCountOut` points to a variable containing the capacity in frames of the `pFramesOut` buffer. -On output, `pFrameCountIn` should be set to the number of input frames that were fully consumed, -whereas `pFrameCountOut` should be set to the number of frames that were written to `pFramesOut`. - -The `onSetRate` callback is optional and is used for dynamically changing the sample rate. If -dynamic rate changes are not supported, you can set this callback to NULL. - -The `onGetInputLatency` and `onGetOutputLatency` functions are used for retrieving the latency in -input and output rates respectively. These can be NULL in which case latency calculations will be -assumed to be NULL. - -The `onGetRequiredInputFrameCount` callback is used to give miniaudio a hint as to how many input -frames are required to be available to produce the given number of output frames. Likewise, the -`onGetExpectedOutputFrameCount` callback is used to determine how many output frames will be -produced given the specified number of input frames. miniaudio will use these as a hint, but they -are optional and can be set to NULL if you're unable to implement them. - - - -10.4. General Data Conversion ------------------------------ -The `ma_data_converter` API can be used to wrap sample format conversion, channel conversion and -resampling into one operation. This is what miniaudio uses internally to convert between the format -requested when the device was initialized and the format of the backend's native device. The API -for general data conversion is very similar to the resampling API. Create a `ma_data_converter` -object like this: - - ```c - ma_data_converter_config config = ma_data_converter_config_init( - inputFormat, - outputFormat, - inputChannels, - outputChannels, - inputSampleRate, - outputSampleRate - ); - - ma_data_converter converter; - ma_result result = ma_data_converter_init(&config, NULL, &converter); - if (result != MA_SUCCESS) { - // An error occurred... - } - ``` - -In the example above we use `ma_data_converter_config_init()` to initialize the config, however -there's many more properties that can be configured, such as channel maps and resampling quality. -Something like the following may be more suitable depending on your requirements: - - ```c - ma_data_converter_config config = ma_data_converter_config_init_default(); - config.formatIn = inputFormat; - config.formatOut = outputFormat; - config.channelsIn = inputChannels; - config.channelsOut = outputChannels; - config.sampleRateIn = inputSampleRate; - config.sampleRateOut = outputSampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_flac, config.channelMapIn, sizeof(config.channelMapIn)/sizeof(config.channelMapIn[0]), config.channelCountIn); - config.resampling.linear.lpfOrder = MA_MAX_FILTER_ORDER; - ``` - -Do the following to uninitialize the data converter: - - ```c - ma_data_converter_uninit(&converter, NULL); - ``` - -The following example shows how data can be processed - - ```c - ma_uint64 frameCountIn = 1000; - ma_uint64 frameCountOut = 2000; - ma_result result = ma_data_converter_process_pcm_frames(&converter, pFramesIn, &frameCountIn, pFramesOut, &frameCountOut); - if (result != MA_SUCCESS) { - // An error occurred... - } - - // At this point, frameCountIn contains the number of input frames that were consumed and frameCountOut contains the number - // of output frames written. - ``` - -The data converter supports multiple channels and is always interleaved (both input and output). -The channel count cannot be changed after initialization. - -Sample rates can be anything other than zero, and are always specified in hertz. They should be set -to something like 44100, etc. The sample rate is the only configuration property that can be -changed after initialization, but only if the `resampling.allowDynamicSampleRate` member of -`ma_data_converter_config` is set to `MA_TRUE`. To change the sample rate, use -`ma_data_converter_set_rate()` or `ma_data_converter_set_rate_ratio()`. The ratio must be in/out. -The resampling algorithm cannot be changed after initialization. - -Processing always happens on a per PCM frame basis and always assumes interleaved input and output. -De-interleaved processing is not supported. To process frames, use -`ma_data_converter_process_pcm_frames()`. On input, this function takes the number of output frames -you can fit in the output buffer and the number of input frames contained in the input buffer. On -output these variables contain the number of output frames that were written to the output buffer -and the number of input frames that were consumed in the process. You can pass in NULL for the -input buffer in which case it will be treated as an infinitely large -buffer of zeros. The output buffer can also be NULL, in which case the processing will be treated -as seek. - -Sometimes it's useful to know exactly how many input frames will be required to output a specific -number of frames. You can calculate this with `ma_data_converter_get_required_input_frame_count()`. -Likewise, it's sometimes useful to know exactly how many frames would be output given a certain -number of input frames. You can do this with `ma_data_converter_get_expected_output_frame_count()`. - -Due to the nature of how resampling works, the data converter introduces some latency if resampling -is required. This can be retrieved in terms of both the input rate and the output rate with -`ma_data_converter_get_input_latency()` and `ma_data_converter_get_output_latency()`. - - - -11. Filtering -============= - -11.1. Biquad Filtering ----------------------- -Biquad filtering is achieved with the `ma_biquad` API. Example: - - ```c - ma_biquad_config config = ma_biquad_config_init(ma_format_f32, channels, b0, b1, b2, a0, a1, a2); - ma_result result = ma_biquad_init(&config, &biquad); - if (result != MA_SUCCESS) { - // Error. - } - - ... - - ma_biquad_process_pcm_frames(&biquad, pFramesOut, pFramesIn, frameCount); - ``` - -Biquad filtering is implemented using transposed direct form 2. The numerator coefficients are b0, -b1 and b2, and the denominator coefficients are a0, a1 and a2. The a0 coefficient is required and -coefficients must not be pre-normalized. - -Supported formats are `ma_format_s16` and `ma_format_f32`. If you need to use a different format -you need to convert it yourself beforehand. When using `ma_format_s16` the biquad filter will use -fixed point arithmetic. When using `ma_format_f32`, floating point arithmetic will be used. - -Input and output frames are always interleaved. - -Filtering can be applied in-place by passing in the same pointer for both the input and output -buffers, like so: - - ```c - ma_biquad_process_pcm_frames(&biquad, pMyData, pMyData, frameCount); - ``` - -If you need to change the values of the coefficients, but maintain the values in the registers you -can do so with `ma_biquad_reinit()`. This is useful if you need to change the properties of the -filter while keeping the values of registers valid to avoid glitching. Do not use -`ma_biquad_init()` for this as it will do a full initialization which involves clearing the -registers to 0. Note that changing the format or channel count after initialization is invalid and -will result in an error. - - -11.2. Low-Pass Filtering ------------------------- -Low-pass filtering is achieved with the following APIs: - - +---------+------------------------------------------+ - | API | Description | - +---------+------------------------------------------+ - | ma_lpf1 | First order low-pass filter | - | ma_lpf2 | Second order low-pass filter | - | ma_lpf | High order low-pass filter (Butterworth) | - +---------+------------------------------------------+ - -Low-pass filter example: - - ```c - ma_lpf_config config = ma_lpf_config_init(ma_format_f32, channels, sampleRate, cutoffFrequency, order); - ma_result result = ma_lpf_init(&config, &lpf); - if (result != MA_SUCCESS) { - // Error. - } - - ... - - ma_lpf_process_pcm_frames(&lpf, pFramesOut, pFramesIn, frameCount); - ``` - -Supported formats are `ma_format_s16` and` ma_format_f32`. If you need to use a different format -you need to convert it yourself beforehand. Input and output frames are always interleaved. - -Filtering can be applied in-place by passing in the same pointer for both the input and output -buffers, like so: - - ```c - ma_lpf_process_pcm_frames(&lpf, pMyData, pMyData, frameCount); - ``` - -The maximum filter order is limited to `MA_MAX_FILTER_ORDER` which is set to 8. If you need more, -you can chain first and second order filters together. - - ```c - for (iFilter = 0; iFilter < filterCount; iFilter += 1) { - ma_lpf2_process_pcm_frames(&lpf2[iFilter], pMyData, pMyData, frameCount); - } - ``` - -If you need to change the configuration of the filter, but need to maintain the state of internal -registers you can do so with `ma_lpf_reinit()`. This may be useful if you need to change the sample -rate and/or cutoff frequency dynamically while maintaining smooth transitions. Note that changing the -format or channel count after initialization is invalid and will result in an error. - -The `ma_lpf` object supports a configurable order, but if you only need a first order filter you -may want to consider using `ma_lpf1`. Likewise, if you only need a second order filter you can use -`ma_lpf2`. The advantage of this is that they're lighter weight and a bit more efficient. - -If an even filter order is specified, a series of second order filters will be processed in a -chain. If an odd filter order is specified, a first order filter will be applied, followed by a -series of second order filters in a chain. - - -11.3. High-Pass Filtering -------------------------- -High-pass filtering is achieved with the following APIs: - - +---------+-------------------------------------------+ - | API | Description | - +---------+-------------------------------------------+ - | ma_hpf1 | First order high-pass filter | - | ma_hpf2 | Second order high-pass filter | - | ma_hpf | High order high-pass filter (Butterworth) | - +---------+-------------------------------------------+ - -High-pass filters work exactly the same as low-pass filters, only the APIs are called `ma_hpf1`, -`ma_hpf2` and `ma_hpf`. See example code for low-pass filters for example usage. - - -11.4. Band-Pass Filtering -------------------------- -Band-pass filtering is achieved with the following APIs: - - +---------+-------------------------------+ - | API | Description | - +---------+-------------------------------+ - | ma_bpf2 | Second order band-pass filter | - | ma_bpf | High order band-pass filter | - +---------+-------------------------------+ - -Band-pass filters work exactly the same as low-pass filters, only the APIs are called `ma_bpf2` and -`ma_hpf`. See example code for low-pass filters for example usage. Note that the order for -band-pass filters must be an even number which means there is no first order band-pass filter, -unlike low-pass and high-pass filters. - - -11.5. Notch Filtering ---------------------- -Notch filtering is achieved with the following APIs: - - +-----------+------------------------------------------+ - | API | Description | - +-----------+------------------------------------------+ - | ma_notch2 | Second order notching filter | - +-----------+------------------------------------------+ - - -11.6. Peaking EQ Filtering -------------------------- -Peaking filtering is achieved with the following APIs: - - +----------+------------------------------------------+ - | API | Description | - +----------+------------------------------------------+ - | ma_peak2 | Second order peaking filter | - +----------+------------------------------------------+ - - -11.7. Low Shelf Filtering -------------------------- -Low shelf filtering is achieved with the following APIs: - - +-------------+------------------------------------------+ - | API | Description | - +-------------+------------------------------------------+ - | ma_loshelf2 | Second order low shelf filter | - +-------------+------------------------------------------+ - -Where a high-pass filter is used to eliminate lower frequencies, a low shelf filter can be used to -just turn them down rather than eliminate them entirely. - - -11.8. High Shelf Filtering --------------------------- -High shelf filtering is achieved with the following APIs: - - +-------------+------------------------------------------+ - | API | Description | - +-------------+------------------------------------------+ - | ma_hishelf2 | Second order high shelf filter | - +-------------+------------------------------------------+ - -The high shelf filter has the same API as the low shelf filter, only you would use `ma_hishelf` -instead of `ma_loshelf`. Where a low shelf filter is used to adjust the volume of low frequencies, -the high shelf filter does the same thing for high frequencies. - - - - -12. Waveform and Noise Generation -================================= - -12.1. Waveforms ---------------- -miniaudio supports generation of sine, square, triangle and sawtooth waveforms. This is achieved -with the `ma_waveform` API. Example: - - ```c - ma_waveform_config config = ma_waveform_config_init( - FORMAT, - CHANNELS, - SAMPLE_RATE, - ma_waveform_type_sine, - amplitude, - frequency); - - ma_waveform waveform; - ma_result result = ma_waveform_init(&config, &waveform); - if (result != MA_SUCCESS) { - // Error. - } - - ... - - ma_waveform_read_pcm_frames(&waveform, pOutput, frameCount); - ``` - -The amplitude, frequency, type, and sample rate can be changed dynamically with -`ma_waveform_set_amplitude()`, `ma_waveform_set_frequency()`, `ma_waveform_set_type()`, and -`ma_waveform_set_sample_rate()` respectively. - -You can invert the waveform by setting the amplitude to a negative value. You can use this to -control whether or not a sawtooth has a positive or negative ramp, for example. - -Below are the supported waveform types: - - +---------------------------+ - | Enum Name | - +---------------------------+ - | ma_waveform_type_sine | - | ma_waveform_type_square | - | ma_waveform_type_triangle | - | ma_waveform_type_sawtooth | - +---------------------------+ - - - -12.2. Noise ------------ -miniaudio supports generation of white, pink and Brownian noise via the `ma_noise` API. Example: - - ```c - ma_noise_config config = ma_noise_config_init( - FORMAT, - CHANNELS, - ma_noise_type_white, - SEED, - amplitude); - - ma_noise noise; - ma_result result = ma_noise_init(&config, &noise); - if (result != MA_SUCCESS) { - // Error. - } - - ... - - ma_noise_read_pcm_frames(&noise, pOutput, frameCount); - ``` - -The noise API uses simple LCG random number generation. It supports a custom seed which is useful -for things like automated testing requiring reproducibility. Setting the seed to zero will default -to `MA_DEFAULT_LCG_SEED`. - -The amplitude and seed can be changed dynamically with `ma_noise_set_amplitude()` and -`ma_noise_set_seed()` respectively. - -By default, the noise API will use different values for different channels. So, for example, the -left side in a stereo stream will be different to the right side. To instead have each channel use -the same random value, set the `duplicateChannels` member of the noise config to true, like so: - - ```c - config.duplicateChannels = MA_TRUE; - ``` - -Below are the supported noise types. - - +------------------------+ - | Enum Name | - +------------------------+ - | ma_noise_type_white | - | ma_noise_type_pink | - | ma_noise_type_brownian | - +------------------------+ - - - -13. Audio Buffers -================= -miniaudio supports reading from a buffer of raw audio data via the `ma_audio_buffer` API. This can -read from memory that's managed by the application, but can also handle the memory management for -you internally. Memory management is flexible and should support most use cases. - -Audio buffers are initialised using the standard configuration system used everywhere in miniaudio: - - ```c - ma_audio_buffer_config config = ma_audio_buffer_config_init( - format, - channels, - sizeInFrames, - pExistingData, - &allocationCallbacks); - - ma_audio_buffer buffer; - result = ma_audio_buffer_init(&config, &buffer); - if (result != MA_SUCCESS) { - // Error. - } - - ... - - ma_audio_buffer_uninit(&buffer); - ``` - -In the example above, the memory pointed to by `pExistingData` will *not* be copied and is how an -application can do self-managed memory allocation. If you would rather make a copy of the data, use -`ma_audio_buffer_init_copy()`. To uninitialize the buffer, use `ma_audio_buffer_uninit()`. - -Sometimes it can be convenient to allocate the memory for the `ma_audio_buffer` structure and the -raw audio data in a contiguous block of memory. That is, the raw audio data will be located -immediately after the `ma_audio_buffer` structure. To do this, use -`ma_audio_buffer_alloc_and_init()`: - - ```c - ma_audio_buffer_config config = ma_audio_buffer_config_init( - format, - channels, - sizeInFrames, - pExistingData, - &allocationCallbacks); - - ma_audio_buffer* pBuffer - result = ma_audio_buffer_alloc_and_init(&config, &pBuffer); - if (result != MA_SUCCESS) { - // Error - } - - ... - - ma_audio_buffer_uninit_and_free(&buffer); - ``` - -If you initialize the buffer with `ma_audio_buffer_alloc_and_init()` you should uninitialize it -with `ma_audio_buffer_uninit_and_free()`. In the example above, the memory pointed to by -`pExistingData` will be copied into the buffer, which is contrary to the behavior of -`ma_audio_buffer_init()`. - -An audio buffer has a playback cursor just like a decoder. As you read frames from the buffer, the -cursor moves forward. The last parameter (`loop`) can be used to determine if the buffer should -loop. The return value is the number of frames actually read. If this is less than the number of -frames requested it means the end has been reached. This should never happen if the `loop` -parameter is set to true. If you want to manually loop back to the start, you can do so with with -`ma_audio_buffer_seek_to_pcm_frame(pAudioBuffer, 0)`. Below is an example for reading data from an -audio buffer. - - ```c - ma_uint64 framesRead = ma_audio_buffer_read_pcm_frames(pAudioBuffer, pFramesOut, desiredFrameCount, isLooping); - if (framesRead < desiredFrameCount) { - // If not looping, this means the end has been reached. This should never happen in looping mode with valid input. - } - ``` - -Sometimes you may want to avoid the cost of data movement between the internal buffer and the -output buffer. Instead you can use memory mapping to retrieve a pointer to a segment of data: - - ```c - void* pMappedFrames; - ma_uint64 frameCount = frameCountToTryMapping; - ma_result result = ma_audio_buffer_map(pAudioBuffer, &pMappedFrames, &frameCount); - if (result == MA_SUCCESS) { - // Map was successful. The value in frameCount will be how many frames were _actually_ mapped, which may be - // less due to the end of the buffer being reached. - ma_copy_pcm_frames(pFramesOut, pMappedFrames, frameCount, pAudioBuffer->format, pAudioBuffer->channels); - - // You must unmap the buffer. - ma_audio_buffer_unmap(pAudioBuffer, frameCount); - } - ``` - -When you use memory mapping, the read cursor is increment by the frame count passed in to -`ma_audio_buffer_unmap()`. If you decide not to process every frame you can pass in a value smaller -than the value returned by `ma_audio_buffer_map()`. The disadvantage to using memory mapping is -that it does not handle looping for you. You can determine if the buffer is at the end for the -purpose of looping with `ma_audio_buffer_at_end()` or by inspecting the return value of -`ma_audio_buffer_unmap()` and checking if it equals `MA_AT_END`. You should not treat `MA_AT_END` -as an error when returned by `ma_audio_buffer_unmap()`. - - - -14. Ring Buffers -================ -miniaudio supports lock free (single producer, single consumer) ring buffers which are exposed via -the `ma_rb` and `ma_pcm_rb` APIs. The `ma_rb` API operates on bytes, whereas the `ma_pcm_rb` -operates on PCM frames. They are otherwise identical as `ma_pcm_rb` is just a wrapper around -`ma_rb`. - -Unlike most other APIs in miniaudio, ring buffers support both interleaved and deinterleaved -streams. The caller can also allocate their own backing memory for the ring buffer to use -internally for added flexibility. Otherwise the ring buffer will manage it's internal memory for -you. - -The examples below use the PCM frame variant of the ring buffer since that's most likely the one -you will want to use. To initialize a ring buffer, do something like the following: - - ```c - ma_pcm_rb rb; - ma_result result = ma_pcm_rb_init(FORMAT, CHANNELS, BUFFER_SIZE_IN_FRAMES, NULL, NULL, &rb); - if (result != MA_SUCCESS) { - // Error - } - ``` - -The `ma_pcm_rb_init()` function takes the sample format and channel count as parameters because -it's the PCM variant of the ring buffer API. For the regular ring buffer that operates on bytes you -would call `ma_rb_init()` which leaves these out and just takes the size of the buffer in bytes -instead of frames. The fourth parameter is an optional pre-allocated buffer and the fifth parameter -is a pointer to a `ma_allocation_callbacks` structure for custom memory allocation routines. -Passing in `NULL` for this results in `MA_MALLOC()` and `MA_FREE()` being used. - -Use `ma_pcm_rb_init_ex()` if you need a deinterleaved buffer. The data for each sub-buffer is -offset from each other based on the stride. To manage your sub-buffers you can use -`ma_pcm_rb_get_subbuffer_stride()`, `ma_pcm_rb_get_subbuffer_offset()` and -`ma_pcm_rb_get_subbuffer_ptr()`. - -Use `ma_pcm_rb_acquire_read()` and `ma_pcm_rb_acquire_write()` to retrieve a pointer to a section -of the ring buffer. You specify the number of frames you need, and on output it will set to what -was actually acquired. If the read or write pointer is positioned such that the number of frames -requested will require a loop, it will be clamped to the end of the buffer. Therefore, the number -of frames you're given may be less than the number you requested. - -After calling `ma_pcm_rb_acquire_read()` or `ma_pcm_rb_acquire_write()`, you do your work on the -buffer and then "commit" it with `ma_pcm_rb_commit_read()` or `ma_pcm_rb_commit_write()`. This is -where the read/write pointers are updated. When you commit you need to pass in the buffer that was -returned by the earlier call to `ma_pcm_rb_acquire_read()` or `ma_pcm_rb_acquire_write()` and is -only used for validation. The number of frames passed to `ma_pcm_rb_commit_read()` and -`ma_pcm_rb_commit_write()` is what's used to increment the pointers, and can be less that what was -originally requested. - -If you want to correct for drift between the write pointer and the read pointer you can use a -combination of `ma_pcm_rb_pointer_distance()`, `ma_pcm_rb_seek_read()` and -`ma_pcm_rb_seek_write()`. Note that you can only move the pointers forward, and you should only -move the read pointer forward via the consumer thread, and the write pointer forward by the -producer thread. If there is too much space between the pointers, move the read pointer forward. If -there is too little space between the pointers, move the write pointer forward. - -You can use a ring buffer at the byte level instead of the PCM frame level by using the `ma_rb` -API. This is exactly the same, only you will use the `ma_rb` functions instead of `ma_pcm_rb` and -instead of frame counts you will pass around byte counts. - -The maximum size of the buffer in bytes is `0x7FFFFFFF-(MA_SIMD_ALIGNMENT-1)` due to the most -significant bit being used to encode a loop flag and the internally managed buffers always being -aligned to `MA_SIMD_ALIGNMENT`. - -Note that the ring buffer is only thread safe when used by a single consumer thread and single -producer thread. - - - -15. Backends -============ -The following backends are supported by miniaudio. These are listed in order of default priority. -When no backend is specified when initializing a context or device, miniaudio will attempt to use -each of these backends in the order listed in the table below. - -Note that backends that are not usable by the build target will not be included in the build. For -example, ALSA, which is specific to Linux, will not be included in the Windows build. - - +-------------+-----------------------+--------------------------------------------------------+ - | Name | Enum Name | Supported Operating Systems | - +-------------+-----------------------+--------------------------------------------------------+ - | WASAPI | ma_backend_wasapi | Windows Vista+ | - | DirectSound | ma_backend_dsound | Windows XP+ | - | WinMM | ma_backend_winmm | Windows 95+ | - | Core Audio | ma_backend_coreaudio | macOS, iOS | - | sndio | ma_backend_sndio | OpenBSD | - | audio(4) | ma_backend_audio4 | NetBSD, OpenBSD | - | OSS | ma_backend_oss | FreeBSD | - | PulseAudio | ma_backend_pulseaudio | Cross Platform (disabled on Windows, BSD and Android) | - | ALSA | ma_backend_alsa | Linux | - | JACK | ma_backend_jack | Cross Platform (disabled on BSD and Android) | - | AAudio | ma_backend_aaudio | Android 8+ | - | OpenSL ES | ma_backend_opensl | Android (API level 16+) | - | Web Audio | ma_backend_webaudio | Web (via Emscripten) | - | Custom | ma_backend_custom | Cross Platform | - | Null | ma_backend_null | Cross Platform (not used on Web) | - +-------------+-----------------------+--------------------------------------------------------+ - -Some backends have some nuance details you may want to be aware of. - -15.1. WASAPI ------------- -- Low-latency shared mode will be disabled when using an application-defined sample rate which is - different to the device's native sample rate. To work around this, set `wasapi.noAutoConvertSRC` - to true in the device config. This is due to IAudioClient3_InitializeSharedAudioStream() failing - when the `AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM` flag is specified. Setting wasapi.noAutoConvertSRC - will result in miniaudio's internal resampler being used instead which will in turn enable the - use of low-latency shared mode. - -15.2. PulseAudio ----------------- -- If you experience bad glitching/noise on Arch Linux, consider this fix from the Arch wiki: - https://wiki.archlinux.org/index.php/PulseAudio/Troubleshooting#Glitches,_skips_or_crackling. - Alternatively, consider using a different backend such as ALSA. - -15.3. Android -------------- -- To capture audio on Android, remember to add the RECORD_AUDIO permission to your manifest: - `` -- With OpenSL|ES, only a single ma_context can be active at any given time. This is due to a - limitation with OpenSL|ES. -- With AAudio, only default devices are enumerated. This is due to AAudio not having an enumeration - API (devices are enumerated through Java). You can however perform your own device enumeration - through Java and then set the ID in the ma_device_id structure (ma_device_id.aaudio) and pass it - to ma_device_init(). -- The backend API will perform resampling where possible. The reason for this as opposed to using - miniaudio's built-in resampler is to take advantage of any potential device-specific - optimizations the driver may implement. - -BSD ---- -- The sndio backend is currently only enabled on OpenBSD builds. -- The audio(4) backend is supported on OpenBSD, but you may need to disable sndiod before you can - use it. - -15.4. UWP ---------- -- UWP only supports default playback and capture devices. -- UWP requires the Microphone capability to be enabled in the application's manifest (Package.appxmanifest): - - ``` - - ... - - - - - ``` - -15.5. Web Audio / Emscripten ----------------------------- -- You cannot use `-std=c*` compiler flags, nor `-ansi`. This only applies to the Emscripten build. -- The first time a context is initialized it will create a global object called "miniaudio" whose - primary purpose is to act as a factory for device objects. -- Currently the Web Audio backend uses ScriptProcessorNode's, but this may need to change later as - they've been deprecated. -- Google has implemented a policy in their browsers that prevent automatic media output without - first receiving some kind of user input. The following web page has additional details: - https://developers.google.com/web/updates/2017/09/autoplay-policy-changes. Starting the device - may fail if you try to start playback without first handling some kind of user input. - - - -16. Optimization Tips -===================== -See below for some tips on improving performance. - -16.1. Low Level API -------------------- -- In the data callback, if your data is already clipped prior to copying it into the output buffer, - set the `noClip` config option in the device config to true. This will disable miniaudio's built - in clipping function. -- By default, miniaudio will pre-silence the data callback's output buffer. If you know that you - will always write valid data to the output buffer you can disable pre-silencing by setting the - `noPreSilence` config option in the device config to true. - -16.2. High Level API --------------------- -- If a sound does not require doppler or pitch shifting, consider disabling pitching by - initializing the sound with the `MA_SOUND_FLAG_NO_PITCH` flag. -- If a sound does not require spatialization, disable it by initializing the sound with the - `MA_SOUND_FLAG_NO_SPATIALIZATION` flag. It can be re-enabled again post-initialization with - `ma_sound_set_spatialization_enabled()`. -- If you know all of your sounds will always be the same sample rate, set the engine's sample - rate to match that of the sounds. Likewise, if you're using a self-managed resource manager, - consider setting the decoded sample rate to match your sounds. By configuring everything to - use a consistent sample rate, sample rate conversion can be avoided. - - - -17. Miscellaneous Notes -======================= -- Automatic stream routing is enabled on a per-backend basis. Support is explicitly enabled for - WASAPI and Core Audio, however other backends such as PulseAudio may naturally support it, though - not all have been tested. -- When compiling with VC6 and earlier, decoding is restricted to files less than 2GB in size. This - is due to 64-bit file APIs not being available. -*/ - -#ifndef miniaudio_h -#define miniaudio_h - -#ifdef __cplusplus -extern "C" { -#endif - -#define MA_STRINGIFY(x) #x -#define MA_XSTRINGIFY(x) MA_STRINGIFY(x) - -#define MA_VERSION_MAJOR 0 -#define MA_VERSION_MINOR 11 -#define MA_VERSION_REVISION 12 -#define MA_VERSION_STRING MA_XSTRINGIFY(MA_VERSION_MAJOR) "." MA_XSTRINGIFY(MA_VERSION_MINOR) "." MA_XSTRINGIFY(MA_VERSION_REVISION) - -#if defined(_MSC_VER) && !defined(__clang__) - #pragma warning(push) - #pragma warning(disable:4201) /* nonstandard extension used: nameless struct/union */ - #pragma warning(disable:4214) /* nonstandard extension used: bit field types other than int */ - #pragma warning(disable:4324) /* structure was padded due to alignment specifier */ -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wpedantic" /* For ISO C99 doesn't support unnamed structs/unions [-Wpedantic] */ - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc11-extensions" /* anonymous unions are a C11 extension */ - #endif -#endif - - - -#if defined(__LP64__) || defined(_WIN64) || (defined(__x86_64__) && !defined(__ILP32__)) || defined(_M_X64) || defined(__ia64) || defined(_M_IA64) || defined(__aarch64__) || defined(_M_ARM64) || defined(__powerpc64__) - #define MA_SIZEOF_PTR 8 -#else - #define MA_SIZEOF_PTR 4 -#endif - -#include /* For size_t. */ - -/* Sized types. */ -#if defined(MA_USE_STDINT) - #include - typedef int8_t ma_int8; - typedef uint8_t ma_uint8; - typedef int16_t ma_int16; - typedef uint16_t ma_uint16; - typedef int32_t ma_int32; - typedef uint32_t ma_uint32; - typedef int64_t ma_int64; - typedef uint64_t ma_uint64; -#else - typedef signed char ma_int8; - typedef unsigned char ma_uint8; - typedef signed short ma_int16; - typedef unsigned short ma_uint16; - typedef signed int ma_int32; - typedef unsigned int ma_uint32; - #if defined(_MSC_VER) && !defined(__clang__) - typedef signed __int64 ma_int64; - typedef unsigned __int64 ma_uint64; - #else - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wlong-long" - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc++11-long-long" - #endif - #endif - typedef signed long long ma_int64; - typedef unsigned long long ma_uint64; - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop - #endif - #endif -#endif /* MA_USE_STDINT */ - -#if MA_SIZEOF_PTR == 8 - typedef ma_uint64 ma_uintptr; -#else - typedef ma_uint32 ma_uintptr; -#endif - -typedef ma_uint8 ma_bool8; -typedef ma_uint32 ma_bool32; -#define MA_TRUE 1 -#define MA_FALSE 0 - -/* These float types are not used universally by miniaudio. It's to simplify some macro expansion for atomic types. */ -typedef float ma_float; -typedef double ma_double; - -typedef void* ma_handle; -typedef void* ma_ptr; -typedef void (* ma_proc)(void); - -#if defined(_MSC_VER) && !defined(_WCHAR_T_DEFINED) -typedef ma_uint16 wchar_t; -#endif - -/* Define NULL for some compilers. */ -#ifndef NULL -#define NULL 0 -#endif - -#if defined(SIZE_MAX) - #define MA_SIZE_MAX SIZE_MAX -#else - #define MA_SIZE_MAX 0xFFFFFFFF /* When SIZE_MAX is not defined by the standard library just default to the maximum 32-bit unsigned integer. */ -#endif - - -/* Platform/backend detection. */ -#if defined(_WIN32) || defined(__COSMOPOLITAN__) - #define MA_WIN32 - #if defined(MA_FORCE_UWP) || (defined(WINAPI_FAMILY) && ((defined(WINAPI_FAMILY_PC_APP) && WINAPI_FAMILY == WINAPI_FAMILY_PC_APP) || (defined(WINAPI_FAMILY_PHONE_APP) && WINAPI_FAMILY == WINAPI_FAMILY_PHONE_APP))) - #define MA_WIN32_UWP - #elif defined(WINAPI_FAMILY) && (defined(WINAPI_FAMILY_GAMES) && WINAPI_FAMILY == WINAPI_FAMILY_GAMES) - #define MA_WIN32_GDK - #else - #define MA_WIN32_DESKTOP - #endif -#endif -#if !defined(_WIN32) /* If it's not Win32, assume POSIX. */ - #define MA_POSIX - - /* - Use the MA_NO_PTHREAD_IN_HEADER option at your own risk. This is intentionally undocumented. - You can use this to avoid including pthread.h in the header section. The downside is that it - results in some fixed sized structures being declared for the various types that are used in - miniaudio. The risk here is that these types might be too small for a given platform. This - risk is yours to take and no support will be offered if you enable this option. - */ - #ifndef MA_NO_PTHREAD_IN_HEADER - #include /* Unfortunate #include, but needed for pthread_t, pthread_mutex_t and pthread_cond_t types. */ - typedef pthread_t ma_pthread_t; - typedef pthread_mutex_t ma_pthread_mutex_t; - typedef pthread_cond_t ma_pthread_cond_t; - #else - typedef ma_uintptr ma_pthread_t; - typedef union ma_pthread_mutex_t { char __data[40]; ma_uint64 __alignment; } ma_pthread_mutex_t; - typedef union ma_pthread_cond_t { char __data[48]; ma_uint64 __alignment; } ma_pthread_cond_t; - #endif - - #ifdef __unix__ - #define MA_UNIX - #ifdef __ORBIS__ - #define MA_ORBIS - #elif defined(__PROSPERO__) - #define MA_PROSPERO - #elif defined(__DragonFly__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) - #define MA_BSD - #endif - #endif - #ifdef __linux__ - #define MA_LINUX - #endif - #ifdef __APPLE__ - #define MA_APPLE - #endif - #ifdef __ANDROID__ - #define MA_ANDROID - #endif - #ifdef __EMSCRIPTEN__ - #define MA_EMSCRIPTEN - #endif - #if defined(__NX__) - #define MA_NX - #endif -#endif - -#if defined(__has_c_attribute) - #if __has_c_attribute(fallthrough) - #define MA_FALLTHROUGH [[fallthrough]] - #endif -#endif -#if !defined(MA_FALLTHROUGH) && defined(__has_attribute) && (defined(__clang__) || defined(__GNUC__)) - #if __has_attribute(fallthrough) - #define MA_FALLTHROUGH __attribute__((fallthrough)) - #endif -#endif -#if !defined(MA_FALLTHROUGH) - #define MA_FALLTHROUGH ((void)0) -#endif - -#ifdef _MSC_VER - #define MA_INLINE __forceinline -#elif defined(__GNUC__) - /* - I've had a bug report where GCC is emitting warnings about functions possibly not being inlineable. This warning happens when - the __attribute__((always_inline)) attribute is defined without an "inline" statement. I think therefore there must be some - case where "__inline__" is not always defined, thus the compiler emitting these warnings. When using -std=c89 or -ansi on the - command line, we cannot use the "inline" keyword and instead need to use "__inline__". In an attempt to work around this issue - I am using "__inline__" only when we're compiling in strict ANSI mode. - */ - #if defined(__STRICT_ANSI__) - #define MA_GNUC_INLINE_HINT __inline__ - #else - #define MA_GNUC_INLINE_HINT inline - #endif - - #if (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 2)) || defined(__clang__) - #define MA_INLINE MA_GNUC_INLINE_HINT __attribute__((always_inline)) - #else - #define MA_INLINE MA_GNUC_INLINE_HINT - #endif -#elif defined(__WATCOMC__) - #define MA_INLINE __inline -#else - #define MA_INLINE -#endif - -#if !defined(MA_API) - #if defined(MA_DLL) - #if defined(_WIN32) - #define MA_DLL_IMPORT __declspec(dllimport) - #define MA_DLL_EXPORT __declspec(dllexport) - #define MA_DLL_PRIVATE static - #else - #if defined(__GNUC__) && __GNUC__ >= 4 - #define MA_DLL_IMPORT __attribute__((visibility("default"))) - #define MA_DLL_EXPORT __attribute__((visibility("default"))) - #define MA_DLL_PRIVATE __attribute__((visibility("hidden"))) - #else - #define MA_DLL_IMPORT - #define MA_DLL_EXPORT - #define MA_DLL_PRIVATE static - #endif - #endif - - #if defined(MINIAUDIO_IMPLEMENTATION) || defined(MA_IMPLEMENTATION) - #define MA_API MA_DLL_EXPORT - #else - #define MA_API MA_DLL_IMPORT - #endif - #define MA_PRIVATE MA_DLL_PRIVATE - #else - #define MA_API extern - #define MA_PRIVATE static - #endif -#endif - -/* SIMD alignment in bytes. Currently set to 32 bytes in preparation for future AVX optimizations. */ -#define MA_SIMD_ALIGNMENT 32 - -/* -Special wchar_t type to ensure any structures in the public sections that reference it have a -consistent size across all platforms. - -On Windows, wchar_t is 2 bytes, whereas everywhere else it's 4 bytes. Since Windows likes to use -wchar_t for it's IDs, we need a special explicitly sized wchar type that is always 2 bytes on all -platforms. -*/ -#if !defined(MA_POSIX) && defined(MA_WIN32) -typedef wchar_t ma_wchar_win32; -#else -typedef ma_uint16 ma_wchar_win32; -#endif - - - -/* -Logging Levels -============== -Log levels are only used to give logging callbacks some context as to the severity of a log message -so they can do filtering. All log levels will be posted to registered logging callbacks. If you -don't want to output a certain log level you can discriminate against the log level in the callback. - -MA_LOG_LEVEL_DEBUG - Used for debugging. Useful for debug and test builds, but should be disabled in release builds. - -MA_LOG_LEVEL_INFO - Informational logging. Useful for debugging. This will never be called from within the data - callback. - -MA_LOG_LEVEL_WARNING - Warnings. You should enable this in you development builds and action them when encounted. These - logs usually indicate a potential problem or misconfiguration, but still allow you to keep - running. This will never be called from within the data callback. - -MA_LOG_LEVEL_ERROR - Error logging. This will be fired when an operation fails and is subsequently aborted. This can - be fired from within the data callback, in which case the device will be stopped. You should - always have this log level enabled. -*/ -typedef enum -{ - MA_LOG_LEVEL_DEBUG = 4, - MA_LOG_LEVEL_INFO = 3, - MA_LOG_LEVEL_WARNING = 2, - MA_LOG_LEVEL_ERROR = 1 -} ma_log_level; - -/* -Variables needing to be accessed atomically should be declared with this macro for two reasons: - - 1) It allows people who read the code to identify a variable as such; and - 2) It forces alignment on platforms where it's required or optimal. - -Note that for x86/64, alignment is not strictly necessary, but does have some performance -implications. Where supported by the compiler, alignment will be used, but otherwise if the CPU -architecture does not require it, it will simply leave it unaligned. This is the case with old -versions of Visual Studio, which I've confirmed with at least VC6. -*/ -#if !defined(_MSC_VER) && defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L) - #include - #define MA_ATOMIC(alignment, type) _Alignas(alignment) type -#else - #if defined(__GNUC__) - /* GCC-style compilers. */ - #define MA_ATOMIC(alignment, type) type __attribute__((aligned(alignment))) - #elif defined(_MSC_VER) && _MSC_VER > 1200 /* 1200 = VC6. Alignment not supported, but not necessary because x86 is the only supported target. */ - /* MSVC. */ - #define MA_ATOMIC(alignment, type) __declspec(align(alignment)) type - #else - /* Other compilers. */ - #define MA_ATOMIC(alignment, type) type - #endif -#endif - -typedef struct ma_context ma_context; -typedef struct ma_device ma_device; - -typedef ma_uint8 ma_channel; -typedef enum -{ - MA_CHANNEL_NONE = 0, - MA_CHANNEL_MONO = 1, - MA_CHANNEL_FRONT_LEFT = 2, - MA_CHANNEL_FRONT_RIGHT = 3, - MA_CHANNEL_FRONT_CENTER = 4, - MA_CHANNEL_LFE = 5, - MA_CHANNEL_BACK_LEFT = 6, - MA_CHANNEL_BACK_RIGHT = 7, - MA_CHANNEL_FRONT_LEFT_CENTER = 8, - MA_CHANNEL_FRONT_RIGHT_CENTER = 9, - MA_CHANNEL_BACK_CENTER = 10, - MA_CHANNEL_SIDE_LEFT = 11, - MA_CHANNEL_SIDE_RIGHT = 12, - MA_CHANNEL_TOP_CENTER = 13, - MA_CHANNEL_TOP_FRONT_LEFT = 14, - MA_CHANNEL_TOP_FRONT_CENTER = 15, - MA_CHANNEL_TOP_FRONT_RIGHT = 16, - MA_CHANNEL_TOP_BACK_LEFT = 17, - MA_CHANNEL_TOP_BACK_CENTER = 18, - MA_CHANNEL_TOP_BACK_RIGHT = 19, - MA_CHANNEL_AUX_0 = 20, - MA_CHANNEL_AUX_1 = 21, - MA_CHANNEL_AUX_2 = 22, - MA_CHANNEL_AUX_3 = 23, - MA_CHANNEL_AUX_4 = 24, - MA_CHANNEL_AUX_5 = 25, - MA_CHANNEL_AUX_6 = 26, - MA_CHANNEL_AUX_7 = 27, - MA_CHANNEL_AUX_8 = 28, - MA_CHANNEL_AUX_9 = 29, - MA_CHANNEL_AUX_10 = 30, - MA_CHANNEL_AUX_11 = 31, - MA_CHANNEL_AUX_12 = 32, - MA_CHANNEL_AUX_13 = 33, - MA_CHANNEL_AUX_14 = 34, - MA_CHANNEL_AUX_15 = 35, - MA_CHANNEL_AUX_16 = 36, - MA_CHANNEL_AUX_17 = 37, - MA_CHANNEL_AUX_18 = 38, - MA_CHANNEL_AUX_19 = 39, - MA_CHANNEL_AUX_20 = 40, - MA_CHANNEL_AUX_21 = 41, - MA_CHANNEL_AUX_22 = 42, - MA_CHANNEL_AUX_23 = 43, - MA_CHANNEL_AUX_24 = 44, - MA_CHANNEL_AUX_25 = 45, - MA_CHANNEL_AUX_26 = 46, - MA_CHANNEL_AUX_27 = 47, - MA_CHANNEL_AUX_28 = 48, - MA_CHANNEL_AUX_29 = 49, - MA_CHANNEL_AUX_30 = 50, - MA_CHANNEL_AUX_31 = 51, - MA_CHANNEL_LEFT = MA_CHANNEL_FRONT_LEFT, - MA_CHANNEL_RIGHT = MA_CHANNEL_FRONT_RIGHT, - MA_CHANNEL_POSITION_COUNT = (MA_CHANNEL_AUX_31 + 1) -} _ma_channel_position; /* Do not use `_ma_channel_position` directly. Use `ma_channel` instead. */ - -typedef enum -{ - MA_SUCCESS = 0, - MA_ERROR = -1, /* A generic error. */ - MA_INVALID_ARGS = -2, - MA_INVALID_OPERATION = -3, - MA_OUT_OF_MEMORY = -4, - MA_OUT_OF_RANGE = -5, - MA_ACCESS_DENIED = -6, - MA_DOES_NOT_EXIST = -7, - MA_ALREADY_EXISTS = -8, - MA_TOO_MANY_OPEN_FILES = -9, - MA_INVALID_FILE = -10, - MA_TOO_BIG = -11, - MA_PATH_TOO_LONG = -12, - MA_NAME_TOO_LONG = -13, - MA_NOT_DIRECTORY = -14, - MA_IS_DIRECTORY = -15, - MA_DIRECTORY_NOT_EMPTY = -16, - MA_AT_END = -17, - MA_NO_SPACE = -18, - MA_BUSY = -19, - MA_IO_ERROR = -20, - MA_INTERRUPT = -21, - MA_UNAVAILABLE = -22, - MA_ALREADY_IN_USE = -23, - MA_BAD_ADDRESS = -24, - MA_BAD_SEEK = -25, - MA_BAD_PIPE = -26, - MA_DEADLOCK = -27, - MA_TOO_MANY_LINKS = -28, - MA_NOT_IMPLEMENTED = -29, - MA_NO_MESSAGE = -30, - MA_BAD_MESSAGE = -31, - MA_NO_DATA_AVAILABLE = -32, - MA_INVALID_DATA = -33, - MA_TIMEOUT = -34, - MA_NO_NETWORK = -35, - MA_NOT_UNIQUE = -36, - MA_NOT_SOCKET = -37, - MA_NO_ADDRESS = -38, - MA_BAD_PROTOCOL = -39, - MA_PROTOCOL_UNAVAILABLE = -40, - MA_PROTOCOL_NOT_SUPPORTED = -41, - MA_PROTOCOL_FAMILY_NOT_SUPPORTED = -42, - MA_ADDRESS_FAMILY_NOT_SUPPORTED = -43, - MA_SOCKET_NOT_SUPPORTED = -44, - MA_CONNECTION_RESET = -45, - MA_ALREADY_CONNECTED = -46, - MA_NOT_CONNECTED = -47, - MA_CONNECTION_REFUSED = -48, - MA_NO_HOST = -49, - MA_IN_PROGRESS = -50, - MA_CANCELLED = -51, - MA_MEMORY_ALREADY_MAPPED = -52, - - /* General miniaudio-specific errors. */ - MA_FORMAT_NOT_SUPPORTED = -100, - MA_DEVICE_TYPE_NOT_SUPPORTED = -101, - MA_SHARE_MODE_NOT_SUPPORTED = -102, - MA_NO_BACKEND = -103, - MA_NO_DEVICE = -104, - MA_API_NOT_FOUND = -105, - MA_INVALID_DEVICE_CONFIG = -106, - MA_LOOP = -107, - MA_BACKEND_NOT_ENABLED = -108, - - /* State errors. */ - MA_DEVICE_NOT_INITIALIZED = -200, - MA_DEVICE_ALREADY_INITIALIZED = -201, - MA_DEVICE_NOT_STARTED = -202, - MA_DEVICE_NOT_STOPPED = -203, - - /* Operation errors. */ - MA_FAILED_TO_INIT_BACKEND = -300, - MA_FAILED_TO_OPEN_BACKEND_DEVICE = -301, - MA_FAILED_TO_START_BACKEND_DEVICE = -302, - MA_FAILED_TO_STOP_BACKEND_DEVICE = -303 -} ma_result; - - -#define MA_MIN_CHANNELS 1 -#ifndef MA_MAX_CHANNELS -#define MA_MAX_CHANNELS 254 -#endif - -#ifndef MA_MAX_FILTER_ORDER -#define MA_MAX_FILTER_ORDER 8 -#endif - -typedef enum -{ - ma_stream_format_pcm = 0 -} ma_stream_format; - -typedef enum -{ - ma_stream_layout_interleaved = 0, - ma_stream_layout_deinterleaved -} ma_stream_layout; - -typedef enum -{ - ma_dither_mode_none = 0, - ma_dither_mode_rectangle, - ma_dither_mode_triangle -} ma_dither_mode; - -typedef enum -{ - /* - I like to keep these explicitly defined because they're used as a key into a lookup table. When items are - added to this, make sure there are no gaps and that they're added to the lookup table in ma_get_bytes_per_sample(). - */ - ma_format_unknown = 0, /* Mainly used for indicating an error, but also used as the default for the output format for decoders. */ - ma_format_u8 = 1, - ma_format_s16 = 2, /* Seems to be the most widely supported format. */ - ma_format_s24 = 3, /* Tightly packed. 3 bytes per sample. */ - ma_format_s32 = 4, - ma_format_f32 = 5, - ma_format_count -} ma_format; - -typedef enum -{ - /* Standard rates need to be in priority order. */ - ma_standard_sample_rate_48000 = 48000, /* Most common */ - ma_standard_sample_rate_44100 = 44100, - - ma_standard_sample_rate_32000 = 32000, /* Lows */ - ma_standard_sample_rate_24000 = 24000, - ma_standard_sample_rate_22050 = 22050, - - ma_standard_sample_rate_88200 = 88200, /* Highs */ - ma_standard_sample_rate_96000 = 96000, - ma_standard_sample_rate_176400 = 176400, - ma_standard_sample_rate_192000 = 192000, - - ma_standard_sample_rate_16000 = 16000, /* Extreme lows */ - ma_standard_sample_rate_11025 = 11250, - ma_standard_sample_rate_8000 = 8000, - - ma_standard_sample_rate_352800 = 352800, /* Extreme highs */ - ma_standard_sample_rate_384000 = 384000, - - ma_standard_sample_rate_min = ma_standard_sample_rate_8000, - ma_standard_sample_rate_max = ma_standard_sample_rate_384000, - ma_standard_sample_rate_count = 14 /* Need to maintain the count manually. Make sure this is updated if items are added to enum. */ -} ma_standard_sample_rate; - - -typedef enum -{ - ma_channel_mix_mode_rectangular = 0, /* Simple averaging based on the plane(s) the channel is sitting on. */ - ma_channel_mix_mode_simple, /* Drop excess channels; zeroed out extra channels. */ - ma_channel_mix_mode_custom_weights, /* Use custom weights specified in ma_channel_converter_config. */ - ma_channel_mix_mode_default = ma_channel_mix_mode_rectangular -} ma_channel_mix_mode; - -typedef enum -{ - ma_standard_channel_map_microsoft, - ma_standard_channel_map_alsa, - ma_standard_channel_map_rfc3551, /* Based off AIFF. */ - ma_standard_channel_map_flac, - ma_standard_channel_map_vorbis, - ma_standard_channel_map_sound4, /* FreeBSD's sound(4). */ - ma_standard_channel_map_sndio, /* www.sndio.org/tips.html */ - ma_standard_channel_map_webaudio = ma_standard_channel_map_flac, /* https://webaudio.github.io/web-audio-api/#ChannelOrdering. Only 1, 2, 4 and 6 channels are defined, but can fill in the gaps with logical assumptions. */ - ma_standard_channel_map_default = ma_standard_channel_map_microsoft -} ma_standard_channel_map; - -typedef enum -{ - ma_performance_profile_low_latency = 0, - ma_performance_profile_conservative -} ma_performance_profile; - - -typedef struct -{ - void* pUserData; - void* (* onMalloc)(size_t sz, void* pUserData); - void* (* onRealloc)(void* p, size_t sz, void* pUserData); - void (* onFree)(void* p, void* pUserData); -} ma_allocation_callbacks; - -typedef struct -{ - ma_int32 state; -} ma_lcg; - - -/* -Atomics. - -These are typesafe structures to prevent errors as a result of forgetting to reference variables atomically. It's too -easy to introduce subtle bugs where you accidentally do a regular assignment instead of an atomic load/store, etc. By -using a struct we can enforce the use of atomics at compile time. - -These types are declared in the header section because we need to reference them in structs below, but functions for -using them are only exposed in the implementation section. I do not want these to be part of the public API. - -There's a few downsides to this system. The first is that you need to declare a new struct for each type. Below are -some macros to help with the declarations. They will be named like so: - - ma_atomic_uint32 - atomic ma_uint32 - ma_atomic_int32 - atomic ma_int32 - ma_atomic_uint64 - atomic ma_uint64 - ma_atomic_float - atomic float - ma_atomic_bool32 - atomic ma_bool32 - -The other downside is that atomic pointers are extremely messy. You need to declare a new struct for each specific -type of pointer you need to make atomic. For example, an atomic ma_node* will look like this: - - MA_ATOMIC_SAFE_TYPE_IMPL_PTR(node) - -Which will declare a type struct that's named like so: - - ma_atomic_ptr_node - -Functions to use the atomic types are declared in the implementation section. All atomic functions are prefixed with -the name of the struct. For example: - - ma_atomic_uint32_set() - Atomic store of ma_uint32 - ma_atomic_uint32_get() - Atomic load of ma_uint32 - etc. - -For pointer types it's the same, which makes them a bit messy to use due to the length of each function name, but in -return you get type safety and enforcement of atomic operations. -*/ -#define MA_ATOMIC_SAFE_TYPE_DECL(c89TypeExtension, typeSize, type) \ - typedef struct \ - { \ - MA_ATOMIC(typeSize, ma_##type) value; \ - } ma_atomic_##type; \ - -#define MA_ATOMIC_SAFE_TYPE_DECL_PTR(type) \ - typedef struct \ - { \ - MA_ATOMIC(MA_SIZEOF_PTR, ma_##type*) value; \ - } ma_atomic_ptr_##type; \ - -MA_ATOMIC_SAFE_TYPE_DECL(32, 4, uint32) -MA_ATOMIC_SAFE_TYPE_DECL(i32, 4, int32) -MA_ATOMIC_SAFE_TYPE_DECL(64, 8, uint64) -MA_ATOMIC_SAFE_TYPE_DECL(f32, 4, float) -MA_ATOMIC_SAFE_TYPE_DECL(32, 4, bool32) - - -/* Spinlocks are 32-bit for compatibility reasons. */ -typedef ma_uint32 ma_spinlock; - -#ifndef MA_NO_THREADING - /* Thread priorities should be ordered such that the default priority of the worker thread is 0. */ - typedef enum - { - ma_thread_priority_idle = -5, - ma_thread_priority_lowest = -4, - ma_thread_priority_low = -3, - ma_thread_priority_normal = -2, - ma_thread_priority_high = -1, - ma_thread_priority_highest = 0, - ma_thread_priority_realtime = 1, - ma_thread_priority_default = 0 - } ma_thread_priority; - - #if defined(MA_POSIX) - typedef ma_pthread_t ma_thread; - #elif defined(MA_WIN32) - typedef ma_handle ma_thread; - #endif - - #if defined(MA_POSIX) - typedef ma_pthread_mutex_t ma_mutex; - #elif defined(MA_WIN32) - typedef ma_handle ma_mutex; - #endif - - #if defined(MA_POSIX) - typedef struct - { - ma_uint32 value; - ma_pthread_mutex_t lock; - ma_pthread_cond_t cond; - } ma_event; - #elif defined(MA_WIN32) - typedef ma_handle ma_event; - #endif - - #if defined(MA_POSIX) - typedef struct - { - int value; - ma_pthread_mutex_t lock; - ma_pthread_cond_t cond; - } ma_semaphore; - #elif defined(MA_WIN32) - typedef ma_handle ma_semaphore; - #endif -#else - /* MA_NO_THREADING is set which means threading is disabled. Threading is required by some API families. If any of these are enabled we need to throw an error. */ - #ifndef MA_NO_DEVICE_IO - #error "MA_NO_THREADING cannot be used without MA_NO_DEVICE_IO"; - #endif -#endif /* MA_NO_THREADING */ - - -/* -Retrieves the version of miniaudio as separated integers. Each component can be NULL if it's not required. -*/ -MA_API void ma_version(ma_uint32* pMajor, ma_uint32* pMinor, ma_uint32* pRevision); - -/* -Retrieves the version of miniaudio as a string which can be useful for logging purposes. -*/ -MA_API const char* ma_version_string(void); - - -/************************************************************************************************************************************************************** - -Logging - -**************************************************************************************************************************************************************/ -#include /* For va_list. */ - -#if defined(__has_attribute) - #if __has_attribute(format) - #define MA_ATTRIBUTE_FORMAT(fmt, va) __attribute__((format(printf, fmt, va))) - #endif -#endif -#ifndef MA_ATTRIBUTE_FORMAT -#define MA_ATTRIBUTE_FORMAT(fmt, va) -#endif - -#ifndef MA_MAX_LOG_CALLBACKS -#define MA_MAX_LOG_CALLBACKS 4 -#endif - - -/* -The callback for handling log messages. - - -Parameters ----------- -pUserData (in) - The user data pointer that was passed into ma_log_register_callback(). - -logLevel (in) - The log level. This can be one of the following: - - +----------------------+ - | Log Level | - +----------------------+ - | MA_LOG_LEVEL_DEBUG | - | MA_LOG_LEVEL_INFO | - | MA_LOG_LEVEL_WARNING | - | MA_LOG_LEVEL_ERROR | - +----------------------+ - -pMessage (in) - The log message. -*/ -typedef void (* ma_log_callback_proc)(void* pUserData, ma_uint32 level, const char* pMessage); - -typedef struct -{ - ma_log_callback_proc onLog; - void* pUserData; -} ma_log_callback; - -MA_API ma_log_callback ma_log_callback_init(ma_log_callback_proc onLog, void* pUserData); - - -typedef struct -{ - ma_log_callback callbacks[MA_MAX_LOG_CALLBACKS]; - ma_uint32 callbackCount; - ma_allocation_callbacks allocationCallbacks; /* Need to store these persistently because ma_log_postv() might need to allocate a buffer on the heap. */ -#ifndef MA_NO_THREADING - ma_mutex lock; /* For thread safety just to make it easier and safer for the logging implementation. */ -#endif -} ma_log; - -MA_API ma_result ma_log_init(const ma_allocation_callbacks* pAllocationCallbacks, ma_log* pLog); -MA_API void ma_log_uninit(ma_log* pLog); -MA_API ma_result ma_log_register_callback(ma_log* pLog, ma_log_callback callback); -MA_API ma_result ma_log_unregister_callback(ma_log* pLog, ma_log_callback callback); -MA_API ma_result ma_log_post(ma_log* pLog, ma_uint32 level, const char* pMessage); -MA_API ma_result ma_log_postv(ma_log* pLog, ma_uint32 level, const char* pFormat, va_list args); -MA_API ma_result ma_log_postf(ma_log* pLog, ma_uint32 level, const char* pFormat, ...) MA_ATTRIBUTE_FORMAT(3, 4); - - -/************************************************************************************************************************************************************** - -Biquad Filtering - -**************************************************************************************************************************************************************/ -typedef union -{ - float f32; - ma_int32 s32; -} ma_biquad_coefficient; - -typedef struct -{ - ma_format format; - ma_uint32 channels; - double b0; - double b1; - double b2; - double a0; - double a1; - double a2; -} ma_biquad_config; - -MA_API ma_biquad_config ma_biquad_config_init(ma_format format, ma_uint32 channels, double b0, double b1, double b2, double a0, double a1, double a2); - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_biquad_coefficient b0; - ma_biquad_coefficient b1; - ma_biquad_coefficient b2; - ma_biquad_coefficient a1; - ma_biquad_coefficient a2; - ma_biquad_coefficient* pR1; - ma_biquad_coefficient* pR2; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_biquad; - -MA_API ma_result ma_biquad_get_heap_size(const ma_biquad_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_biquad_init_preallocated(const ma_biquad_config* pConfig, void* pHeap, ma_biquad* pBQ); -MA_API ma_result ma_biquad_init(const ma_biquad_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_biquad* pBQ); -MA_API void ma_biquad_uninit(ma_biquad* pBQ, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_biquad_reinit(const ma_biquad_config* pConfig, ma_biquad* pBQ); -MA_API ma_result ma_biquad_clear_cache(ma_biquad* pBQ); -MA_API ma_result ma_biquad_process_pcm_frames(ma_biquad* pBQ, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_biquad_get_latency(const ma_biquad* pBQ); - - -/************************************************************************************************************************************************************** - -Low-Pass Filtering - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double cutoffFrequency; - double q; -} ma_lpf1_config, ma_lpf2_config; - -MA_API ma_lpf1_config ma_lpf1_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency); -MA_API ma_lpf2_config ma_lpf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, double q); - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_biquad_coefficient a; - ma_biquad_coefficient* pR1; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_lpf1; - -MA_API ma_result ma_lpf1_get_heap_size(const ma_lpf1_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_lpf1_init_preallocated(const ma_lpf1_config* pConfig, void* pHeap, ma_lpf1* pLPF); -MA_API ma_result ma_lpf1_init(const ma_lpf1_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf1* pLPF); -MA_API void ma_lpf1_uninit(ma_lpf1* pLPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_lpf1_reinit(const ma_lpf1_config* pConfig, ma_lpf1* pLPF); -MA_API ma_result ma_lpf1_clear_cache(ma_lpf1* pLPF); -MA_API ma_result ma_lpf1_process_pcm_frames(ma_lpf1* pLPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_lpf1_get_latency(const ma_lpf1* pLPF); - -typedef struct -{ - ma_biquad bq; /* The second order low-pass filter is implemented as a biquad filter. */ -} ma_lpf2; - -MA_API ma_result ma_lpf2_get_heap_size(const ma_lpf2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_lpf2_init_preallocated(const ma_lpf2_config* pConfig, void* pHeap, ma_lpf2* pHPF); -MA_API ma_result ma_lpf2_init(const ma_lpf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf2* pLPF); -MA_API void ma_lpf2_uninit(ma_lpf2* pLPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_lpf2_reinit(const ma_lpf2_config* pConfig, ma_lpf2* pLPF); -MA_API ma_result ma_lpf2_clear_cache(ma_lpf2* pLPF); -MA_API ma_result ma_lpf2_process_pcm_frames(ma_lpf2* pLPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_lpf2_get_latency(const ma_lpf2* pLPF); - - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double cutoffFrequency; - ma_uint32 order; /* If set to 0, will be treated as a passthrough (no filtering will be applied). */ -} ma_lpf_config; - -MA_API ma_lpf_config ma_lpf_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order); - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint32 lpf1Count; - ma_uint32 lpf2Count; - ma_lpf1* pLPF1; - ma_lpf2* pLPF2; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_lpf; - -MA_API ma_result ma_lpf_get_heap_size(const ma_lpf_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_lpf_init_preallocated(const ma_lpf_config* pConfig, void* pHeap, ma_lpf* pLPF); -MA_API ma_result ma_lpf_init(const ma_lpf_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf* pLPF); -MA_API void ma_lpf_uninit(ma_lpf* pLPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_lpf_reinit(const ma_lpf_config* pConfig, ma_lpf* pLPF); -MA_API ma_result ma_lpf_clear_cache(ma_lpf* pLPF); -MA_API ma_result ma_lpf_process_pcm_frames(ma_lpf* pLPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_lpf_get_latency(const ma_lpf* pLPF); - - -/************************************************************************************************************************************************************** - -High-Pass Filtering - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double cutoffFrequency; - double q; -} ma_hpf1_config, ma_hpf2_config; - -MA_API ma_hpf1_config ma_hpf1_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency); -MA_API ma_hpf2_config ma_hpf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, double q); - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_biquad_coefficient a; - ma_biquad_coefficient* pR1; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_hpf1; - -MA_API ma_result ma_hpf1_get_heap_size(const ma_hpf1_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_hpf1_init_preallocated(const ma_hpf1_config* pConfig, void* pHeap, ma_hpf1* pLPF); -MA_API ma_result ma_hpf1_init(const ma_hpf1_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf1* pHPF); -MA_API void ma_hpf1_uninit(ma_hpf1* pHPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_hpf1_reinit(const ma_hpf1_config* pConfig, ma_hpf1* pHPF); -MA_API ma_result ma_hpf1_process_pcm_frames(ma_hpf1* pHPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_hpf1_get_latency(const ma_hpf1* pHPF); - -typedef struct -{ - ma_biquad bq; /* The second order high-pass filter is implemented as a biquad filter. */ -} ma_hpf2; - -MA_API ma_result ma_hpf2_get_heap_size(const ma_hpf2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_hpf2_init_preallocated(const ma_hpf2_config* pConfig, void* pHeap, ma_hpf2* pHPF); -MA_API ma_result ma_hpf2_init(const ma_hpf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf2* pHPF); -MA_API void ma_hpf2_uninit(ma_hpf2* pHPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_hpf2_reinit(const ma_hpf2_config* pConfig, ma_hpf2* pHPF); -MA_API ma_result ma_hpf2_process_pcm_frames(ma_hpf2* pHPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_hpf2_get_latency(const ma_hpf2* pHPF); - - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double cutoffFrequency; - ma_uint32 order; /* If set to 0, will be treated as a passthrough (no filtering will be applied). */ -} ma_hpf_config; - -MA_API ma_hpf_config ma_hpf_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order); - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint32 hpf1Count; - ma_uint32 hpf2Count; - ma_hpf1* pHPF1; - ma_hpf2* pHPF2; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_hpf; - -MA_API ma_result ma_hpf_get_heap_size(const ma_hpf_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_hpf_init_preallocated(const ma_hpf_config* pConfig, void* pHeap, ma_hpf* pLPF); -MA_API ma_result ma_hpf_init(const ma_hpf_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf* pHPF); -MA_API void ma_hpf_uninit(ma_hpf* pHPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_hpf_reinit(const ma_hpf_config* pConfig, ma_hpf* pHPF); -MA_API ma_result ma_hpf_process_pcm_frames(ma_hpf* pHPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_hpf_get_latency(const ma_hpf* pHPF); - - -/************************************************************************************************************************************************************** - -Band-Pass Filtering - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double cutoffFrequency; - double q; -} ma_bpf2_config; - -MA_API ma_bpf2_config ma_bpf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, double q); - -typedef struct -{ - ma_biquad bq; /* The second order band-pass filter is implemented as a biquad filter. */ -} ma_bpf2; - -MA_API ma_result ma_bpf2_get_heap_size(const ma_bpf2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_bpf2_init_preallocated(const ma_bpf2_config* pConfig, void* pHeap, ma_bpf2* pBPF); -MA_API ma_result ma_bpf2_init(const ma_bpf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_bpf2* pBPF); -MA_API void ma_bpf2_uninit(ma_bpf2* pBPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_bpf2_reinit(const ma_bpf2_config* pConfig, ma_bpf2* pBPF); -MA_API ma_result ma_bpf2_process_pcm_frames(ma_bpf2* pBPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_bpf2_get_latency(const ma_bpf2* pBPF); - - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double cutoffFrequency; - ma_uint32 order; /* If set to 0, will be treated as a passthrough (no filtering will be applied). */ -} ma_bpf_config; - -MA_API ma_bpf_config ma_bpf_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order); - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 bpf2Count; - ma_bpf2* pBPF2; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_bpf; - -MA_API ma_result ma_bpf_get_heap_size(const ma_bpf_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_bpf_init_preallocated(const ma_bpf_config* pConfig, void* pHeap, ma_bpf* pBPF); -MA_API ma_result ma_bpf_init(const ma_bpf_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_bpf* pBPF); -MA_API void ma_bpf_uninit(ma_bpf* pBPF, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_bpf_reinit(const ma_bpf_config* pConfig, ma_bpf* pBPF); -MA_API ma_result ma_bpf_process_pcm_frames(ma_bpf* pBPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_bpf_get_latency(const ma_bpf* pBPF); - - -/************************************************************************************************************************************************************** - -Notching Filter - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double q; - double frequency; -} ma_notch2_config, ma_notch_config; - -MA_API ma_notch2_config ma_notch2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double q, double frequency); - -typedef struct -{ - ma_biquad bq; -} ma_notch2; - -MA_API ma_result ma_notch2_get_heap_size(const ma_notch2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_notch2_init_preallocated(const ma_notch2_config* pConfig, void* pHeap, ma_notch2* pFilter); -MA_API ma_result ma_notch2_init(const ma_notch2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_notch2* pFilter); -MA_API void ma_notch2_uninit(ma_notch2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_notch2_reinit(const ma_notch2_config* pConfig, ma_notch2* pFilter); -MA_API ma_result ma_notch2_process_pcm_frames(ma_notch2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_notch2_get_latency(const ma_notch2* pFilter); - - -/************************************************************************************************************************************************************** - -Peaking EQ Filter - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double gainDB; - double q; - double frequency; -} ma_peak2_config, ma_peak_config; - -MA_API ma_peak2_config ma_peak2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency); - -typedef struct -{ - ma_biquad bq; -} ma_peak2; - -MA_API ma_result ma_peak2_get_heap_size(const ma_peak2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_peak2_init_preallocated(const ma_peak2_config* pConfig, void* pHeap, ma_peak2* pFilter); -MA_API ma_result ma_peak2_init(const ma_peak2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_peak2* pFilter); -MA_API void ma_peak2_uninit(ma_peak2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_peak2_reinit(const ma_peak2_config* pConfig, ma_peak2* pFilter); -MA_API ma_result ma_peak2_process_pcm_frames(ma_peak2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_peak2_get_latency(const ma_peak2* pFilter); - - -/************************************************************************************************************************************************************** - -Low Shelf Filter - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double gainDB; - double shelfSlope; - double frequency; -} ma_loshelf2_config, ma_loshelf_config; - -MA_API ma_loshelf2_config ma_loshelf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double shelfSlope, double frequency); - -typedef struct -{ - ma_biquad bq; -} ma_loshelf2; - -MA_API ma_result ma_loshelf2_get_heap_size(const ma_loshelf2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_loshelf2_init_preallocated(const ma_loshelf2_config* pConfig, void* pHeap, ma_loshelf2* pFilter); -MA_API ma_result ma_loshelf2_init(const ma_loshelf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_loshelf2* pFilter); -MA_API void ma_loshelf2_uninit(ma_loshelf2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_loshelf2_reinit(const ma_loshelf2_config* pConfig, ma_loshelf2* pFilter); -MA_API ma_result ma_loshelf2_process_pcm_frames(ma_loshelf2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_loshelf2_get_latency(const ma_loshelf2* pFilter); - - -/************************************************************************************************************************************************************** - -High Shelf Filter - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - double gainDB; - double shelfSlope; - double frequency; -} ma_hishelf2_config, ma_hishelf_config; - -MA_API ma_hishelf2_config ma_hishelf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double shelfSlope, double frequency); - -typedef struct -{ - ma_biquad bq; -} ma_hishelf2; - -MA_API ma_result ma_hishelf2_get_heap_size(const ma_hishelf2_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_hishelf2_init_preallocated(const ma_hishelf2_config* pConfig, void* pHeap, ma_hishelf2* pFilter); -MA_API ma_result ma_hishelf2_init(const ma_hishelf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hishelf2* pFilter); -MA_API void ma_hishelf2_uninit(ma_hishelf2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_hishelf2_reinit(const ma_hishelf2_config* pConfig, ma_hishelf2* pFilter); -MA_API ma_result ma_hishelf2_process_pcm_frames(ma_hishelf2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_uint32 ma_hishelf2_get_latency(const ma_hishelf2* pFilter); - - - -/* -Delay -*/ -typedef struct -{ - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint32 delayInFrames; - ma_bool32 delayStart; /* Set to true to delay the start of the output; false otherwise. */ - float wet; /* 0..1. Default = 1. */ - float dry; /* 0..1. Default = 1. */ - float decay; /* 0..1. Default = 0 (no feedback). Feedback decay. Use this for echo. */ -} ma_delay_config; - -MA_API ma_delay_config ma_delay_config_init(ma_uint32 channels, ma_uint32 sampleRate, ma_uint32 delayInFrames, float decay); - - -typedef struct -{ - ma_delay_config config; - ma_uint32 cursor; /* Feedback is written to this cursor. Always equal or in front of the read cursor. */ - ma_uint32 bufferSizeInFrames; - float* pBuffer; -} ma_delay; - -MA_API ma_result ma_delay_init(const ma_delay_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_delay* pDelay); -MA_API void ma_delay_uninit(ma_delay* pDelay, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_delay_process_pcm_frames(ma_delay* pDelay, void* pFramesOut, const void* pFramesIn, ma_uint32 frameCount); -MA_API void ma_delay_set_wet(ma_delay* pDelay, float value); -MA_API float ma_delay_get_wet(const ma_delay* pDelay); -MA_API void ma_delay_set_dry(ma_delay* pDelay, float value); -MA_API float ma_delay_get_dry(const ma_delay* pDelay); -MA_API void ma_delay_set_decay(ma_delay* pDelay, float value); -MA_API float ma_delay_get_decay(const ma_delay* pDelay); - - -/* Gainer for smooth volume changes. */ -typedef struct -{ - ma_uint32 channels; - ma_uint32 smoothTimeInFrames; -} ma_gainer_config; - -MA_API ma_gainer_config ma_gainer_config_init(ma_uint32 channels, ma_uint32 smoothTimeInFrames); - - -typedef struct -{ - ma_gainer_config config; - ma_uint32 t; - float masterVolume; - float* pOldGains; - float* pNewGains; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_gainer; - -MA_API ma_result ma_gainer_get_heap_size(const ma_gainer_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_gainer_init_preallocated(const ma_gainer_config* pConfig, void* pHeap, ma_gainer* pGainer); -MA_API ma_result ma_gainer_init(const ma_gainer_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_gainer* pGainer); -MA_API void ma_gainer_uninit(ma_gainer* pGainer, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_gainer_process_pcm_frames(ma_gainer* pGainer, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_result ma_gainer_set_gain(ma_gainer* pGainer, float newGain); -MA_API ma_result ma_gainer_set_gains(ma_gainer* pGainer, float* pNewGains); -MA_API ma_result ma_gainer_set_master_volume(ma_gainer* pGainer, float volume); -MA_API ma_result ma_gainer_get_master_volume(const ma_gainer* pGainer, float* pVolume); - - - -/* Stereo panner. */ -typedef enum -{ - ma_pan_mode_balance = 0, /* Does not blend one side with the other. Technically just a balance. Compatible with other popular audio engines and therefore the default. */ - ma_pan_mode_pan /* A true pan. The sound from one side will "move" to the other side and blend with it. */ -} ma_pan_mode; - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_pan_mode mode; - float pan; -} ma_panner_config; - -MA_API ma_panner_config ma_panner_config_init(ma_format format, ma_uint32 channels); - - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_pan_mode mode; - float pan; /* -1..1 where 0 is no pan, -1 is left side, +1 is right side. Defaults to 0. */ -} ma_panner; - -MA_API ma_result ma_panner_init(const ma_panner_config* pConfig, ma_panner* pPanner); -MA_API ma_result ma_panner_process_pcm_frames(ma_panner* pPanner, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API void ma_panner_set_mode(ma_panner* pPanner, ma_pan_mode mode); -MA_API ma_pan_mode ma_panner_get_mode(const ma_panner* pPanner); -MA_API void ma_panner_set_pan(ma_panner* pPanner, float pan); -MA_API float ma_panner_get_pan(const ma_panner* pPanner); - - - -/* Fader. */ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; -} ma_fader_config; - -MA_API ma_fader_config ma_fader_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate); - -typedef struct -{ - ma_fader_config config; - float volumeBeg; /* If volumeBeg and volumeEnd is equal to 1, no fading happens (ma_fader_process_pcm_frames() will run as a passthrough). */ - float volumeEnd; - ma_uint64 lengthInFrames; /* The total length of the fade. */ - ma_uint64 cursorInFrames; /* The current time in frames. Incremented by ma_fader_process_pcm_frames(). */ -} ma_fader; - -MA_API ma_result ma_fader_init(const ma_fader_config* pConfig, ma_fader* pFader); -MA_API ma_result ma_fader_process_pcm_frames(ma_fader* pFader, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API void ma_fader_get_data_format(const ma_fader* pFader, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate); -MA_API void ma_fader_set_fade(ma_fader* pFader, float volumeBeg, float volumeEnd, ma_uint64 lengthInFrames); -MA_API float ma_fader_get_current_volume(const ma_fader* pFader); - - - -/* Spatializer. */ -typedef struct -{ - float x; - float y; - float z; -} ma_vec3f; - -typedef struct -{ - ma_vec3f v; - ma_spinlock lock; -} ma_atomic_vec3f; - -typedef enum -{ - ma_attenuation_model_none, /* No distance attenuation and no spatialization. */ - ma_attenuation_model_inverse, /* Equivalent to OpenAL's AL_INVERSE_DISTANCE_CLAMPED. */ - ma_attenuation_model_linear, /* Linear attenuation. Equivalent to OpenAL's AL_LINEAR_DISTANCE_CLAMPED. */ - ma_attenuation_model_exponential /* Exponential attenuation. Equivalent to OpenAL's AL_EXPONENT_DISTANCE_CLAMPED. */ -} ma_attenuation_model; - -typedef enum -{ - ma_positioning_absolute, - ma_positioning_relative -} ma_positioning; - -typedef enum -{ - ma_handedness_right, - ma_handedness_left -} ma_handedness; - - -typedef struct -{ - ma_uint32 channelsOut; - ma_channel* pChannelMapOut; - ma_handedness handedness; /* Defaults to right. Forward is -1 on the Z axis. In a left handed system, forward is +1 on the Z axis. */ - float coneInnerAngleInRadians; - float coneOuterAngleInRadians; - float coneOuterGain; - float speedOfSound; - ma_vec3f worldUp; -} ma_spatializer_listener_config; - -MA_API ma_spatializer_listener_config ma_spatializer_listener_config_init(ma_uint32 channelsOut); - - -typedef struct -{ - ma_spatializer_listener_config config; - ma_atomic_vec3f position; /* The absolute position of the listener. */ - ma_atomic_vec3f direction; /* The direction the listener is facing. The world up vector is config.worldUp. */ - ma_atomic_vec3f velocity; - ma_bool32 isEnabled; - - /* Memory management. */ - ma_bool32 _ownsHeap; - void* _pHeap; -} ma_spatializer_listener; - -MA_API ma_result ma_spatializer_listener_get_heap_size(const ma_spatializer_listener_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_spatializer_listener_init_preallocated(const ma_spatializer_listener_config* pConfig, void* pHeap, ma_spatializer_listener* pListener); -MA_API ma_result ma_spatializer_listener_init(const ma_spatializer_listener_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_uninit(ma_spatializer_listener* pListener, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_channel* ma_spatializer_listener_get_channel_map(ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_set_cone(ma_spatializer_listener* pListener, float innerAngleInRadians, float outerAngleInRadians, float outerGain); -MA_API void ma_spatializer_listener_get_cone(const ma_spatializer_listener* pListener, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain); -MA_API void ma_spatializer_listener_set_position(ma_spatializer_listener* pListener, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_listener_get_position(const ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_set_direction(ma_spatializer_listener* pListener, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_listener_get_direction(const ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_set_velocity(ma_spatializer_listener* pListener, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_listener_get_velocity(const ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_set_speed_of_sound(ma_spatializer_listener* pListener, float speedOfSound); -MA_API float ma_spatializer_listener_get_speed_of_sound(const ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_set_world_up(ma_spatializer_listener* pListener, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_listener_get_world_up(const ma_spatializer_listener* pListener); -MA_API void ma_spatializer_listener_set_enabled(ma_spatializer_listener* pListener, ma_bool32 isEnabled); -MA_API ma_bool32 ma_spatializer_listener_is_enabled(const ma_spatializer_listener* pListener); - - -typedef struct -{ - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_channel* pChannelMapIn; - ma_attenuation_model attenuationModel; - ma_positioning positioning; - ma_handedness handedness; /* Defaults to right. Forward is -1 on the Z axis. In a left handed system, forward is +1 on the Z axis. */ - float minGain; - float maxGain; - float minDistance; - float maxDistance; - float rolloff; - float coneInnerAngleInRadians; - float coneOuterAngleInRadians; - float coneOuterGain; - float dopplerFactor; /* Set to 0 to disable doppler effect. */ - float directionalAttenuationFactor; /* Set to 0 to disable directional attenuation. */ - float minSpatializationChannelGain; /* The minimal scaling factor to apply to channel gains when accounting for the direction of the sound relative to the listener. Must be in the range of 0..1. Smaller values means more aggressive directional panning, larger values means more subtle directional panning. */ - ma_uint32 gainSmoothTimeInFrames; /* When the gain of a channel changes during spatialization, the transition will be linearly interpolated over this number of frames. */ -} ma_spatializer_config; - -MA_API ma_spatializer_config ma_spatializer_config_init(ma_uint32 channelsIn, ma_uint32 channelsOut); - - -typedef struct -{ - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_channel* pChannelMapIn; - ma_attenuation_model attenuationModel; - ma_positioning positioning; - ma_handedness handedness; /* Defaults to right. Forward is -1 on the Z axis. In a left handed system, forward is +1 on the Z axis. */ - float minGain; - float maxGain; - float minDistance; - float maxDistance; - float rolloff; - float coneInnerAngleInRadians; - float coneOuterAngleInRadians; - float coneOuterGain; - float dopplerFactor; /* Set to 0 to disable doppler effect. */ - float directionalAttenuationFactor; /* Set to 0 to disable directional attenuation. */ - ma_uint32 gainSmoothTimeInFrames; /* When the gain of a channel changes during spatialization, the transition will be linearly interpolated over this number of frames. */ - ma_atomic_vec3f position; - ma_atomic_vec3f direction; - ma_atomic_vec3f velocity; /* For doppler effect. */ - float dopplerPitch; /* Will be updated by ma_spatializer_process_pcm_frames() and can be used by higher level functions to apply a pitch shift for doppler effect. */ - float minSpatializationChannelGain; - ma_gainer gainer; /* For smooth gain transitions. */ - float* pNewChannelGainsOut; /* An offset of _pHeap. Used by ma_spatializer_process_pcm_frames() to store new channel gains. The number of elements in this array is equal to config.channelsOut. */ - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_spatializer; - -MA_API ma_result ma_spatializer_get_heap_size(const ma_spatializer_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_spatializer_init_preallocated(const ma_spatializer_config* pConfig, void* pHeap, ma_spatializer* pSpatializer); -MA_API ma_result ma_spatializer_init(const ma_spatializer_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_spatializer* pSpatializer); -MA_API void ma_spatializer_uninit(ma_spatializer* pSpatializer, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_spatializer_process_pcm_frames(ma_spatializer* pSpatializer, ma_spatializer_listener* pListener, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_result ma_spatializer_set_master_volume(ma_spatializer* pSpatializer, float volume); -MA_API ma_result ma_spatializer_get_master_volume(const ma_spatializer* pSpatializer, float* pVolume); -MA_API ma_uint32 ma_spatializer_get_input_channels(const ma_spatializer* pSpatializer); -MA_API ma_uint32 ma_spatializer_get_output_channels(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_attenuation_model(ma_spatializer* pSpatializer, ma_attenuation_model attenuationModel); -MA_API ma_attenuation_model ma_spatializer_get_attenuation_model(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_positioning(ma_spatializer* pSpatializer, ma_positioning positioning); -MA_API ma_positioning ma_spatializer_get_positioning(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_rolloff(ma_spatializer* pSpatializer, float rolloff); -MA_API float ma_spatializer_get_rolloff(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_min_gain(ma_spatializer* pSpatializer, float minGain); -MA_API float ma_spatializer_get_min_gain(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_max_gain(ma_spatializer* pSpatializer, float maxGain); -MA_API float ma_spatializer_get_max_gain(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_min_distance(ma_spatializer* pSpatializer, float minDistance); -MA_API float ma_spatializer_get_min_distance(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_max_distance(ma_spatializer* pSpatializer, float maxDistance); -MA_API float ma_spatializer_get_max_distance(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_cone(ma_spatializer* pSpatializer, float innerAngleInRadians, float outerAngleInRadians, float outerGain); -MA_API void ma_spatializer_get_cone(const ma_spatializer* pSpatializer, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain); -MA_API void ma_spatializer_set_doppler_factor(ma_spatializer* pSpatializer, float dopplerFactor); -MA_API float ma_spatializer_get_doppler_factor(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_directional_attenuation_factor(ma_spatializer* pSpatializer, float directionalAttenuationFactor); -MA_API float ma_spatializer_get_directional_attenuation_factor(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_position(ma_spatializer* pSpatializer, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_get_position(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_direction(ma_spatializer* pSpatializer, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_get_direction(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_set_velocity(ma_spatializer* pSpatializer, float x, float y, float z); -MA_API ma_vec3f ma_spatializer_get_velocity(const ma_spatializer* pSpatializer); -MA_API void ma_spatializer_get_relative_position_and_direction(const ma_spatializer* pSpatializer, const ma_spatializer_listener* pListener, ma_vec3f* pRelativePos, ma_vec3f* pRelativeDir); - - - -/************************************************************************************************************************************************************ -************************************************************************************************************************************************************* - -DATA CONVERSION -=============== - -This section contains the APIs for data conversion. You will find everything here for channel mapping, sample format conversion, resampling, etc. - -************************************************************************************************************************************************************* -************************************************************************************************************************************************************/ - -/************************************************************************************************************************************************************** - -Resampling - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRateIn; - ma_uint32 sampleRateOut; - ma_uint32 lpfOrder; /* The low-pass filter order. Setting this to 0 will disable low-pass filtering. */ - double lpfNyquistFactor; /* 0..1. Defaults to 1. 1 = Half the sampling frequency (Nyquist Frequency), 0.5 = Quarter the sampling frequency (half Nyquest Frequency), etc. */ -} ma_linear_resampler_config; - -MA_API ma_linear_resampler_config ma_linear_resampler_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut); - -typedef struct -{ - ma_linear_resampler_config config; - ma_uint32 inAdvanceInt; - ma_uint32 inAdvanceFrac; - ma_uint32 inTimeInt; - ma_uint32 inTimeFrac; - union - { - float* f32; - ma_int16* s16; - } x0; /* The previous input frame. */ - union - { - float* f32; - ma_int16* s16; - } x1; /* The next input frame. */ - ma_lpf lpf; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_linear_resampler; - -MA_API ma_result ma_linear_resampler_get_heap_size(const ma_linear_resampler_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_linear_resampler_init_preallocated(const ma_linear_resampler_config* pConfig, void* pHeap, ma_linear_resampler* pResampler); -MA_API ma_result ma_linear_resampler_init(const ma_linear_resampler_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_linear_resampler* pResampler); -MA_API void ma_linear_resampler_uninit(ma_linear_resampler* pResampler, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_linear_resampler_process_pcm_frames(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut); -MA_API ma_result ma_linear_resampler_set_rate(ma_linear_resampler* pResampler, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut); -MA_API ma_result ma_linear_resampler_set_rate_ratio(ma_linear_resampler* pResampler, float ratioInOut); -MA_API ma_uint64 ma_linear_resampler_get_input_latency(const ma_linear_resampler* pResampler); -MA_API ma_uint64 ma_linear_resampler_get_output_latency(const ma_linear_resampler* pResampler); -MA_API ma_result ma_linear_resampler_get_required_input_frame_count(const ma_linear_resampler* pResampler, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount); -MA_API ma_result ma_linear_resampler_get_expected_output_frame_count(const ma_linear_resampler* pResampler, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount); -MA_API ma_result ma_linear_resampler_reset(ma_linear_resampler* pResampler); - - -typedef struct ma_resampler_config ma_resampler_config; - -typedef void ma_resampling_backend; -typedef struct -{ - ma_result (* onGetHeapSize )(void* pUserData, const ma_resampler_config* pConfig, size_t* pHeapSizeInBytes); - ma_result (* onInit )(void* pUserData, const ma_resampler_config* pConfig, void* pHeap, ma_resampling_backend** ppBackend); - void (* onUninit )(void* pUserData, ma_resampling_backend* pBackend, const ma_allocation_callbacks* pAllocationCallbacks); - ma_result (* onProcess )(void* pUserData, ma_resampling_backend* pBackend, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut); - ma_result (* onSetRate )(void* pUserData, ma_resampling_backend* pBackend, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut); /* Optional. Rate changes will be disabled. */ - ma_uint64 (* onGetInputLatency )(void* pUserData, const ma_resampling_backend* pBackend); /* Optional. Latency will be reported as 0. */ - ma_uint64 (* onGetOutputLatency )(void* pUserData, const ma_resampling_backend* pBackend); /* Optional. Latency will be reported as 0. */ - ma_result (* onGetRequiredInputFrameCount )(void* pUserData, const ma_resampling_backend* pBackend, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount); /* Optional. Latency mitigation will be disabled. */ - ma_result (* onGetExpectedOutputFrameCount)(void* pUserData, const ma_resampling_backend* pBackend, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount); /* Optional. Latency mitigation will be disabled. */ - ma_result (* onReset )(void* pUserData, ma_resampling_backend* pBackend); -} ma_resampling_backend_vtable; - -typedef enum -{ - ma_resample_algorithm_linear = 0, /* Fastest, lowest quality. Optional low-pass filtering. Default. */ - ma_resample_algorithm_custom, -} ma_resample_algorithm; - -struct ma_resampler_config -{ - ma_format format; /* Must be either ma_format_f32 or ma_format_s16. */ - ma_uint32 channels; - ma_uint32 sampleRateIn; - ma_uint32 sampleRateOut; - ma_resample_algorithm algorithm; /* When set to ma_resample_algorithm_custom, pBackendVTable will be used. */ - ma_resampling_backend_vtable* pBackendVTable; - void* pBackendUserData; - struct - { - ma_uint32 lpfOrder; - } linear; -}; - -MA_API ma_resampler_config ma_resampler_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut, ma_resample_algorithm algorithm); - -typedef struct -{ - ma_resampling_backend* pBackend; - ma_resampling_backend_vtable* pBackendVTable; - void* pBackendUserData; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRateIn; - ma_uint32 sampleRateOut; - union - { - ma_linear_resampler linear; - } state; /* State for stock resamplers so we can avoid a malloc. For stock resamplers, pBackend will point here. */ - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_resampler; - -MA_API ma_result ma_resampler_get_heap_size(const ma_resampler_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_resampler_init_preallocated(const ma_resampler_config* pConfig, void* pHeap, ma_resampler* pResampler); - -/* -Initializes a new resampler object from a config. -*/ -MA_API ma_result ma_resampler_init(const ma_resampler_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_resampler* pResampler); - -/* -Uninitializes a resampler. -*/ -MA_API void ma_resampler_uninit(ma_resampler* pResampler, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -Converts the given input data. - -Both the input and output frames must be in the format specified in the config when the resampler was initilized. - -On input, [pFrameCountOut] contains the number of output frames to process. On output it contains the number of output frames that -were actually processed, which may be less than the requested amount which will happen if there's not enough input data. You can use -ma_resampler_get_expected_output_frame_count() to know how many output frames will be processed for a given number of input frames. - -On input, [pFrameCountIn] contains the number of input frames contained in [pFramesIn]. On output it contains the number of whole -input frames that were actually processed. You can use ma_resampler_get_required_input_frame_count() to know how many input frames -you should provide for a given number of output frames. [pFramesIn] can be NULL, in which case zeroes will be used instead. - -If [pFramesOut] is NULL, a seek is performed. In this case, if [pFrameCountOut] is not NULL it will seek by the specified number of -output frames. Otherwise, if [pFramesCountOut] is NULL and [pFrameCountIn] is not NULL, it will seek by the specified number of input -frames. When seeking, [pFramesIn] is allowed to NULL, in which case the internal timing state will be updated, but no input will be -processed. In this case, any internal filter state will be updated as if zeroes were passed in. - -It is an error for [pFramesOut] to be non-NULL and [pFrameCountOut] to be NULL. - -It is an error for both [pFrameCountOut] and [pFrameCountIn] to be NULL. -*/ -MA_API ma_result ma_resampler_process_pcm_frames(ma_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut); - - -/* -Sets the input and output sample rate. -*/ -MA_API ma_result ma_resampler_set_rate(ma_resampler* pResampler, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut); - -/* -Sets the input and output sample rate as a ratio. - -The ration is in/out. -*/ -MA_API ma_result ma_resampler_set_rate_ratio(ma_resampler* pResampler, float ratio); - -/* -Retrieves the latency introduced by the resampler in input frames. -*/ -MA_API ma_uint64 ma_resampler_get_input_latency(const ma_resampler* pResampler); - -/* -Retrieves the latency introduced by the resampler in output frames. -*/ -MA_API ma_uint64 ma_resampler_get_output_latency(const ma_resampler* pResampler); - -/* -Calculates the number of whole input frames that would need to be read from the client in order to output the specified -number of output frames. - -The returned value does not include cached input frames. It only returns the number of extra frames that would need to be -read from the input buffer in order to output the specified number of output frames. -*/ -MA_API ma_result ma_resampler_get_required_input_frame_count(const ma_resampler* pResampler, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount); - -/* -Calculates the number of whole output frames that would be output after fully reading and consuming the specified number of -input frames. -*/ -MA_API ma_result ma_resampler_get_expected_output_frame_count(const ma_resampler* pResampler, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount); - -/* -Resets the resampler's timer and clears it's internal cache. -*/ -MA_API ma_result ma_resampler_reset(ma_resampler* pResampler); - - -/************************************************************************************************************************************************************** - -Channel Conversion - -**************************************************************************************************************************************************************/ -typedef enum -{ - ma_channel_conversion_path_unknown, - ma_channel_conversion_path_passthrough, - ma_channel_conversion_path_mono_out, /* Converting to mono. */ - ma_channel_conversion_path_mono_in, /* Converting from mono. */ - ma_channel_conversion_path_shuffle, /* Simple shuffle. Will use this when all channels are present in both input and output channel maps, but just in a different order. */ - ma_channel_conversion_path_weights /* Blended based on weights. */ -} ma_channel_conversion_path; - -typedef enum -{ - ma_mono_expansion_mode_duplicate = 0, /* The default. */ - ma_mono_expansion_mode_average, /* Average the mono channel across all channels. */ - ma_mono_expansion_mode_stereo_only, /* Duplicate to the left and right channels only and ignore the others. */ - ma_mono_expansion_mode_default = ma_mono_expansion_mode_duplicate -} ma_mono_expansion_mode; - -typedef struct -{ - ma_format format; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - const ma_channel* pChannelMapIn; - const ma_channel* pChannelMapOut; - ma_channel_mix_mode mixingMode; - ma_bool32 calculateLFEFromSpatialChannels; /* When an output LFE channel is present, but no input LFE, set to true to set the output LFE to the average of all spatial channels (LR, FR, etc.). Ignored when an input LFE is present. */ - float** ppWeights; /* [in][out]. Only used when mixingMode is set to ma_channel_mix_mode_custom_weights. */ -} ma_channel_converter_config; - -MA_API ma_channel_converter_config ma_channel_converter_config_init(ma_format format, ma_uint32 channelsIn, const ma_channel* pChannelMapIn, ma_uint32 channelsOut, const ma_channel* pChannelMapOut, ma_channel_mix_mode mixingMode); - -typedef struct -{ - ma_format format; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_channel_mix_mode mixingMode; - ma_channel_conversion_path conversionPath; - ma_channel* pChannelMapIn; - ma_channel* pChannelMapOut; - ma_uint8* pShuffleTable; /* Indexed by output channel index. */ - union - { - float** f32; - ma_int32** s16; - } weights; /* [in][out] */ - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_channel_converter; - -MA_API ma_result ma_channel_converter_get_heap_size(const ma_channel_converter_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_channel_converter_init_preallocated(const ma_channel_converter_config* pConfig, void* pHeap, ma_channel_converter* pConverter); -MA_API ma_result ma_channel_converter_init(const ma_channel_converter_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_channel_converter* pConverter); -MA_API void ma_channel_converter_uninit(ma_channel_converter* pConverter, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_channel_converter_process_pcm_frames(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount); -MA_API ma_result ma_channel_converter_get_input_channel_map(const ma_channel_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_channel_converter_get_output_channel_map(const ma_channel_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap); - - -/************************************************************************************************************************************************************** - -Data Conversion - -**************************************************************************************************************************************************************/ -typedef struct -{ - ma_format formatIn; - ma_format formatOut; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_uint32 sampleRateIn; - ma_uint32 sampleRateOut; - ma_channel* pChannelMapIn; - ma_channel* pChannelMapOut; - ma_dither_mode ditherMode; - ma_channel_mix_mode channelMixMode; - ma_bool32 calculateLFEFromSpatialChannels; /* When an output LFE channel is present, but no input LFE, set to true to set the output LFE to the average of all spatial channels (LR, FR, etc.). Ignored when an input LFE is present. */ - float** ppChannelWeights; /* [in][out]. Only used when mixingMode is set to ma_channel_mix_mode_custom_weights. */ - ma_bool32 allowDynamicSampleRate; - ma_resampler_config resampling; -} ma_data_converter_config; - -MA_API ma_data_converter_config ma_data_converter_config_init_default(void); -MA_API ma_data_converter_config ma_data_converter_config_init(ma_format formatIn, ma_format formatOut, ma_uint32 channelsIn, ma_uint32 channelsOut, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut); - - -typedef enum -{ - ma_data_converter_execution_path_passthrough, /* No conversion. */ - ma_data_converter_execution_path_format_only, /* Only format conversion. */ - ma_data_converter_execution_path_channels_only, /* Only channel conversion. */ - ma_data_converter_execution_path_resample_only, /* Only resampling. */ - ma_data_converter_execution_path_resample_first, /* All conversions, but resample as the first step. */ - ma_data_converter_execution_path_channels_first /* All conversions, but channels as the first step. */ -} ma_data_converter_execution_path; - -typedef struct -{ - ma_format formatIn; - ma_format formatOut; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_uint32 sampleRateIn; - ma_uint32 sampleRateOut; - ma_dither_mode ditherMode; - ma_data_converter_execution_path executionPath; /* The execution path the data converter will follow when processing. */ - ma_channel_converter channelConverter; - ma_resampler resampler; - ma_bool8 hasPreFormatConversion; - ma_bool8 hasPostFormatConversion; - ma_bool8 hasChannelConverter; - ma_bool8 hasResampler; - ma_bool8 isPassthrough; - - /* Memory management. */ - ma_bool8 _ownsHeap; - void* _pHeap; -} ma_data_converter; - -MA_API ma_result ma_data_converter_get_heap_size(const ma_data_converter_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_data_converter_init_preallocated(const ma_data_converter_config* pConfig, void* pHeap, ma_data_converter* pConverter); -MA_API ma_result ma_data_converter_init(const ma_data_converter_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_converter* pConverter); -MA_API void ma_data_converter_uninit(ma_data_converter* pConverter, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_data_converter_process_pcm_frames(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut); -MA_API ma_result ma_data_converter_set_rate(ma_data_converter* pConverter, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut); -MA_API ma_result ma_data_converter_set_rate_ratio(ma_data_converter* pConverter, float ratioInOut); -MA_API ma_uint64 ma_data_converter_get_input_latency(const ma_data_converter* pConverter); -MA_API ma_uint64 ma_data_converter_get_output_latency(const ma_data_converter* pConverter); -MA_API ma_result ma_data_converter_get_required_input_frame_count(const ma_data_converter* pConverter, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount); -MA_API ma_result ma_data_converter_get_expected_output_frame_count(const ma_data_converter* pConverter, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount); -MA_API ma_result ma_data_converter_get_input_channel_map(const ma_data_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_data_converter_get_output_channel_map(const ma_data_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_data_converter_reset(ma_data_converter* pConverter); - - -/************************************************************************************************************************************************************ - -Format Conversion - -************************************************************************************************************************************************************/ -MA_API void ma_pcm_u8_to_s16(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_u8_to_s24(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_u8_to_s32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_u8_to_f32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s16_to_u8(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s16_to_s24(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s16_to_s32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s16_to_f32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s24_to_u8(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s24_to_s16(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s24_to_s32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s24_to_f32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s32_to_u8(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s32_to_s16(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s32_to_s24(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_s32_to_f32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_f32_to_u8(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_f32_to_s16(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_f32_to_s24(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_f32_to_s32(void* pOut, const void* pIn, ma_uint64 count, ma_dither_mode ditherMode); -MA_API void ma_pcm_convert(void* pOut, ma_format formatOut, const void* pIn, ma_format formatIn, ma_uint64 sampleCount, ma_dither_mode ditherMode); -MA_API void ma_convert_pcm_frames_format(void* pOut, ma_format formatOut, const void* pIn, ma_format formatIn, ma_uint64 frameCount, ma_uint32 channels, ma_dither_mode ditherMode); - -/* -Deinterleaves an interleaved buffer. -*/ -MA_API void ma_deinterleave_pcm_frames(ma_format format, ma_uint32 channels, ma_uint64 frameCount, const void* pInterleavedPCMFrames, void** ppDeinterleavedPCMFrames); - -/* -Interleaves a group of deinterleaved buffers. -*/ -MA_API void ma_interleave_pcm_frames(ma_format format, ma_uint32 channels, ma_uint64 frameCount, const void** ppDeinterleavedPCMFrames, void* pInterleavedPCMFrames); - - -/************************************************************************************************************************************************************ - -Channel Maps - -************************************************************************************************************************************************************/ -/* -This is used in the shuffle table to indicate that the channel index is undefined and should be ignored. -*/ -#define MA_CHANNEL_INDEX_NULL 255 - -/* -Retrieves the channel position of the specified channel in the given channel map. - -The pChannelMap parameter can be null, in which case miniaudio's default channel map will be assumed. -*/ -MA_API ma_channel ma_channel_map_get_channel(const ma_channel* pChannelMap, ma_uint32 channelCount, ma_uint32 channelIndex); - -/* -Initializes a blank channel map. - -When a blank channel map is specified anywhere it indicates that the native channel map should be used. -*/ -MA_API void ma_channel_map_init_blank(ma_channel* pChannelMap, ma_uint32 channels); - -/* -Helper for retrieving a standard channel map. - -The output channel map buffer must have a capacity of at least `channelMapCap`. -*/ -MA_API void ma_channel_map_init_standard(ma_standard_channel_map standardChannelMap, ma_channel* pChannelMap, size_t channelMapCap, ma_uint32 channels); - -/* -Copies a channel map. - -Both input and output channel map buffers must have a capacity of at at least `channels`. -*/ -MA_API void ma_channel_map_copy(ma_channel* pOut, const ma_channel* pIn, ma_uint32 channels); - -/* -Copies a channel map if one is specified, otherwise copies the default channel map. - -The output buffer must have a capacity of at least `channels`. If not NULL, the input channel map must also have a capacity of at least `channels`. -*/ -MA_API void ma_channel_map_copy_or_default(ma_channel* pOut, size_t channelMapCapOut, const ma_channel* pIn, ma_uint32 channels); - - -/* -Determines whether or not a channel map is valid. - -A blank channel map is valid (all channels set to MA_CHANNEL_NONE). The way a blank channel map is handled is context specific, but -is usually treated as a passthrough. - -Invalid channel maps: - - A channel map with no channels - - A channel map with more than one channel and a mono channel - -The channel map buffer must have a capacity of at least `channels`. -*/ -MA_API ma_bool32 ma_channel_map_is_valid(const ma_channel* pChannelMap, ma_uint32 channels); - -/* -Helper for comparing two channel maps for equality. - -This assumes the channel count is the same between the two. - -Both channels map buffers must have a capacity of at least `channels`. -*/ -MA_API ma_bool32 ma_channel_map_is_equal(const ma_channel* pChannelMapA, const ma_channel* pChannelMapB, ma_uint32 channels); - -/* -Helper for determining if a channel map is blank (all channels set to MA_CHANNEL_NONE). - -The channel map buffer must have a capacity of at least `channels`. -*/ -MA_API ma_bool32 ma_channel_map_is_blank(const ma_channel* pChannelMap, ma_uint32 channels); - -/* -Helper for determining whether or not a channel is present in the given channel map. - -The channel map buffer must have a capacity of at least `channels`. -*/ -MA_API ma_bool32 ma_channel_map_contains_channel_position(ma_uint32 channels, const ma_channel* pChannelMap, ma_channel channelPosition); - -/* -Find a channel position in the given channel map. Returns MA_TRUE if the channel is found; MA_FALSE otherwise. The -index of the channel is output to `pChannelIndex`. - -The channel map buffer must have a capacity of at least `channels`. -*/ -MA_API ma_bool32 ma_channel_map_find_channel_position(ma_uint32 channels, const ma_channel* pChannelMap, ma_channel channelPosition, ma_uint32* pChannelIndex); - -/* -Generates a string representing the given channel map. - -This is for printing and debugging purposes, not serialization/deserialization. - -Returns the length of the string, not including the null terminator. -*/ -MA_API size_t ma_channel_map_to_string(const ma_channel* pChannelMap, ma_uint32 channels, char* pBufferOut, size_t bufferCap); - -/* -Retrieves a human readable version of a channel position. -*/ -MA_API const char* ma_channel_position_to_string(ma_channel channel); - - -/************************************************************************************************************************************************************ - -Conversion Helpers - -************************************************************************************************************************************************************/ - -/* -High-level helper for doing a full format conversion in one go. Returns the number of output frames. Call this with pOut set to NULL to -determine the required size of the output buffer. frameCountOut should be set to the capacity of pOut. If pOut is NULL, frameCountOut is -ignored. - -A return value of 0 indicates an error. - -This function is useful for one-off bulk conversions, but if you're streaming data you should use the ma_data_converter APIs instead. -*/ -MA_API ma_uint64 ma_convert_frames(void* pOut, ma_uint64 frameCountOut, ma_format formatOut, ma_uint32 channelsOut, ma_uint32 sampleRateOut, const void* pIn, ma_uint64 frameCountIn, ma_format formatIn, ma_uint32 channelsIn, ma_uint32 sampleRateIn); -MA_API ma_uint64 ma_convert_frames_ex(void* pOut, ma_uint64 frameCountOut, const void* pIn, ma_uint64 frameCountIn, const ma_data_converter_config* pConfig); - - -/************************************************************************************************************************************************************ - -Ring Buffer - -************************************************************************************************************************************************************/ -typedef struct -{ - void* pBuffer; - ma_uint32 subbufferSizeInBytes; - ma_uint32 subbufferCount; - ma_uint32 subbufferStrideInBytes; - MA_ATOMIC(4, ma_uint32) encodedReadOffset; /* Most significant bit is the loop flag. Lower 31 bits contains the actual offset in bytes. Must be used atomically. */ - MA_ATOMIC(4, ma_uint32) encodedWriteOffset; /* Most significant bit is the loop flag. Lower 31 bits contains the actual offset in bytes. Must be used atomically. */ - ma_bool8 ownsBuffer; /* Used to know whether or not miniaudio is responsible for free()-ing the buffer. */ - ma_bool8 clearOnWriteAcquire; /* When set, clears the acquired write buffer before returning from ma_rb_acquire_write(). */ - ma_allocation_callbacks allocationCallbacks; -} ma_rb; - -MA_API ma_result ma_rb_init_ex(size_t subbufferSizeInBytes, size_t subbufferCount, size_t subbufferStrideInBytes, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_rb* pRB); -MA_API ma_result ma_rb_init(size_t bufferSizeInBytes, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_rb* pRB); -MA_API void ma_rb_uninit(ma_rb* pRB); -MA_API void ma_rb_reset(ma_rb* pRB); -MA_API ma_result ma_rb_acquire_read(ma_rb* pRB, size_t* pSizeInBytes, void** ppBufferOut); -MA_API ma_result ma_rb_commit_read(ma_rb* pRB, size_t sizeInBytes); -MA_API ma_result ma_rb_acquire_write(ma_rb* pRB, size_t* pSizeInBytes, void** ppBufferOut); -MA_API ma_result ma_rb_commit_write(ma_rb* pRB, size_t sizeInBytes); -MA_API ma_result ma_rb_seek_read(ma_rb* pRB, size_t offsetInBytes); -MA_API ma_result ma_rb_seek_write(ma_rb* pRB, size_t offsetInBytes); -MA_API ma_int32 ma_rb_pointer_distance(ma_rb* pRB); /* Returns the distance between the write pointer and the read pointer. Should never be negative for a correct program. Will return the number of bytes that can be read before the read pointer hits the write pointer. */ -MA_API ma_uint32 ma_rb_available_read(ma_rb* pRB); -MA_API ma_uint32 ma_rb_available_write(ma_rb* pRB); -MA_API size_t ma_rb_get_subbuffer_size(ma_rb* pRB); -MA_API size_t ma_rb_get_subbuffer_stride(ma_rb* pRB); -MA_API size_t ma_rb_get_subbuffer_offset(ma_rb* pRB, size_t subbufferIndex); -MA_API void* ma_rb_get_subbuffer_ptr(ma_rb* pRB, size_t subbufferIndex, void* pBuffer); - - -typedef struct -{ - ma_rb rb; - ma_format format; - ma_uint32 channels; -} ma_pcm_rb; - -MA_API ma_result ma_pcm_rb_init_ex(ma_format format, ma_uint32 channels, ma_uint32 subbufferSizeInFrames, ma_uint32 subbufferCount, ma_uint32 subbufferStrideInFrames, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_pcm_rb* pRB); -MA_API ma_result ma_pcm_rb_init(ma_format format, ma_uint32 channels, ma_uint32 bufferSizeInFrames, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_pcm_rb* pRB); -MA_API void ma_pcm_rb_uninit(ma_pcm_rb* pRB); -MA_API void ma_pcm_rb_reset(ma_pcm_rb* pRB); -MA_API ma_result ma_pcm_rb_acquire_read(ma_pcm_rb* pRB, ma_uint32* pSizeInFrames, void** ppBufferOut); -MA_API ma_result ma_pcm_rb_commit_read(ma_pcm_rb* pRB, ma_uint32 sizeInFrames); -MA_API ma_result ma_pcm_rb_acquire_write(ma_pcm_rb* pRB, ma_uint32* pSizeInFrames, void** ppBufferOut); -MA_API ma_result ma_pcm_rb_commit_write(ma_pcm_rb* pRB, ma_uint32 sizeInFrames); -MA_API ma_result ma_pcm_rb_seek_read(ma_pcm_rb* pRB, ma_uint32 offsetInFrames); -MA_API ma_result ma_pcm_rb_seek_write(ma_pcm_rb* pRB, ma_uint32 offsetInFrames); -MA_API ma_int32 ma_pcm_rb_pointer_distance(ma_pcm_rb* pRB); /* Return value is in frames. */ -MA_API ma_uint32 ma_pcm_rb_available_read(ma_pcm_rb* pRB); -MA_API ma_uint32 ma_pcm_rb_available_write(ma_pcm_rb* pRB); -MA_API ma_uint32 ma_pcm_rb_get_subbuffer_size(ma_pcm_rb* pRB); -MA_API ma_uint32 ma_pcm_rb_get_subbuffer_stride(ma_pcm_rb* pRB); -MA_API ma_uint32 ma_pcm_rb_get_subbuffer_offset(ma_pcm_rb* pRB, ma_uint32 subbufferIndex); -MA_API void* ma_pcm_rb_get_subbuffer_ptr(ma_pcm_rb* pRB, ma_uint32 subbufferIndex, void* pBuffer); - - -/* -The idea of the duplex ring buffer is to act as the intermediary buffer when running two asynchronous devices in a duplex set up. The -capture device writes to it, and then a playback device reads from it. - -At the moment this is just a simple naive implementation, but in the future I want to implement some dynamic resampling to seamlessly -handle desyncs. Note that the API is work in progress and may change at any time in any version. - -The size of the buffer is based on the capture side since that's what'll be written to the buffer. It is based on the capture period size -in frames. The internal sample rate of the capture device is also needed in order to calculate the size. -*/ -typedef struct -{ - ma_pcm_rb rb; -} ma_duplex_rb; - -MA_API ma_result ma_duplex_rb_init(ma_format captureFormat, ma_uint32 captureChannels, ma_uint32 sampleRate, ma_uint32 captureInternalSampleRate, ma_uint32 captureInternalPeriodSizeInFrames, const ma_allocation_callbacks* pAllocationCallbacks, ma_duplex_rb* pRB); -MA_API ma_result ma_duplex_rb_uninit(ma_duplex_rb* pRB); - - -/************************************************************************************************************************************************************ - -Miscellaneous Helpers - -************************************************************************************************************************************************************/ -/* -Retrieves a human readable description of the given result code. -*/ -MA_API const char* ma_result_description(ma_result result); - -/* -malloc() -*/ -MA_API void* ma_malloc(size_t sz, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -calloc() -*/ -MA_API void* ma_calloc(size_t sz, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -realloc() -*/ -MA_API void* ma_realloc(void* p, size_t sz, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -free() -*/ -MA_API void ma_free(void* p, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -Performs an aligned malloc, with the assumption that the alignment is a power of 2. -*/ -MA_API void* ma_aligned_malloc(size_t sz, size_t alignment, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -Free's an aligned malloc'd buffer. -*/ -MA_API void ma_aligned_free(void* p, const ma_allocation_callbacks* pAllocationCallbacks); - -/* -Retrieves a friendly name for a format. -*/ -MA_API const char* ma_get_format_name(ma_format format); - -/* -Blends two frames in floating point format. -*/ -MA_API void ma_blend_f32(float* pOut, float* pInA, float* pInB, float factor, ma_uint32 channels); - -/* -Retrieves the size of a sample in bytes for the given format. - -This API is efficient and is implemented using a lookup table. - -Thread Safety: SAFE - This API is pure. -*/ -MA_API ma_uint32 ma_get_bytes_per_sample(ma_format format); -static MA_INLINE ma_uint32 ma_get_bytes_per_frame(ma_format format, ma_uint32 channels) { return ma_get_bytes_per_sample(format) * channels; } - -/* -Converts a log level to a string. -*/ -MA_API const char* ma_log_level_to_string(ma_uint32 logLevel); - - - - -/************************************************************************************************************************************************************ - -Synchronization - -************************************************************************************************************************************************************/ -/* -Locks a spinlock. -*/ -MA_API ma_result ma_spinlock_lock(volatile ma_spinlock* pSpinlock); - -/* -Locks a spinlock, but does not yield() when looping. -*/ -MA_API ma_result ma_spinlock_lock_noyield(volatile ma_spinlock* pSpinlock); - -/* -Unlocks a spinlock. -*/ -MA_API ma_result ma_spinlock_unlock(volatile ma_spinlock* pSpinlock); - - -#ifndef MA_NO_THREADING - -/* -Creates a mutex. - -A mutex must be created from a valid context. A mutex is initially unlocked. -*/ -MA_API ma_result ma_mutex_init(ma_mutex* pMutex); - -/* -Deletes a mutex. -*/ -MA_API void ma_mutex_uninit(ma_mutex* pMutex); - -/* -Locks a mutex with an infinite timeout. -*/ -MA_API void ma_mutex_lock(ma_mutex* pMutex); - -/* -Unlocks a mutex. -*/ -MA_API void ma_mutex_unlock(ma_mutex* pMutex); - - -/* -Initializes an auto-reset event. -*/ -MA_API ma_result ma_event_init(ma_event* pEvent); - -/* -Uninitializes an auto-reset event. -*/ -MA_API void ma_event_uninit(ma_event* pEvent); - -/* -Waits for the specified auto-reset event to become signalled. -*/ -MA_API ma_result ma_event_wait(ma_event* pEvent); - -/* -Signals the specified auto-reset event. -*/ -MA_API ma_result ma_event_signal(ma_event* pEvent); -#endif /* MA_NO_THREADING */ - - -/* -Fence -===== -This locks while the counter is larger than 0. Counter can be incremented and decremented by any -thread, but care needs to be taken when waiting. It is possible for one thread to acquire the -fence just as another thread returns from ma_fence_wait(). - -The idea behind a fence is to allow you to wait for a group of operations to complete. When an -operation starts, the counter is incremented which locks the fence. When the operation completes, -the fence will be released which decrements the counter. ma_fence_wait() will block until the -counter hits zero. - -If threading is disabled, ma_fence_wait() will spin on the counter. -*/ -typedef struct -{ -#ifndef MA_NO_THREADING - ma_event e; -#endif - ma_uint32 counter; -} ma_fence; - -MA_API ma_result ma_fence_init(ma_fence* pFence); -MA_API void ma_fence_uninit(ma_fence* pFence); -MA_API ma_result ma_fence_acquire(ma_fence* pFence); /* Increment counter. */ -MA_API ma_result ma_fence_release(ma_fence* pFence); /* Decrement counter. */ -MA_API ma_result ma_fence_wait(ma_fence* pFence); /* Wait for counter to reach 0. */ - - - -/* -Notification callback for asynchronous operations. -*/ -typedef void ma_async_notification; - -typedef struct -{ - void (* onSignal)(ma_async_notification* pNotification); -} ma_async_notification_callbacks; - -MA_API ma_result ma_async_notification_signal(ma_async_notification* pNotification); - - -/* -Simple polling notification. - -This just sets a variable when the notification has been signalled which is then polled with ma_async_notification_poll_is_signalled() -*/ -typedef struct -{ - ma_async_notification_callbacks cb; - ma_bool32 signalled; -} ma_async_notification_poll; - -MA_API ma_result ma_async_notification_poll_init(ma_async_notification_poll* pNotificationPoll); -MA_API ma_bool32 ma_async_notification_poll_is_signalled(const ma_async_notification_poll* pNotificationPoll); - - -/* -Event Notification - -This uses an ma_event. If threading is disabled (MA_NO_THREADING), initialization will fail. -*/ -typedef struct -{ - ma_async_notification_callbacks cb; -#ifndef MA_NO_THREADING - ma_event e; -#endif -} ma_async_notification_event; - -MA_API ma_result ma_async_notification_event_init(ma_async_notification_event* pNotificationEvent); -MA_API ma_result ma_async_notification_event_uninit(ma_async_notification_event* pNotificationEvent); -MA_API ma_result ma_async_notification_event_wait(ma_async_notification_event* pNotificationEvent); -MA_API ma_result ma_async_notification_event_signal(ma_async_notification_event* pNotificationEvent); - - - - -/************************************************************************************************************************************************************ - -Job Queue - -************************************************************************************************************************************************************/ - -/* -Slot Allocator --------------- -The idea of the slot allocator is for it to be used in conjunction with a fixed sized buffer. You use the slot allocator to allocator an index that can be used -as the insertion point for an object. - -Slots are reference counted to help mitigate the ABA problem in the lock-free queue we use for tracking jobs. - -The slot index is stored in the low 32 bits. The reference counter is stored in the high 32 bits: - - +-----------------+-----------------+ - | 32 Bits | 32 Bits | - +-----------------+-----------------+ - | Reference Count | Slot Index | - +-----------------+-----------------+ -*/ -typedef struct -{ - ma_uint32 capacity; /* The number of slots to make available. */ -} ma_slot_allocator_config; - -MA_API ma_slot_allocator_config ma_slot_allocator_config_init(ma_uint32 capacity); - - -typedef struct -{ - MA_ATOMIC(4, ma_uint32) bitfield; /* Must be used atomically because the allocation and freeing routines need to make copies of this which must never be optimized away by the compiler. */ -} ma_slot_allocator_group; - -typedef struct -{ - ma_slot_allocator_group* pGroups; /* Slots are grouped in chunks of 32. */ - ma_uint32* pSlots; /* 32 bits for reference counting for ABA mitigation. */ - ma_uint32 count; /* Allocation count. */ - ma_uint32 capacity; - - /* Memory management. */ - ma_bool32 _ownsHeap; - void* _pHeap; -} ma_slot_allocator; - -MA_API ma_result ma_slot_allocator_get_heap_size(const ma_slot_allocator_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_slot_allocator_init_preallocated(const ma_slot_allocator_config* pConfig, void* pHeap, ma_slot_allocator* pAllocator); -MA_API ma_result ma_slot_allocator_init(const ma_slot_allocator_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_slot_allocator* pAllocator); -MA_API void ma_slot_allocator_uninit(ma_slot_allocator* pAllocator, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_slot_allocator_alloc(ma_slot_allocator* pAllocator, ma_uint64* pSlot); -MA_API ma_result ma_slot_allocator_free(ma_slot_allocator* pAllocator, ma_uint64 slot); - - -typedef struct ma_job ma_job; - -/* -Callback for processing a job. Each job type will have their own processing callback which will be -called by ma_job_process(). -*/ -typedef ma_result (* ma_job_proc)(ma_job* pJob); - -/* When a job type is added here an callback needs to be added go "g_jobVTable" in the implementation section. */ -typedef enum -{ - /* Miscellaneous. */ - MA_JOB_TYPE_QUIT = 0, - MA_JOB_TYPE_CUSTOM, - - /* Resource Manager. */ - MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER_NODE, - MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER_NODE, - MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE, - MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER, - MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER, - MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_STREAM, - MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_STREAM, - MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_STREAM, - MA_JOB_TYPE_RESOURCE_MANAGER_SEEK_DATA_STREAM, - - /* Device. */ - MA_JOB_TYPE_DEVICE_AAUDIO_REROUTE, - - /* Count. Must always be last. */ - MA_JOB_TYPE_COUNT -} ma_job_type; - -struct ma_job -{ - union - { - struct - { - ma_uint16 code; /* Job type. */ - ma_uint16 slot; /* Index into a ma_slot_allocator. */ - ma_uint32 refcount; - } breakup; - ma_uint64 allocation; - } toc; /* 8 bytes. We encode the job code into the slot allocation data to save space. */ - MA_ATOMIC(8, ma_uint64) next; /* refcount + slot for the next item. Does not include the job code. */ - ma_uint32 order; /* Execution order. Used to create a data dependency and ensure a job is executed in order. Usage is contextual depending on the job type. */ - - union - { - /* Miscellaneous. */ - struct - { - ma_job_proc proc; - ma_uintptr data0; - ma_uintptr data1; - } custom; - - /* Resource Manager */ - union - { - struct - { - /*ma_resource_manager**/ void* pResourceManager; - /*ma_resource_manager_data_buffer_node**/ void* pDataBufferNode; - char* pFilePath; - wchar_t* pFilePathW; - ma_uint32 flags; /* Resource manager data source flags that were used when initializing the data buffer. */ - ma_async_notification* pInitNotification; /* Signalled when the data buffer has been initialized and the format/channels/rate can be retrieved. */ - ma_async_notification* pDoneNotification; /* Signalled when the data buffer has been fully decoded. Will be passed through to MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE when decoding. */ - ma_fence* pInitFence; /* Released when initialization of the decoder is complete. */ - ma_fence* pDoneFence; /* Released if initialization of the decoder fails. Passed through to PAGE_DATA_BUFFER_NODE untouched if init is successful. */ - } loadDataBufferNode; - struct - { - /*ma_resource_manager**/ void* pResourceManager; - /*ma_resource_manager_data_buffer_node**/ void* pDataBufferNode; - ma_async_notification* pDoneNotification; - ma_fence* pDoneFence; - } freeDataBufferNode; - struct - { - /*ma_resource_manager**/ void* pResourceManager; - /*ma_resource_manager_data_buffer_node**/ void* pDataBufferNode; - /*ma_decoder**/ void* pDecoder; - ma_async_notification* pDoneNotification; /* Signalled when the data buffer has been fully decoded. */ - ma_fence* pDoneFence; /* Passed through from LOAD_DATA_BUFFER_NODE and released when the data buffer completes decoding or an error occurs. */ - } pageDataBufferNode; - - struct - { - /*ma_resource_manager_data_buffer**/ void* pDataBuffer; - ma_async_notification* pInitNotification; /* Signalled when the data buffer has been initialized and the format/channels/rate can be retrieved. */ - ma_async_notification* pDoneNotification; /* Signalled when the data buffer has been fully decoded. */ - ma_fence* pInitFence; /* Released when the data buffer has been initialized and the format/channels/rate can be retrieved. */ - ma_fence* pDoneFence; /* Released when the data buffer has been fully decoded. */ - ma_uint64 rangeBegInPCMFrames; - ma_uint64 rangeEndInPCMFrames; - ma_uint64 loopPointBegInPCMFrames; - ma_uint64 loopPointEndInPCMFrames; - ma_uint32 isLooping; - } loadDataBuffer; - struct - { - /*ma_resource_manager_data_buffer**/ void* pDataBuffer; - ma_async_notification* pDoneNotification; - ma_fence* pDoneFence; - } freeDataBuffer; - - struct - { - /*ma_resource_manager_data_stream**/ void* pDataStream; - char* pFilePath; /* Allocated when the job is posted, freed by the job thread after loading. */ - wchar_t* pFilePathW; /* ^ As above ^. Only used if pFilePath is NULL. */ - ma_uint64 initialSeekPoint; - ma_async_notification* pInitNotification; /* Signalled after the first two pages have been decoded and frames can be read from the stream. */ - ma_fence* pInitFence; - } loadDataStream; - struct - { - /*ma_resource_manager_data_stream**/ void* pDataStream; - ma_async_notification* pDoneNotification; - ma_fence* pDoneFence; - } freeDataStream; - struct - { - /*ma_resource_manager_data_stream**/ void* pDataStream; - ma_uint32 pageIndex; /* The index of the page to decode into. */ - } pageDataStream; - struct - { - /*ma_resource_manager_data_stream**/ void* pDataStream; - ma_uint64 frameIndex; - } seekDataStream; - } resourceManager; - - /* Device. */ - union - { - union - { - struct - { - /*ma_device**/ void* pDevice; - /*ma_device_type*/ ma_uint32 deviceType; - } reroute; - } aaudio; - } device; - } data; -}; - -MA_API ma_job ma_job_init(ma_uint16 code); -MA_API ma_result ma_job_process(ma_job* pJob); - - -/* -When set, ma_job_queue_next() will not wait and no semaphore will be signaled in -ma_job_queue_post(). ma_job_queue_next() will return MA_NO_DATA_AVAILABLE if nothing is available. - -This flag should always be used for platforms that do not support multithreading. -*/ -typedef enum -{ - MA_JOB_QUEUE_FLAG_NON_BLOCKING = 0x00000001 -} ma_job_queue_flags; - -typedef struct -{ - ma_uint32 flags; - ma_uint32 capacity; /* The maximum number of jobs that can fit in the queue at a time. */ -} ma_job_queue_config; - -MA_API ma_job_queue_config ma_job_queue_config_init(ma_uint32 flags, ma_uint32 capacity); - - -typedef struct -{ - ma_uint32 flags; /* Flags passed in at initialization time. */ - ma_uint32 capacity; /* The maximum number of jobs that can fit in the queue at a time. Set by the config. */ - MA_ATOMIC(8, ma_uint64) head; /* The first item in the list. Required for removing from the top of the list. */ - MA_ATOMIC(8, ma_uint64) tail; /* The last item in the list. Required for appending to the end of the list. */ -#ifndef MA_NO_THREADING - ma_semaphore sem; /* Only used when MA_JOB_QUEUE_FLAG_NON_BLOCKING is unset. */ -#endif - ma_slot_allocator allocator; - ma_job* pJobs; -#ifndef MA_USE_EXPERIMENTAL_LOCK_FREE_JOB_QUEUE - ma_spinlock lock; -#endif - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_job_queue; - -MA_API ma_result ma_job_queue_get_heap_size(const ma_job_queue_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_job_queue_init_preallocated(const ma_job_queue_config* pConfig, void* pHeap, ma_job_queue* pQueue); -MA_API ma_result ma_job_queue_init(const ma_job_queue_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_job_queue* pQueue); -MA_API void ma_job_queue_uninit(ma_job_queue* pQueue, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_job_queue_post(ma_job_queue* pQueue, const ma_job* pJob); -MA_API ma_result ma_job_queue_next(ma_job_queue* pQueue, ma_job* pJob); /* Returns MA_CANCELLED if the next job is a quit job. */ - - - -/************************************************************************************************************************************************************ -************************************************************************************************************************************************************* - -DEVICE I/O -========== - -This section contains the APIs for device playback and capture. Here is where you'll find ma_device_init(), etc. - -************************************************************************************************************************************************************* -************************************************************************************************************************************************************/ -#ifndef MA_NO_DEVICE_IO -/* Some backends are only supported on certain platforms. */ -#if defined(MA_WIN32) - #define MA_SUPPORT_WASAPI - - #if defined(MA_WIN32_DESKTOP) /* DirectSound and WinMM backends are only supported on desktops. */ - #define MA_SUPPORT_DSOUND - #define MA_SUPPORT_WINMM - - /* Don't enable JACK here if compiling with Cosmopolitan. It'll be enabled in the Linux section below. */ - #if !defined(__COSMOPOLITAN__) - #define MA_SUPPORT_JACK /* JACK is technically supported on Windows, but I don't know how many people use it in practice... */ - #endif - #endif -#endif -#if defined(MA_UNIX) && !defined(MA_ORBIS) && !defined(MA_PROSPERO) - #if defined(MA_LINUX) - #if !defined(MA_ANDROID) && !defined(__COSMOPOLITAN__) /* ALSA is not supported on Android. */ - #define MA_SUPPORT_ALSA - #endif - #endif - #if !defined(MA_BSD) && !defined(MA_ANDROID) && !defined(MA_EMSCRIPTEN) - #define MA_SUPPORT_PULSEAUDIO - #define MA_SUPPORT_JACK - #endif - #if defined(__OpenBSD__) /* <-- Change this to "#if defined(MA_BSD)" to enable sndio on all BSD flavors. */ - #define MA_SUPPORT_SNDIO /* sndio is only supported on OpenBSD for now. May be expanded later if there's demand. */ - #endif - #if defined(__NetBSD__) || defined(__OpenBSD__) - #define MA_SUPPORT_AUDIO4 /* Only support audio(4) on platforms with known support. */ - #endif - #if defined(__FreeBSD__) || defined(__DragonFly__) - #define MA_SUPPORT_OSS /* Only support OSS on specific platforms with known support. */ - #endif -#endif -#if defined(MA_ANDROID) - #define MA_SUPPORT_AAUDIO - #define MA_SUPPORT_OPENSL -#endif -#if defined(MA_APPLE) - #define MA_SUPPORT_COREAUDIO -#endif -#if defined(MA_EMSCRIPTEN) - #define MA_SUPPORT_WEBAUDIO -#endif - -/* All platforms should support custom backends. */ -#define MA_SUPPORT_CUSTOM - -/* Explicitly disable the Null backend for Emscripten because it uses a background thread which is not properly supported right now. */ -#if !defined(MA_EMSCRIPTEN) -#define MA_SUPPORT_NULL -#endif - - -#if defined(MA_SUPPORT_WASAPI) && !defined(MA_NO_WASAPI) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_WASAPI)) - #define MA_HAS_WASAPI -#endif -#if defined(MA_SUPPORT_DSOUND) && !defined(MA_NO_DSOUND) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_DSOUND)) - #define MA_HAS_DSOUND -#endif -#if defined(MA_SUPPORT_WINMM) && !defined(MA_NO_WINMM) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_WINMM)) - #define MA_HAS_WINMM -#endif -#if defined(MA_SUPPORT_ALSA) && !defined(MA_NO_ALSA) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_ALSA)) - #define MA_HAS_ALSA -#endif -#if defined(MA_SUPPORT_PULSEAUDIO) && !defined(MA_NO_PULSEAUDIO) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_PULSEAUDIO)) - #define MA_HAS_PULSEAUDIO -#endif -#if defined(MA_SUPPORT_JACK) && !defined(MA_NO_JACK) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_JACK)) - #define MA_HAS_JACK -#endif -#if defined(MA_SUPPORT_COREAUDIO) && !defined(MA_NO_COREAUDIO) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_COREAUDIO)) - #define MA_HAS_COREAUDIO -#endif -#if defined(MA_SUPPORT_SNDIO) && !defined(MA_NO_SNDIO) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_SNDIO)) - #define MA_HAS_SNDIO -#endif -#if defined(MA_SUPPORT_AUDIO4) && !defined(MA_NO_AUDIO4) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_AUDIO4)) - #define MA_HAS_AUDIO4 -#endif -#if defined(MA_SUPPORT_OSS) && !defined(MA_NO_OSS) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_OSS)) - #define MA_HAS_OSS -#endif -#if defined(MA_SUPPORT_AAUDIO) && !defined(MA_NO_AAUDIO) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_AAUDIO)) - #define MA_HAS_AAUDIO -#endif -#if defined(MA_SUPPORT_OPENSL) && !defined(MA_NO_OPENSL) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_OPENSL)) - #define MA_HAS_OPENSL -#endif -#if defined(MA_SUPPORT_WEBAUDIO) && !defined(MA_NO_WEBAUDIO) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_WEBAUDIO)) - #define MA_HAS_WEBAUDIO -#endif -#if defined(MA_SUPPORT_CUSTOM) && !defined(MA_NO_CUSTOM) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_CUSTOM)) - #define MA_HAS_CUSTOM -#endif -#if defined(MA_SUPPORT_NULL) && !defined(MA_NO_NULL) && (!defined(MA_ENABLE_ONLY_SPECIFIC_BACKENDS) || defined(MA_ENABLE_NULL)) - #define MA_HAS_NULL -#endif - -typedef enum -{ - ma_device_state_uninitialized = 0, - ma_device_state_stopped = 1, /* The device's default state after initialization. */ - ma_device_state_started = 2, /* The device is started and is requesting and/or delivering audio data. */ - ma_device_state_starting = 3, /* Transitioning from a stopped state to started. */ - ma_device_state_stopping = 4 /* Transitioning from a started state to stopped. */ -} ma_device_state; - -MA_ATOMIC_SAFE_TYPE_DECL(i32, 4, device_state) - - -#ifdef MA_SUPPORT_WASAPI -/* We need a IMMNotificationClient object for WASAPI. */ -typedef struct -{ - void* lpVtbl; - ma_uint32 counter; - ma_device* pDevice; -} ma_IMMNotificationClient; -#endif - -/* Backend enums must be in priority order. */ -typedef enum -{ - ma_backend_wasapi, - ma_backend_dsound, - ma_backend_winmm, - ma_backend_coreaudio, - ma_backend_sndio, - ma_backend_audio4, - ma_backend_oss, - ma_backend_pulseaudio, - ma_backend_alsa, - ma_backend_jack, - ma_backend_aaudio, - ma_backend_opensl, - ma_backend_webaudio, - ma_backend_custom, /* <-- Custom backend, with callbacks defined by the context config. */ - ma_backend_null /* <-- Must always be the last item. Lowest priority, and used as the terminator for backend enumeration. */ -} ma_backend; - -#define MA_BACKEND_COUNT (ma_backend_null+1) - - -/* -Device job thread. This is used by backends that require asynchronous processing of certain -operations. It is not used by all backends. - -The device job thread is made up of a thread and a job queue. You can post a job to the thread with -ma_device_job_thread_post(). The thread will do the processing of the job. -*/ -typedef struct -{ - ma_bool32 noThread; /* Set this to true if you want to process jobs yourself. */ - ma_uint32 jobQueueCapacity; - ma_uint32 jobQueueFlags; -} ma_device_job_thread_config; - -MA_API ma_device_job_thread_config ma_device_job_thread_config_init(void); - -typedef struct -{ - ma_thread thread; - ma_job_queue jobQueue; - ma_bool32 _hasThread; -} ma_device_job_thread; - -MA_API ma_result ma_device_job_thread_init(const ma_device_job_thread_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_device_job_thread* pJobThread); -MA_API void ma_device_job_thread_uninit(ma_device_job_thread* pJobThread, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_device_job_thread_post(ma_device_job_thread* pJobThread, const ma_job* pJob); -MA_API ma_result ma_device_job_thread_next(ma_device_job_thread* pJobThread, ma_job* pJob); - - - -/* Device notification types. */ -typedef enum -{ - ma_device_notification_type_started, - ma_device_notification_type_stopped, - ma_device_notification_type_rerouted, - ma_device_notification_type_interruption_began, - ma_device_notification_type_interruption_ended -} ma_device_notification_type; - -typedef struct -{ - ma_device* pDevice; - ma_device_notification_type type; - union - { - struct - { - int _unused; - } started; - struct - { - int _unused; - } stopped; - struct - { - int _unused; - } rerouted; - struct - { - int _unused; - } interruption; - } data; -} ma_device_notification; - -/* -The notification callback for when the application should be notified of a change to the device. - -This callback is used for notifying the application of changes such as when the device has started, -stopped, rerouted or an interruption has occurred. Note that not all backends will post all -notification types. For example, some backends will perform automatic stream routing without any -kind of notification to the host program which means miniaudio will never know about it and will -never be able to fire the rerouted notification. You should keep this in mind when designing your -program. - -The stopped notification will *not* get fired when a device is rerouted. - - -Parameters ----------- -pNotification (in) - A pointer to a structure containing information about the event. Use the `pDevice` member of - this object to retrieve the relevant device. The `type` member can be used to discriminate - against each of the notification types. - - -Remarks -------- -Do not restart or uninitialize the device from the callback. - -Not all notifications will be triggered by all backends, however the started and stopped events -should be reliable for all backends. Some backends do not have a good way to detect device -stoppages due to unplugging the device which may result in the stopped callback not getting -fired. This has been observed with at least one BSD variant. - -The rerouted notification is fired *after* the reroute has occurred. The stopped notification will -*not* get fired when a device is rerouted. The following backends are known to do automatic stream -rerouting, but do not have a way to be notified of the change: - - * DirectSound - -The interruption notifications are used on mobile platforms for detecting when audio is interrupted -due to things like an incoming phone call. Currently this is only implemented on iOS. None of the -Android backends will report this notification. -*/ -typedef void (* ma_device_notification_proc)(const ma_device_notification* pNotification); - - -/* -The callback for processing audio data from the device. - -The data callback is fired by miniaudio whenever the device needs to have more data delivered to a playback device, or when a capture device has some data -available. This is called as soon as the backend asks for more data which means it may be called with inconsistent frame counts. You cannot assume the -callback will be fired with a consistent frame count. - - -Parameters ----------- -pDevice (in) - A pointer to the relevant device. - -pOutput (out) - A pointer to the output buffer that will receive audio data that will later be played back through the speakers. This will be non-null for a playback or - full-duplex device and null for a capture and loopback device. - -pInput (in) - A pointer to the buffer containing input data from a recording device. This will be non-null for a capture, full-duplex or loopback device and null for a - playback device. - -frameCount (in) - The number of PCM frames to process. Note that this will not necessarily be equal to what you requested when you initialized the device. The - `periodSizeInFrames` and `periodSizeInMilliseconds` members of the device config are just hints, and are not necessarily exactly what you'll get. You must - not assume this will always be the same value each time the callback is fired. - - -Remarks -------- -You cannot stop and start the device from inside the callback or else you'll get a deadlock. You must also not uninitialize the device from inside the -callback. The following APIs cannot be called from inside the callback: - - ma_device_init() - ma_device_init_ex() - ma_device_uninit() - ma_device_start() - ma_device_stop() - -The proper way to stop the device is to call `ma_device_stop()` from a different thread, normally the main application thread. -*/ -typedef void (* ma_device_data_proc)(ma_device* pDevice, void* pOutput, const void* pInput, ma_uint32 frameCount); - - - - -/* -DEPRECATED. Use ma_device_notification_proc instead. - -The callback for when the device has been stopped. - -This will be called when the device is stopped explicitly with `ma_device_stop()` and also called implicitly when the device is stopped through external forces -such as being unplugged or an internal error occurring. - - -Parameters ----------- -pDevice (in) - A pointer to the device that has just stopped. - - -Remarks -------- -Do not restart or uninitialize the device from the callback. -*/ -typedef void (* ma_stop_proc)(ma_device* pDevice); /* DEPRECATED. Use ma_device_notification_proc instead. */ - -typedef enum -{ - ma_device_type_playback = 1, - ma_device_type_capture = 2, - ma_device_type_duplex = ma_device_type_playback | ma_device_type_capture, /* 3 */ - ma_device_type_loopback = 4 -} ma_device_type; - -typedef enum -{ - ma_share_mode_shared = 0, - ma_share_mode_exclusive -} ma_share_mode; - -/* iOS/tvOS/watchOS session categories. */ -typedef enum -{ - ma_ios_session_category_default = 0, /* AVAudioSessionCategoryPlayAndRecord. */ - ma_ios_session_category_none, /* Leave the session category unchanged. */ - ma_ios_session_category_ambient, /* AVAudioSessionCategoryAmbient */ - ma_ios_session_category_solo_ambient, /* AVAudioSessionCategorySoloAmbient */ - ma_ios_session_category_playback, /* AVAudioSessionCategoryPlayback */ - ma_ios_session_category_record, /* AVAudioSessionCategoryRecord */ - ma_ios_session_category_play_and_record, /* AVAudioSessionCategoryPlayAndRecord */ - ma_ios_session_category_multi_route /* AVAudioSessionCategoryMultiRoute */ -} ma_ios_session_category; - -/* iOS/tvOS/watchOS session category options */ -typedef enum -{ - ma_ios_session_category_option_mix_with_others = 0x01, /* AVAudioSessionCategoryOptionMixWithOthers */ - ma_ios_session_category_option_duck_others = 0x02, /* AVAudioSessionCategoryOptionDuckOthers */ - ma_ios_session_category_option_allow_bluetooth = 0x04, /* AVAudioSessionCategoryOptionAllowBluetooth */ - ma_ios_session_category_option_default_to_speaker = 0x08, /* AVAudioSessionCategoryOptionDefaultToSpeaker */ - ma_ios_session_category_option_interrupt_spoken_audio_and_mix_with_others = 0x11, /* AVAudioSessionCategoryOptionInterruptSpokenAudioAndMixWithOthers */ - ma_ios_session_category_option_allow_bluetooth_a2dp = 0x20, /* AVAudioSessionCategoryOptionAllowBluetoothA2DP */ - ma_ios_session_category_option_allow_air_play = 0x40, /* AVAudioSessionCategoryOptionAllowAirPlay */ -} ma_ios_session_category_option; - -/* OpenSL stream types. */ -typedef enum -{ - ma_opensl_stream_type_default = 0, /* Leaves the stream type unset. */ - ma_opensl_stream_type_voice, /* SL_ANDROID_STREAM_VOICE */ - ma_opensl_stream_type_system, /* SL_ANDROID_STREAM_SYSTEM */ - ma_opensl_stream_type_ring, /* SL_ANDROID_STREAM_RING */ - ma_opensl_stream_type_media, /* SL_ANDROID_STREAM_MEDIA */ - ma_opensl_stream_type_alarm, /* SL_ANDROID_STREAM_ALARM */ - ma_opensl_stream_type_notification /* SL_ANDROID_STREAM_NOTIFICATION */ -} ma_opensl_stream_type; - -/* OpenSL recording presets. */ -typedef enum -{ - ma_opensl_recording_preset_default = 0, /* Leaves the input preset unset. */ - ma_opensl_recording_preset_generic, /* SL_ANDROID_RECORDING_PRESET_GENERIC */ - ma_opensl_recording_preset_camcorder, /* SL_ANDROID_RECORDING_PRESET_CAMCORDER */ - ma_opensl_recording_preset_voice_recognition, /* SL_ANDROID_RECORDING_PRESET_VOICE_RECOGNITION */ - ma_opensl_recording_preset_voice_communication, /* SL_ANDROID_RECORDING_PRESET_VOICE_COMMUNICATION */ - ma_opensl_recording_preset_voice_unprocessed /* SL_ANDROID_RECORDING_PRESET_UNPROCESSED */ -} ma_opensl_recording_preset; - -/* WASAPI audio thread priority characteristics. */ -typedef enum -{ - ma_wasapi_usage_default = 0, - ma_wasapi_usage_games, - ma_wasapi_usage_pro_audio, -} ma_wasapi_usage; - -/* AAudio usage types. */ -typedef enum -{ - ma_aaudio_usage_default = 0, /* Leaves the usage type unset. */ - ma_aaudio_usage_media, /* AAUDIO_USAGE_MEDIA */ - ma_aaudio_usage_voice_communication, /* AAUDIO_USAGE_VOICE_COMMUNICATION */ - ma_aaudio_usage_voice_communication_signalling, /* AAUDIO_USAGE_VOICE_COMMUNICATION_SIGNALLING */ - ma_aaudio_usage_alarm, /* AAUDIO_USAGE_ALARM */ - ma_aaudio_usage_notification, /* AAUDIO_USAGE_NOTIFICATION */ - ma_aaudio_usage_notification_ringtone, /* AAUDIO_USAGE_NOTIFICATION_RINGTONE */ - ma_aaudio_usage_notification_event, /* AAUDIO_USAGE_NOTIFICATION_EVENT */ - ma_aaudio_usage_assistance_accessibility, /* AAUDIO_USAGE_ASSISTANCE_ACCESSIBILITY */ - ma_aaudio_usage_assistance_navigation_guidance, /* AAUDIO_USAGE_ASSISTANCE_NAVIGATION_GUIDANCE */ - ma_aaudio_usage_assistance_sonification, /* AAUDIO_USAGE_ASSISTANCE_SONIFICATION */ - ma_aaudio_usage_game, /* AAUDIO_USAGE_GAME */ - ma_aaudio_usage_assitant, /* AAUDIO_USAGE_ASSISTANT */ - ma_aaudio_usage_emergency, /* AAUDIO_SYSTEM_USAGE_EMERGENCY */ - ma_aaudio_usage_safety, /* AAUDIO_SYSTEM_USAGE_SAFETY */ - ma_aaudio_usage_vehicle_status, /* AAUDIO_SYSTEM_USAGE_VEHICLE_STATUS */ - ma_aaudio_usage_announcement /* AAUDIO_SYSTEM_USAGE_ANNOUNCEMENT */ -} ma_aaudio_usage; - -/* AAudio content types. */ -typedef enum -{ - ma_aaudio_content_type_default = 0, /* Leaves the content type unset. */ - ma_aaudio_content_type_speech, /* AAUDIO_CONTENT_TYPE_SPEECH */ - ma_aaudio_content_type_music, /* AAUDIO_CONTENT_TYPE_MUSIC */ - ma_aaudio_content_type_movie, /* AAUDIO_CONTENT_TYPE_MOVIE */ - ma_aaudio_content_type_sonification /* AAUDIO_CONTENT_TYPE_SONIFICATION */ -} ma_aaudio_content_type; - -/* AAudio input presets. */ -typedef enum -{ - ma_aaudio_input_preset_default = 0, /* Leaves the input preset unset. */ - ma_aaudio_input_preset_generic, /* AAUDIO_INPUT_PRESET_GENERIC */ - ma_aaudio_input_preset_camcorder, /* AAUDIO_INPUT_PRESET_CAMCORDER */ - ma_aaudio_input_preset_voice_recognition, /* AAUDIO_INPUT_PRESET_VOICE_RECOGNITION */ - ma_aaudio_input_preset_voice_communication, /* AAUDIO_INPUT_PRESET_VOICE_COMMUNICATION */ - ma_aaudio_input_preset_unprocessed, /* AAUDIO_INPUT_PRESET_UNPROCESSED */ - ma_aaudio_input_preset_voice_performance /* AAUDIO_INPUT_PRESET_VOICE_PERFORMANCE */ -} ma_aaudio_input_preset; - -typedef enum -{ - ma_aaudio_allow_capture_default = 0, /* Leaves the allowed capture policy unset. */ - ma_aaudio_allow_capture_by_all, /* AAUDIO_ALLOW_CAPTURE_BY_ALL */ - ma_aaudio_allow_capture_by_system, /* AAUDIO_ALLOW_CAPTURE_BY_SYSTEM */ - ma_aaudio_allow_capture_by_none /* AAUDIO_ALLOW_CAPTURE_BY_NONE */ -} ma_aaudio_allowed_capture_policy; - -typedef union -{ - ma_int64 counter; - double counterD; -} ma_timer; - -typedef union -{ - ma_wchar_win32 wasapi[64]; /* WASAPI uses a wchar_t string for identification. */ - ma_uint8 dsound[16]; /* DirectSound uses a GUID for identification. */ - /*UINT_PTR*/ ma_uint32 winmm; /* When creating a device, WinMM expects a Win32 UINT_PTR for device identification. In practice it's actually just a UINT. */ - char alsa[256]; /* ALSA uses a name string for identification. */ - char pulse[256]; /* PulseAudio uses a name string for identification. */ - int jack; /* JACK always uses default devices. */ - char coreaudio[256]; /* Core Audio uses a string for identification. */ - char sndio[256]; /* "snd/0", etc. */ - char audio4[256]; /* "/dev/audio", etc. */ - char oss[64]; /* "dev/dsp0", etc. "dev/dsp" for the default device. */ - ma_int32 aaudio; /* AAudio uses a 32-bit integer for identification. */ - ma_uint32 opensl; /* OpenSL|ES uses a 32-bit unsigned integer for identification. */ - char webaudio[32]; /* Web Audio always uses default devices for now, but if this changes it'll be a GUID. */ - union - { - int i; - char s[256]; - void* p; - } custom; /* The custom backend could be anything. Give them a few options. */ - int nullbackend; /* The null backend uses an integer for device IDs. */ -} ma_device_id; - - -typedef struct ma_context_config ma_context_config; -typedef struct ma_device_config ma_device_config; -typedef struct ma_backend_callbacks ma_backend_callbacks; - -#define MA_DATA_FORMAT_FLAG_EXCLUSIVE_MODE (1U << 1) /* If set, this is supported in exclusive mode. Otherwise not natively supported by exclusive mode. */ - -#ifndef MA_MAX_DEVICE_NAME_LENGTH -#define MA_MAX_DEVICE_NAME_LENGTH 255 -#endif - -typedef struct -{ - /* Basic info. This is the only information guaranteed to be filled in during device enumeration. */ - ma_device_id id; - char name[MA_MAX_DEVICE_NAME_LENGTH + 1]; /* +1 for null terminator. */ - ma_bool32 isDefault; - - ma_uint32 nativeDataFormatCount; - struct - { - ma_format format; /* Sample format. If set to ma_format_unknown, all sample formats are supported. */ - ma_uint32 channels; /* If set to 0, all channels are supported. */ - ma_uint32 sampleRate; /* If set to 0, all sample rates are supported. */ - ma_uint32 flags; /* A combination of MA_DATA_FORMAT_FLAG_* flags. */ - } nativeDataFormats[/*ma_format_count * ma_standard_sample_rate_count * MA_MAX_CHANNELS*/ 64]; /* Not sure how big to make this. There can be *many* permutations for virtual devices which can support anything. */ -} ma_device_info; - -struct ma_device_config -{ - ma_device_type deviceType; - ma_uint32 sampleRate; - ma_uint32 periodSizeInFrames; - ma_uint32 periodSizeInMilliseconds; - ma_uint32 periods; - ma_performance_profile performanceProfile; - ma_bool8 noPreSilencedOutputBuffer; /* When set to true, the contents of the output buffer passed into the data callback will be left undefined rather than initialized to silence. */ - ma_bool8 noClip; /* When set to true, the contents of the output buffer passed into the data callback will be clipped after returning. Only applies when the playback sample format is f32. */ - ma_bool8 noDisableDenormals; /* Do not disable denormals when firing the data callback. */ - ma_bool8 noFixedSizedCallback; /* Disables strict fixed-sized data callbacks. Setting this to true will result in the period size being treated only as a hint to the backend. This is an optimization for those who don't need fixed sized callbacks. */ - ma_device_data_proc dataCallback; - ma_device_notification_proc notificationCallback; - ma_stop_proc stopCallback; - void* pUserData; - ma_resampler_config resampling; - struct - { - const ma_device_id* pDeviceID; - ma_format format; - ma_uint32 channels; - ma_channel* pChannelMap; - ma_channel_mix_mode channelMixMode; - ma_bool32 calculateLFEFromSpatialChannels; /* When an output LFE channel is present, but no input LFE, set to true to set the output LFE to the average of all spatial channels (LR, FR, etc.). Ignored when an input LFE is present. */ - ma_share_mode shareMode; - } playback; - struct - { - const ma_device_id* pDeviceID; - ma_format format; - ma_uint32 channels; - ma_channel* pChannelMap; - ma_channel_mix_mode channelMixMode; - ma_bool32 calculateLFEFromSpatialChannels; /* When an output LFE channel is present, but no input LFE, set to true to set the output LFE to the average of all spatial channels (LR, FR, etc.). Ignored when an input LFE is present. */ - ma_share_mode shareMode; - } capture; - - struct - { - ma_wasapi_usage usage; /* When configured, uses Avrt APIs to set the thread characteristics. */ - ma_bool8 noAutoConvertSRC; /* When set to true, disables the use of AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM. */ - ma_bool8 noDefaultQualitySRC; /* When set to true, disables the use of AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY. */ - ma_bool8 noAutoStreamRouting; /* Disables automatic stream routing. */ - ma_bool8 noHardwareOffloading; /* Disables WASAPI's hardware offloading feature. */ - ma_uint32 loopbackProcessID; /* The process ID to include or exclude for loopback mode. Set to 0 to capture audio from all processes. Ignored when an explicit device ID is specified. */ - ma_bool8 loopbackProcessExclude; /* When set to true, excludes the process specified by loopbackProcessID. By default, the process will be included. */ - } wasapi; - struct - { - ma_bool32 noMMap; /* Disables MMap mode. */ - ma_bool32 noAutoFormat; /* Opens the ALSA device with SND_PCM_NO_AUTO_FORMAT. */ - ma_bool32 noAutoChannels; /* Opens the ALSA device with SND_PCM_NO_AUTO_CHANNELS. */ - ma_bool32 noAutoResample; /* Opens the ALSA device with SND_PCM_NO_AUTO_RESAMPLE. */ - } alsa; - struct - { - const char* pStreamNamePlayback; - const char* pStreamNameCapture; - } pulse; - struct - { - ma_bool32 allowNominalSampleRateChange; /* Desktop only. When enabled, allows changing of the sample rate at the operating system level. */ - } coreaudio; - struct - { - ma_opensl_stream_type streamType; - ma_opensl_recording_preset recordingPreset; - ma_bool32 enableCompatibilityWorkarounds; - } opensl; - struct - { - ma_aaudio_usage usage; - ma_aaudio_content_type contentType; - ma_aaudio_input_preset inputPreset; - ma_aaudio_allowed_capture_policy allowedCapturePolicy; - ma_bool32 noAutoStartAfterReroute; - ma_bool32 enableCompatibilityWorkarounds; - } aaudio; -}; - - -/* -The callback for handling device enumeration. This is fired from `ma_context_enumerated_devices()`. - - -Parameters ----------- -pContext (in) - A pointer to the context performing the enumeration. - -deviceType (in) - The type of the device being enumerated. This will always be either `ma_device_type_playback` or `ma_device_type_capture`. - -pInfo (in) - A pointer to a `ma_device_info` containing the ID and name of the enumerated device. Note that this will not include detailed information about the device, - only basic information (ID and name). The reason for this is that it would otherwise require opening the backend device to probe for the information which - is too inefficient. - -pUserData (in) - The user data pointer passed into `ma_context_enumerate_devices()`. -*/ -typedef ma_bool32 (* ma_enum_devices_callback_proc)(ma_context* pContext, ma_device_type deviceType, const ma_device_info* pInfo, void* pUserData); - - -/* -Describes some basic details about a playback or capture device. -*/ -typedef struct -{ - const ma_device_id* pDeviceID; - ma_share_mode shareMode; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_channel channelMap[MA_MAX_CHANNELS]; - ma_uint32 periodSizeInFrames; - ma_uint32 periodSizeInMilliseconds; - ma_uint32 periodCount; -} ma_device_descriptor; - -/* -These are the callbacks required to be implemented for a backend. These callbacks are grouped into two parts: context and device. There is one context -to many devices. A device is created from a context. - -The general flow goes like this: - - 1) A context is created with `onContextInit()` - 1a) Available devices can be enumerated with `onContextEnumerateDevices()` if required. - 1b) Detailed information about a device can be queried with `onContextGetDeviceInfo()` if required. - 2) A device is created from the context that was created in the first step using `onDeviceInit()`, and optionally a device ID that was - selected from device enumeration via `onContextEnumerateDevices()`. - 3) A device is started or stopped with `onDeviceStart()` / `onDeviceStop()` - 4) Data is delivered to and from the device by the backend. This is always done based on the native format returned by the prior call - to `onDeviceInit()`. Conversion between the device's native format and the format requested by the application will be handled by - miniaudio internally. - -Initialization of the context is quite simple. You need to do any necessary initialization of internal objects and then output the -callbacks defined in this structure. - -Once the context has been initialized you can initialize a device. Before doing so, however, the application may want to know which -physical devices are available. This is where `onContextEnumerateDevices()` comes in. This is fairly simple. For each device, fire the -given callback with, at a minimum, the basic information filled out in `ma_device_info`. When the callback returns `MA_FALSE`, enumeration -needs to stop and the `onContextEnumerateDevices()` function returns with a success code. - -Detailed device information can be retrieved from a device ID using `onContextGetDeviceInfo()`. This takes as input the device type and ID, -and on output returns detailed information about the device in `ma_device_info`. The `onContextGetDeviceInfo()` callback must handle the -case when the device ID is NULL, in which case information about the default device needs to be retrieved. - -Once the context has been created and the device ID retrieved (if using anything other than the default device), the device can be created. -This is a little bit more complicated than initialization of the context due to it's more complicated configuration. When initializing a -device, a duplex device may be requested. This means a separate data format needs to be specified for both playback and capture. On input, -the data format is set to what the application wants. On output it's set to the native format which should match as closely as possible to -the requested format. The conversion between the format requested by the application and the device's native format will be handled -internally by miniaudio. - -On input, if the sample format is set to `ma_format_unknown`, the backend is free to use whatever sample format it desires, so long as it's -supported by miniaudio. When the channel count is set to 0, the backend should use the device's native channel count. The same applies for -sample rate. For the channel map, the default should be used when `ma_channel_map_is_blank()` returns true (all channels set to -`MA_CHANNEL_NONE`). On input, the `periodSizeInFrames` or `periodSizeInMilliseconds` option should always be set. The backend should -inspect both of these variables. If `periodSizeInFrames` is set, it should take priority, otherwise it needs to be derived from the period -size in milliseconds (`periodSizeInMilliseconds`) and the sample rate, keeping in mind that the sample rate may be 0, in which case the -sample rate will need to be determined before calculating the period size in frames. On output, all members of the `ma_device_descriptor` -object should be set to a valid value, except for `periodSizeInMilliseconds` which is optional (`periodSizeInFrames` *must* be set). - -Starting and stopping of the device is done with `onDeviceStart()` and `onDeviceStop()` and should be self-explanatory. If the backend uses -asynchronous reading and writing, `onDeviceStart()` and `onDeviceStop()` should always be implemented. - -The handling of data delivery between the application and the device is the most complicated part of the process. To make this a bit -easier, some helper callbacks are available. If the backend uses a blocking read/write style of API, the `onDeviceRead()` and -`onDeviceWrite()` callbacks can optionally be implemented. These are blocking and work just like reading and writing from a file. If the -backend uses a callback for data delivery, that callback must call `ma_device_handle_backend_data_callback()` from within it's callback. -This allows miniaudio to then process any necessary data conversion and then pass it to the miniaudio data callback. - -If the backend requires absolute flexibility with it's data delivery, it can optionally implement the `onDeviceDataLoop()` callback -which will allow it to implement the logic that will run on the audio thread. This is much more advanced and is completely optional. - -The audio thread should run data delivery logic in a loop while `ma_device_get_state() == ma_device_state_started` and no errors have been -encountered. Do not start or stop the device here. That will be handled from outside the `onDeviceDataLoop()` callback. - -The invocation of the `onDeviceDataLoop()` callback will be handled by miniaudio. When you start the device, miniaudio will fire this -callback. When the device is stopped, the `ma_device_get_state() == ma_device_state_started` condition will fail and the loop will be terminated -which will then fall through to the part that stops the device. For an example on how to implement the `onDeviceDataLoop()` callback, -look at `ma_device_audio_thread__default_read_write()`. Implement the `onDeviceDataLoopWakeup()` callback if you need a mechanism to -wake up the audio thread. - -If the backend supports an optimized retrieval of device information from an initialized `ma_device` object, it should implement the -`onDeviceGetInfo()` callback. This is optional, in which case it will fall back to `onContextGetDeviceInfo()` which is less efficient. -*/ -struct ma_backend_callbacks -{ - ma_result (* onContextInit)(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks); - ma_result (* onContextUninit)(ma_context* pContext); - ma_result (* onContextEnumerateDevices)(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData); - ma_result (* onContextGetDeviceInfo)(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo); - ma_result (* onDeviceInit)(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture); - ma_result (* onDeviceUninit)(ma_device* pDevice); - ma_result (* onDeviceStart)(ma_device* pDevice); - ma_result (* onDeviceStop)(ma_device* pDevice); - ma_result (* onDeviceRead)(ma_device* pDevice, void* pFrames, ma_uint32 frameCount, ma_uint32* pFramesRead); - ma_result (* onDeviceWrite)(ma_device* pDevice, const void* pFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten); - ma_result (* onDeviceDataLoop)(ma_device* pDevice); - ma_result (* onDeviceDataLoopWakeup)(ma_device* pDevice); - ma_result (* onDeviceGetInfo)(ma_device* pDevice, ma_device_type type, ma_device_info* pDeviceInfo); -}; - -struct ma_context_config -{ - ma_log* pLog; - ma_thread_priority threadPriority; - size_t threadStackSize; - void* pUserData; - ma_allocation_callbacks allocationCallbacks; - struct - { - ma_bool32 useVerboseDeviceEnumeration; - } alsa; - struct - { - const char* pApplicationName; - const char* pServerName; - ma_bool32 tryAutoSpawn; /* Enables autospawning of the PulseAudio daemon if necessary. */ - } pulse; - struct - { - ma_ios_session_category sessionCategory; - ma_uint32 sessionCategoryOptions; - ma_bool32 noAudioSessionActivate; /* iOS only. When set to true, does not perform an explicit [[AVAudioSession sharedInstace] setActive:true] on initialization. */ - ma_bool32 noAudioSessionDeactivate; /* iOS only. When set to true, does not perform an explicit [[AVAudioSession sharedInstace] setActive:false] on uninitialization. */ - } coreaudio; - struct - { - const char* pClientName; - ma_bool32 tryStartServer; - } jack; - ma_backend_callbacks custom; -}; - -/* WASAPI specific structure for some commands which must run on a common thread due to bugs in WASAPI. */ -typedef struct -{ - int code; - ma_event* pEvent; /* This will be signalled when the event is complete. */ - union - { - struct - { - int _unused; - } quit; - struct - { - ma_device_type deviceType; - void* pAudioClient; - void** ppAudioClientService; - ma_result* pResult; /* The result from creating the audio client service. */ - } createAudioClient; - struct - { - ma_device* pDevice; - ma_device_type deviceType; - } releaseAudioClient; - } data; -} ma_context_command__wasapi; - -struct ma_context -{ - ma_backend_callbacks callbacks; - ma_backend backend; /* DirectSound, ALSA, etc. */ - ma_log* pLog; - ma_log log; /* Only used if the log is owned by the context. The pLog member will be set to &log in this case. */ - ma_thread_priority threadPriority; - size_t threadStackSize; - void* pUserData; - ma_allocation_callbacks allocationCallbacks; - ma_mutex deviceEnumLock; /* Used to make ma_context_get_devices() thread safe. */ - ma_mutex deviceInfoLock; /* Used to make ma_context_get_device_info() thread safe. */ - ma_uint32 deviceInfoCapacity; /* Total capacity of pDeviceInfos. */ - ma_uint32 playbackDeviceInfoCount; - ma_uint32 captureDeviceInfoCount; - ma_device_info* pDeviceInfos; /* Playback devices first, then capture. */ - - union - { -#ifdef MA_SUPPORT_WASAPI - struct - { - ma_thread commandThread; - ma_mutex commandLock; - ma_semaphore commandSem; - ma_uint32 commandIndex; - ma_uint32 commandCount; - ma_context_command__wasapi commands[4]; - ma_handle hAvrt; - ma_proc AvSetMmThreadCharacteristicsA; - ma_proc AvRevertMmThreadcharacteristics; - ma_handle hMMDevapi; - ma_proc ActivateAudioInterfaceAsync; - } wasapi; -#endif -#ifdef MA_SUPPORT_DSOUND - struct - { - ma_handle hDSoundDLL; - ma_proc DirectSoundCreate; - ma_proc DirectSoundEnumerateA; - ma_proc DirectSoundCaptureCreate; - ma_proc DirectSoundCaptureEnumerateA; - } dsound; -#endif -#ifdef MA_SUPPORT_WINMM - struct - { - ma_handle hWinMM; - ma_proc waveOutGetNumDevs; - ma_proc waveOutGetDevCapsA; - ma_proc waveOutOpen; - ma_proc waveOutClose; - ma_proc waveOutPrepareHeader; - ma_proc waveOutUnprepareHeader; - ma_proc waveOutWrite; - ma_proc waveOutReset; - ma_proc waveInGetNumDevs; - ma_proc waveInGetDevCapsA; - ma_proc waveInOpen; - ma_proc waveInClose; - ma_proc waveInPrepareHeader; - ma_proc waveInUnprepareHeader; - ma_proc waveInAddBuffer; - ma_proc waveInStart; - ma_proc waveInReset; - } winmm; -#endif -#ifdef MA_SUPPORT_ALSA - struct - { - ma_handle asoundSO; - ma_proc snd_pcm_open; - ma_proc snd_pcm_close; - ma_proc snd_pcm_hw_params_sizeof; - ma_proc snd_pcm_hw_params_any; - ma_proc snd_pcm_hw_params_set_format; - ma_proc snd_pcm_hw_params_set_format_first; - ma_proc snd_pcm_hw_params_get_format_mask; - ma_proc snd_pcm_hw_params_set_channels; - ma_proc snd_pcm_hw_params_set_channels_near; - ma_proc snd_pcm_hw_params_set_channels_minmax; - ma_proc snd_pcm_hw_params_set_rate_resample; - ma_proc snd_pcm_hw_params_set_rate; - ma_proc snd_pcm_hw_params_set_rate_near; - ma_proc snd_pcm_hw_params_set_buffer_size_near; - ma_proc snd_pcm_hw_params_set_periods_near; - ma_proc snd_pcm_hw_params_set_access; - ma_proc snd_pcm_hw_params_get_format; - ma_proc snd_pcm_hw_params_get_channels; - ma_proc snd_pcm_hw_params_get_channels_min; - ma_proc snd_pcm_hw_params_get_channels_max; - ma_proc snd_pcm_hw_params_get_rate; - ma_proc snd_pcm_hw_params_get_rate_min; - ma_proc snd_pcm_hw_params_get_rate_max; - ma_proc snd_pcm_hw_params_get_buffer_size; - ma_proc snd_pcm_hw_params_get_periods; - ma_proc snd_pcm_hw_params_get_access; - ma_proc snd_pcm_hw_params_test_format; - ma_proc snd_pcm_hw_params_test_channels; - ma_proc snd_pcm_hw_params_test_rate; - ma_proc snd_pcm_hw_params; - ma_proc snd_pcm_sw_params_sizeof; - ma_proc snd_pcm_sw_params_current; - ma_proc snd_pcm_sw_params_get_boundary; - ma_proc snd_pcm_sw_params_set_avail_min; - ma_proc snd_pcm_sw_params_set_start_threshold; - ma_proc snd_pcm_sw_params_set_stop_threshold; - ma_proc snd_pcm_sw_params; - ma_proc snd_pcm_format_mask_sizeof; - ma_proc snd_pcm_format_mask_test; - ma_proc snd_pcm_get_chmap; - ma_proc snd_pcm_state; - ma_proc snd_pcm_prepare; - ma_proc snd_pcm_start; - ma_proc snd_pcm_drop; - ma_proc snd_pcm_drain; - ma_proc snd_pcm_reset; - ma_proc snd_device_name_hint; - ma_proc snd_device_name_get_hint; - ma_proc snd_card_get_index; - ma_proc snd_device_name_free_hint; - ma_proc snd_pcm_mmap_begin; - ma_proc snd_pcm_mmap_commit; - ma_proc snd_pcm_recover; - ma_proc snd_pcm_readi; - ma_proc snd_pcm_writei; - ma_proc snd_pcm_avail; - ma_proc snd_pcm_avail_update; - ma_proc snd_pcm_wait; - ma_proc snd_pcm_nonblock; - ma_proc snd_pcm_info; - ma_proc snd_pcm_info_sizeof; - ma_proc snd_pcm_info_get_name; - ma_proc snd_pcm_poll_descriptors; - ma_proc snd_pcm_poll_descriptors_count; - ma_proc snd_pcm_poll_descriptors_revents; - ma_proc snd_config_update_free_global; - - ma_mutex internalDeviceEnumLock; - ma_bool32 useVerboseDeviceEnumeration; - } alsa; -#endif -#ifdef MA_SUPPORT_PULSEAUDIO - struct - { - ma_handle pulseSO; - ma_proc pa_mainloop_new; - ma_proc pa_mainloop_free; - ma_proc pa_mainloop_quit; - ma_proc pa_mainloop_get_api; - ma_proc pa_mainloop_iterate; - ma_proc pa_mainloop_wakeup; - ma_proc pa_threaded_mainloop_new; - ma_proc pa_threaded_mainloop_free; - ma_proc pa_threaded_mainloop_start; - ma_proc pa_threaded_mainloop_stop; - ma_proc pa_threaded_mainloop_lock; - ma_proc pa_threaded_mainloop_unlock; - ma_proc pa_threaded_mainloop_wait; - ma_proc pa_threaded_mainloop_signal; - ma_proc pa_threaded_mainloop_accept; - ma_proc pa_threaded_mainloop_get_retval; - ma_proc pa_threaded_mainloop_get_api; - ma_proc pa_threaded_mainloop_in_thread; - ma_proc pa_threaded_mainloop_set_name; - ma_proc pa_context_new; - ma_proc pa_context_unref; - ma_proc pa_context_connect; - ma_proc pa_context_disconnect; - ma_proc pa_context_set_state_callback; - ma_proc pa_context_get_state; - ma_proc pa_context_get_sink_info_list; - ma_proc pa_context_get_source_info_list; - ma_proc pa_context_get_sink_info_by_name; - ma_proc pa_context_get_source_info_by_name; - ma_proc pa_operation_unref; - ma_proc pa_operation_get_state; - ma_proc pa_channel_map_init_extend; - ma_proc pa_channel_map_valid; - ma_proc pa_channel_map_compatible; - ma_proc pa_stream_new; - ma_proc pa_stream_unref; - ma_proc pa_stream_connect_playback; - ma_proc pa_stream_connect_record; - ma_proc pa_stream_disconnect; - ma_proc pa_stream_get_state; - ma_proc pa_stream_get_sample_spec; - ma_proc pa_stream_get_channel_map; - ma_proc pa_stream_get_buffer_attr; - ma_proc pa_stream_set_buffer_attr; - ma_proc pa_stream_get_device_name; - ma_proc pa_stream_set_write_callback; - ma_proc pa_stream_set_read_callback; - ma_proc pa_stream_set_suspended_callback; - ma_proc pa_stream_set_moved_callback; - ma_proc pa_stream_is_suspended; - ma_proc pa_stream_flush; - ma_proc pa_stream_drain; - ma_proc pa_stream_is_corked; - ma_proc pa_stream_cork; - ma_proc pa_stream_trigger; - ma_proc pa_stream_begin_write; - ma_proc pa_stream_write; - ma_proc pa_stream_peek; - ma_proc pa_stream_drop; - ma_proc pa_stream_writable_size; - ma_proc pa_stream_readable_size; - - /*pa_mainloop**/ ma_ptr pMainLoop; - /*pa_context**/ ma_ptr pPulseContext; - char* pApplicationName; /* Set when the context is initialized. Used by devices for their local pa_context objects. */ - char* pServerName; /* Set when the context is initialized. Used by devices for their local pa_context objects. */ - } pulse; -#endif -#ifdef MA_SUPPORT_JACK - struct - { - ma_handle jackSO; - ma_proc jack_client_open; - ma_proc jack_client_close; - ma_proc jack_client_name_size; - ma_proc jack_set_process_callback; - ma_proc jack_set_buffer_size_callback; - ma_proc jack_on_shutdown; - ma_proc jack_get_sample_rate; - ma_proc jack_get_buffer_size; - ma_proc jack_get_ports; - ma_proc jack_activate; - ma_proc jack_deactivate; - ma_proc jack_connect; - ma_proc jack_port_register; - ma_proc jack_port_name; - ma_proc jack_port_get_buffer; - ma_proc jack_free; - - char* pClientName; - ma_bool32 tryStartServer; - } jack; -#endif -#ifdef MA_SUPPORT_COREAUDIO - struct - { - ma_handle hCoreFoundation; - ma_proc CFStringGetCString; - ma_proc CFRelease; - - ma_handle hCoreAudio; - ma_proc AudioObjectGetPropertyData; - ma_proc AudioObjectGetPropertyDataSize; - ma_proc AudioObjectSetPropertyData; - ma_proc AudioObjectAddPropertyListener; - ma_proc AudioObjectRemovePropertyListener; - - ma_handle hAudioUnit; /* Could possibly be set to AudioToolbox on later versions of macOS. */ - ma_proc AudioComponentFindNext; - ma_proc AudioComponentInstanceDispose; - ma_proc AudioComponentInstanceNew; - ma_proc AudioOutputUnitStart; - ma_proc AudioOutputUnitStop; - ma_proc AudioUnitAddPropertyListener; - ma_proc AudioUnitGetPropertyInfo; - ma_proc AudioUnitGetProperty; - ma_proc AudioUnitSetProperty; - ma_proc AudioUnitInitialize; - ma_proc AudioUnitRender; - - /*AudioComponent*/ ma_ptr component; - ma_bool32 noAudioSessionDeactivate; /* For tracking whether or not the iOS audio session should be explicitly deactivated. Set from the config in ma_context_init__coreaudio(). */ - } coreaudio; -#endif -#ifdef MA_SUPPORT_SNDIO - struct - { - ma_handle sndioSO; - ma_proc sio_open; - ma_proc sio_close; - ma_proc sio_setpar; - ma_proc sio_getpar; - ma_proc sio_getcap; - ma_proc sio_start; - ma_proc sio_stop; - ma_proc sio_read; - ma_proc sio_write; - ma_proc sio_onmove; - ma_proc sio_nfds; - ma_proc sio_pollfd; - ma_proc sio_revents; - ma_proc sio_eof; - ma_proc sio_setvol; - ma_proc sio_onvol; - ma_proc sio_initpar; - } sndio; -#endif -#ifdef MA_SUPPORT_AUDIO4 - struct - { - int _unused; - } audio4; -#endif -#ifdef MA_SUPPORT_OSS - struct - { - int versionMajor; - int versionMinor; - } oss; -#endif -#ifdef MA_SUPPORT_AAUDIO - struct - { - ma_handle hAAudio; /* libaaudio.so */ - ma_proc AAudio_createStreamBuilder; - ma_proc AAudioStreamBuilder_delete; - ma_proc AAudioStreamBuilder_setDeviceId; - ma_proc AAudioStreamBuilder_setDirection; - ma_proc AAudioStreamBuilder_setSharingMode; - ma_proc AAudioStreamBuilder_setFormat; - ma_proc AAudioStreamBuilder_setChannelCount; - ma_proc AAudioStreamBuilder_setSampleRate; - ma_proc AAudioStreamBuilder_setBufferCapacityInFrames; - ma_proc AAudioStreamBuilder_setFramesPerDataCallback; - ma_proc AAudioStreamBuilder_setDataCallback; - ma_proc AAudioStreamBuilder_setErrorCallback; - ma_proc AAudioStreamBuilder_setPerformanceMode; - ma_proc AAudioStreamBuilder_setUsage; - ma_proc AAudioStreamBuilder_setContentType; - ma_proc AAudioStreamBuilder_setInputPreset; - ma_proc AAudioStreamBuilder_setAllowedCapturePolicy; - ma_proc AAudioStreamBuilder_openStream; - ma_proc AAudioStream_close; - ma_proc AAudioStream_getState; - ma_proc AAudioStream_waitForStateChange; - ma_proc AAudioStream_getFormat; - ma_proc AAudioStream_getChannelCount; - ma_proc AAudioStream_getSampleRate; - ma_proc AAudioStream_getBufferCapacityInFrames; - ma_proc AAudioStream_getFramesPerDataCallback; - ma_proc AAudioStream_getFramesPerBurst; - ma_proc AAudioStream_requestStart; - ma_proc AAudioStream_requestStop; - ma_device_job_thread jobThread; /* For processing operations outside of the error callback, specifically device disconnections and rerouting. */ - } aaudio; -#endif -#ifdef MA_SUPPORT_OPENSL - struct - { - ma_handle libOpenSLES; - ma_handle SL_IID_ENGINE; - ma_handle SL_IID_AUDIOIODEVICECAPABILITIES; - ma_handle SL_IID_ANDROIDSIMPLEBUFFERQUEUE; - ma_handle SL_IID_RECORD; - ma_handle SL_IID_PLAY; - ma_handle SL_IID_OUTPUTMIX; - ma_handle SL_IID_ANDROIDCONFIGURATION; - ma_proc slCreateEngine; - } opensl; -#endif -#ifdef MA_SUPPORT_WEBAUDIO - struct - { - int _unused; - } webaudio; -#endif -#ifdef MA_SUPPORT_NULL - struct - { - int _unused; - } null_backend; -#endif - }; - - union - { -#if defined(MA_WIN32) - struct - { - /*HMODULE*/ ma_handle hOle32DLL; - ma_proc CoInitialize; - ma_proc CoInitializeEx; - ma_proc CoUninitialize; - ma_proc CoCreateInstance; - ma_proc CoTaskMemFree; - ma_proc PropVariantClear; - ma_proc StringFromGUID2; - - /*HMODULE*/ ma_handle hUser32DLL; - ma_proc GetForegroundWindow; - ma_proc GetDesktopWindow; - - /*HMODULE*/ ma_handle hAdvapi32DLL; - ma_proc RegOpenKeyExA; - ma_proc RegCloseKey; - ma_proc RegQueryValueExA; - } win32; -#endif -#ifdef MA_POSIX - struct - { - int _unused; - } posix; -#endif - int _unused; - }; -}; - -struct ma_device -{ - ma_context* pContext; - ma_device_type type; - ma_uint32 sampleRate; - ma_atomic_device_state state; /* The state of the device is variable and can change at any time on any thread. Must be used atomically. */ - ma_device_data_proc onData; /* Set once at initialization time and should not be changed after. */ - ma_device_notification_proc onNotification; /* Set once at initialization time and should not be changed after. */ - ma_stop_proc onStop; /* DEPRECATED. Use the notification callback instead. Set once at initialization time and should not be changed after. */ - void* pUserData; /* Application defined data. */ - ma_mutex startStopLock; - ma_event wakeupEvent; - ma_event startEvent; - ma_event stopEvent; - ma_thread thread; - ma_result workResult; /* This is set by the worker thread after it's finished doing a job. */ - ma_bool8 isOwnerOfContext; /* When set to true, uninitializing the device will also uninitialize the context. Set to true when NULL is passed into ma_device_init(). */ - ma_bool8 noPreSilencedOutputBuffer; - ma_bool8 noClip; - ma_bool8 noDisableDenormals; - ma_bool8 noFixedSizedCallback; - ma_atomic_float masterVolumeFactor; /* Linear 0..1. Can be read and written simultaneously by different threads. Must be used atomically. */ - ma_duplex_rb duplexRB; /* Intermediary buffer for duplex device on asynchronous backends. */ - struct - { - ma_resample_algorithm algorithm; - ma_resampling_backend_vtable* pBackendVTable; - void* pBackendUserData; - struct - { - ma_uint32 lpfOrder; - } linear; - } resampling; - struct - { - ma_device_id* pID; /* Set to NULL if using default ID, otherwise set to the address of "id". */ - ma_device_id id; /* If using an explicit device, will be set to a copy of the ID used for initialization. Otherwise cleared to 0. */ - char name[MA_MAX_DEVICE_NAME_LENGTH + 1]; /* Maybe temporary. Likely to be replaced with a query API. */ - ma_share_mode shareMode; /* Set to whatever was passed in when the device was initialized. */ - ma_format format; - ma_uint32 channels; - ma_channel channelMap[MA_MAX_CHANNELS]; - ma_format internalFormat; - ma_uint32 internalChannels; - ma_uint32 internalSampleRate; - ma_channel internalChannelMap[MA_MAX_CHANNELS]; - ma_uint32 internalPeriodSizeInFrames; - ma_uint32 internalPeriods; - ma_channel_mix_mode channelMixMode; - ma_bool32 calculateLFEFromSpatialChannels; - ma_data_converter converter; - void* pIntermediaryBuffer; /* For implementing fixed sized buffer callbacks. Will be null if using variable sized callbacks. */ - ma_uint32 intermediaryBufferCap; - ma_uint32 intermediaryBufferLen; /* How many valid frames are sitting in the intermediary buffer. */ - void* pInputCache; /* In external format. Can be null. */ - ma_uint64 inputCacheCap; - ma_uint64 inputCacheConsumed; - ma_uint64 inputCacheRemaining; - } playback; - struct - { - ma_device_id* pID; /* Set to NULL if using default ID, otherwise set to the address of "id". */ - ma_device_id id; /* If using an explicit device, will be set to a copy of the ID used for initialization. Otherwise cleared to 0. */ - char name[MA_MAX_DEVICE_NAME_LENGTH + 1]; /* Maybe temporary. Likely to be replaced with a query API. */ - ma_share_mode shareMode; /* Set to whatever was passed in when the device was initialized. */ - ma_format format; - ma_uint32 channels; - ma_channel channelMap[MA_MAX_CHANNELS]; - ma_format internalFormat; - ma_uint32 internalChannels; - ma_uint32 internalSampleRate; - ma_channel internalChannelMap[MA_MAX_CHANNELS]; - ma_uint32 internalPeriodSizeInFrames; - ma_uint32 internalPeriods; - ma_channel_mix_mode channelMixMode; - ma_bool32 calculateLFEFromSpatialChannels; - ma_data_converter converter; - void* pIntermediaryBuffer; /* For implementing fixed sized buffer callbacks. Will be null if using variable sized callbacks. */ - ma_uint32 intermediaryBufferCap; - ma_uint32 intermediaryBufferLen; /* How many valid frames are sitting in the intermediary buffer. */ - } capture; - - union - { -#ifdef MA_SUPPORT_WASAPI - struct - { - /*IAudioClient**/ ma_ptr pAudioClientPlayback; - /*IAudioClient**/ ma_ptr pAudioClientCapture; - /*IAudioRenderClient**/ ma_ptr pRenderClient; - /*IAudioCaptureClient**/ ma_ptr pCaptureClient; - /*IMMDeviceEnumerator**/ ma_ptr pDeviceEnumerator; /* Used for IMMNotificationClient notifications. Required for detecting default device changes. */ - ma_IMMNotificationClient notificationClient; - /*HANDLE*/ ma_handle hEventPlayback; /* Auto reset. Initialized to signaled. */ - /*HANDLE*/ ma_handle hEventCapture; /* Auto reset. Initialized to unsignaled. */ - ma_uint32 actualBufferSizeInFramesPlayback; /* Value from GetBufferSize(). internalPeriodSizeInFrames is not set to the _actual_ buffer size when low-latency shared mode is being used due to the way the IAudioClient3 API works. */ - ma_uint32 actualBufferSizeInFramesCapture; - ma_uint32 originalPeriodSizeInFrames; - ma_uint32 originalPeriodSizeInMilliseconds; - ma_uint32 originalPeriods; - ma_performance_profile originalPerformanceProfile; - ma_uint32 periodSizeInFramesPlayback; - ma_uint32 periodSizeInFramesCapture; - void* pMappedBufferCapture; - ma_uint32 mappedBufferCaptureCap; - ma_uint32 mappedBufferCaptureLen; - void* pMappedBufferPlayback; - ma_uint32 mappedBufferPlaybackCap; - ma_uint32 mappedBufferPlaybackLen; - ma_atomic_bool32 isStartedCapture; /* Can be read and written simultaneously across different threads. Must be used atomically, and must be 32-bit. */ - ma_atomic_bool32 isStartedPlayback; /* Can be read and written simultaneously across different threads. Must be used atomically, and must be 32-bit. */ - ma_uint32 loopbackProcessID; - ma_bool8 loopbackProcessExclude; - ma_bool8 noAutoConvertSRC; /* When set to true, disables the use of AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM. */ - ma_bool8 noDefaultQualitySRC; /* When set to true, disables the use of AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY. */ - ma_bool8 noHardwareOffloading; - ma_bool8 allowCaptureAutoStreamRouting; - ma_bool8 allowPlaybackAutoStreamRouting; - ma_bool8 isDetachedPlayback; - ma_bool8 isDetachedCapture; - ma_wasapi_usage usage; - void* hAvrtHandle; - ma_mutex rerouteLock; - } wasapi; -#endif -#ifdef MA_SUPPORT_DSOUND - struct - { - /*LPDIRECTSOUND*/ ma_ptr pPlayback; - /*LPDIRECTSOUNDBUFFER*/ ma_ptr pPlaybackPrimaryBuffer; - /*LPDIRECTSOUNDBUFFER*/ ma_ptr pPlaybackBuffer; - /*LPDIRECTSOUNDCAPTURE*/ ma_ptr pCapture; - /*LPDIRECTSOUNDCAPTUREBUFFER*/ ma_ptr pCaptureBuffer; - } dsound; -#endif -#ifdef MA_SUPPORT_WINMM - struct - { - /*HWAVEOUT*/ ma_handle hDevicePlayback; - /*HWAVEIN*/ ma_handle hDeviceCapture; - /*HANDLE*/ ma_handle hEventPlayback; - /*HANDLE*/ ma_handle hEventCapture; - ma_uint32 fragmentSizeInFrames; - ma_uint32 iNextHeaderPlayback; /* [0,periods). Used as an index into pWAVEHDRPlayback. */ - ma_uint32 iNextHeaderCapture; /* [0,periods). Used as an index into pWAVEHDRCapture. */ - ma_uint32 headerFramesConsumedPlayback; /* The number of PCM frames consumed in the buffer in pWAVEHEADER[iNextHeader]. */ - ma_uint32 headerFramesConsumedCapture; /* ^^^ */ - /*WAVEHDR**/ ma_uint8* pWAVEHDRPlayback; /* One instantiation for each period. */ - /*WAVEHDR**/ ma_uint8* pWAVEHDRCapture; /* One instantiation for each period. */ - ma_uint8* pIntermediaryBufferPlayback; - ma_uint8* pIntermediaryBufferCapture; - ma_uint8* _pHeapData; /* Used internally and is used for the heap allocated data for the intermediary buffer and the WAVEHDR structures. */ - } winmm; -#endif -#ifdef MA_SUPPORT_ALSA - struct - { - /*snd_pcm_t**/ ma_ptr pPCMPlayback; - /*snd_pcm_t**/ ma_ptr pPCMCapture; - /*struct pollfd**/ void* pPollDescriptorsPlayback; - /*struct pollfd**/ void* pPollDescriptorsCapture; - int pollDescriptorCountPlayback; - int pollDescriptorCountCapture; - int wakeupfdPlayback; /* eventfd for waking up from poll() when the playback device is stopped. */ - int wakeupfdCapture; /* eventfd for waking up from poll() when the capture device is stopped. */ - ma_bool8 isUsingMMapPlayback; - ma_bool8 isUsingMMapCapture; - } alsa; -#endif -#ifdef MA_SUPPORT_PULSEAUDIO - struct - { - /*pa_mainloop**/ ma_ptr pMainLoop; - /*pa_context**/ ma_ptr pPulseContext; - /*pa_stream**/ ma_ptr pStreamPlayback; - /*pa_stream**/ ma_ptr pStreamCapture; - } pulse; -#endif -#ifdef MA_SUPPORT_JACK - struct - { - /*jack_client_t**/ ma_ptr pClient; - /*jack_port_t**/ ma_ptr* ppPortsPlayback; - /*jack_port_t**/ ma_ptr* ppPortsCapture; - float* pIntermediaryBufferPlayback; /* Typed as a float because JACK is always floating point. */ - float* pIntermediaryBufferCapture; - } jack; -#endif -#ifdef MA_SUPPORT_COREAUDIO - struct - { - ma_uint32 deviceObjectIDPlayback; - ma_uint32 deviceObjectIDCapture; - /*AudioUnit*/ ma_ptr audioUnitPlayback; - /*AudioUnit*/ ma_ptr audioUnitCapture; - /*AudioBufferList**/ ma_ptr pAudioBufferList; /* Only used for input devices. */ - ma_uint32 audioBufferCapInFrames; /* Only used for input devices. The capacity in frames of each buffer in pAudioBufferList. */ - ma_event stopEvent; - ma_uint32 originalPeriodSizeInFrames; - ma_uint32 originalPeriodSizeInMilliseconds; - ma_uint32 originalPeriods; - ma_performance_profile originalPerformanceProfile; - ma_bool32 isDefaultPlaybackDevice; - ma_bool32 isDefaultCaptureDevice; - ma_bool32 isSwitchingPlaybackDevice; /* <-- Set to true when the default device has changed and miniaudio is in the process of switching. */ - ma_bool32 isSwitchingCaptureDevice; /* <-- Set to true when the default device has changed and miniaudio is in the process of switching. */ - void* pNotificationHandler; /* Only used on mobile platforms. Obj-C object for handling route changes. */ - } coreaudio; -#endif -#ifdef MA_SUPPORT_SNDIO - struct - { - ma_ptr handlePlayback; - ma_ptr handleCapture; - ma_bool32 isStartedPlayback; - ma_bool32 isStartedCapture; - } sndio; -#endif -#ifdef MA_SUPPORT_AUDIO4 - struct - { - int fdPlayback; - int fdCapture; - } audio4; -#endif -#ifdef MA_SUPPORT_OSS - struct - { - int fdPlayback; - int fdCapture; - } oss; -#endif -#ifdef MA_SUPPORT_AAUDIO - struct - { - /*AAudioStream**/ ma_ptr pStreamPlayback; - /*AAudioStream**/ ma_ptr pStreamCapture; - ma_aaudio_usage usage; - ma_aaudio_content_type contentType; - ma_aaudio_input_preset inputPreset; - ma_aaudio_allowed_capture_policy allowedCapturePolicy; - ma_bool32 noAutoStartAfterReroute; - } aaudio; -#endif -#ifdef MA_SUPPORT_OPENSL - struct - { - /*SLObjectItf*/ ma_ptr pOutputMixObj; - /*SLOutputMixItf*/ ma_ptr pOutputMix; - /*SLObjectItf*/ ma_ptr pAudioPlayerObj; - /*SLPlayItf*/ ma_ptr pAudioPlayer; - /*SLObjectItf*/ ma_ptr pAudioRecorderObj; - /*SLRecordItf*/ ma_ptr pAudioRecorder; - /*SLAndroidSimpleBufferQueueItf*/ ma_ptr pBufferQueuePlayback; - /*SLAndroidSimpleBufferQueueItf*/ ma_ptr pBufferQueueCapture; - ma_bool32 isDrainingCapture; - ma_bool32 isDrainingPlayback; - ma_uint32 currentBufferIndexPlayback; - ma_uint32 currentBufferIndexCapture; - ma_uint8* pBufferPlayback; /* This is malloc()'d and is used for storing audio data. Typed as ma_uint8 for easy offsetting. */ - ma_uint8* pBufferCapture; - } opensl; -#endif -#ifdef MA_SUPPORT_WEBAUDIO - struct - { - /* AudioWorklets path. */ - /* EMSCRIPTEN_WEBAUDIO_T */ int audioContextPlayback; - /* EMSCRIPTEN_WEBAUDIO_T */ int audioContextCapture; - /* EMSCRIPTEN_AUDIO_WORKLET_NODE_T */ int workletNodePlayback; - /* EMSCRIPTEN_AUDIO_WORKLET_NODE_T */ int workletNodeCapture; - size_t intermediaryBufferSizeInFramesPlayback; - size_t intermediaryBufferSizeInFramesCapture; - float* pIntermediaryBufferPlayback; - float* pIntermediaryBufferCapture; - void* pStackBufferPlayback; - void* pStackBufferCapture; - ma_bool32 isInitialized; - - /* ScriptProcessorNode path. */ - int indexPlayback; /* We use a factory on the JavaScript side to manage devices and use an index for JS/C interop. */ - int indexCapture; - } webaudio; -#endif -#ifdef MA_SUPPORT_NULL - struct - { - ma_thread deviceThread; - ma_event operationEvent; - ma_event operationCompletionEvent; - ma_semaphore operationSemaphore; - ma_uint32 operation; - ma_result operationResult; - ma_timer timer; - double priorRunTime; - ma_uint32 currentPeriodFramesRemainingPlayback; - ma_uint32 currentPeriodFramesRemainingCapture; - ma_uint64 lastProcessedFramePlayback; - ma_uint64 lastProcessedFrameCapture; - ma_atomic_bool32 isStarted; /* Read and written by multiple threads. Must be used atomically, and must be 32-bit for compiler compatibility. */ - } null_device; -#endif - }; -}; -#if defined(_MSC_VER) && !defined(__clang__) - #pragma warning(pop) -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) - #pragma GCC diagnostic pop /* For ISO C99 doesn't support unnamed structs/unions [-Wpedantic] */ -#endif - -/* -Initializes a `ma_context_config` object. - - -Return Value ------------- -A `ma_context_config` initialized to defaults. - - -Remarks -------- -You must always use this to initialize the default state of the `ma_context_config` object. Not using this will result in your program breaking when miniaudio -is updated and new members are added to `ma_context_config`. It also sets logical defaults. - -You can override members of the returned object by changing it's members directly. - - -See Also --------- -ma_context_init() -*/ -MA_API ma_context_config ma_context_config_init(void); - -/* -Initializes a context. - -The context is used for selecting and initializing an appropriate backend and to represent the backend at a more global level than that of an individual -device. There is one context to many devices, and a device is created from a context. A context is required to enumerate devices. - - -Parameters ----------- -backends (in, optional) - A list of backends to try initializing, in priority order. Can be NULL, in which case it uses default priority order. - -backendCount (in, optional) - The number of items in `backend`. Ignored if `backend` is NULL. - -pConfig (in, optional) - The context configuration. - -pContext (in) - A pointer to the context object being initialized. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. Do not call this function across multiple threads as some backends read and write to global state. - - -Remarks -------- -When `backends` is NULL, the default priority order will be used. Below is a list of backends in priority order: - - |-------------|-----------------------|--------------------------------------------------------| - | Name | Enum Name | Supported Operating Systems | - |-------------|-----------------------|--------------------------------------------------------| - | WASAPI | ma_backend_wasapi | Windows Vista+ | - | DirectSound | ma_backend_dsound | Windows XP+ | - | WinMM | ma_backend_winmm | Windows XP+ (may work on older versions, but untested) | - | Core Audio | ma_backend_coreaudio | macOS, iOS | - | ALSA | ma_backend_alsa | Linux | - | PulseAudio | ma_backend_pulseaudio | Cross Platform (disabled on Windows, BSD and Android) | - | JACK | ma_backend_jack | Cross Platform (disabled on BSD and Android) | - | sndio | ma_backend_sndio | OpenBSD | - | audio(4) | ma_backend_audio4 | NetBSD, OpenBSD | - | OSS | ma_backend_oss | FreeBSD | - | AAudio | ma_backend_aaudio | Android 8+ | - | OpenSL|ES | ma_backend_opensl | Android (API level 16+) | - | Web Audio | ma_backend_webaudio | Web (via Emscripten) | - | Null | ma_backend_null | Cross Platform (not used on Web) | - |-------------|-----------------------|--------------------------------------------------------| - -The context can be configured via the `pConfig` argument. The config object is initialized with `ma_context_config_init()`. Individual configuration settings -can then be set directly on the structure. Below are the members of the `ma_context_config` object. - - pLog - A pointer to the `ma_log` to post log messages to. Can be NULL if the application does not - require logging. See the `ma_log` API for details on how to use the logging system. - - threadPriority - The desired priority to use for the audio thread. Allowable values include the following: - - |--------------------------------------| - | Thread Priority | - |--------------------------------------| - | ma_thread_priority_idle | - | ma_thread_priority_lowest | - | ma_thread_priority_low | - | ma_thread_priority_normal | - | ma_thread_priority_high | - | ma_thread_priority_highest (default) | - | ma_thread_priority_realtime | - | ma_thread_priority_default | - |--------------------------------------| - - threadStackSize - The desired size of the stack for the audio thread. Defaults to the operating system's default. - - pUserData - A pointer to application-defined data. This can be accessed from the context object directly such as `context.pUserData`. - - allocationCallbacks - Structure containing custom allocation callbacks. Leaving this at defaults will cause it to use MA_MALLOC, MA_REALLOC and MA_FREE. These allocation - callbacks will be used for anything tied to the context, including devices. - - alsa.useVerboseDeviceEnumeration - ALSA will typically enumerate many different devices which can be intrusive and not user-friendly. To combat this, miniaudio will enumerate only unique - card/device pairs by default. The problem with this is that you lose a bit of flexibility and control. Setting alsa.useVerboseDeviceEnumeration makes - it so the ALSA backend includes all devices. Defaults to false. - - pulse.pApplicationName - PulseAudio only. The application name to use when initializing the PulseAudio context with `pa_context_new()`. - - pulse.pServerName - PulseAudio only. The name of the server to connect to with `pa_context_connect()`. - - pulse.tryAutoSpawn - PulseAudio only. Whether or not to try automatically starting the PulseAudio daemon. Defaults to false. If you set this to true, keep in mind that - miniaudio uses a trial and error method to find the most appropriate backend, and this will result in the PulseAudio daemon starting which may be - intrusive for the end user. - - coreaudio.sessionCategory - iOS only. The session category to use for the shared AudioSession instance. Below is a list of allowable values and their Core Audio equivalents. - - |-----------------------------------------|-------------------------------------| - | miniaudio Token | Core Audio Token | - |-----------------------------------------|-------------------------------------| - | ma_ios_session_category_ambient | AVAudioSessionCategoryAmbient | - | ma_ios_session_category_solo_ambient | AVAudioSessionCategorySoloAmbient | - | ma_ios_session_category_playback | AVAudioSessionCategoryPlayback | - | ma_ios_session_category_record | AVAudioSessionCategoryRecord | - | ma_ios_session_category_play_and_record | AVAudioSessionCategoryPlayAndRecord | - | ma_ios_session_category_multi_route | AVAudioSessionCategoryMultiRoute | - | ma_ios_session_category_none | AVAudioSessionCategoryAmbient | - | ma_ios_session_category_default | AVAudioSessionCategoryAmbient | - |-----------------------------------------|-------------------------------------| - - coreaudio.sessionCategoryOptions - iOS only. Session category options to use with the shared AudioSession instance. Below is a list of allowable values and their Core Audio equivalents. - - |---------------------------------------------------------------------------|------------------------------------------------------------------| - | miniaudio Token | Core Audio Token | - |---------------------------------------------------------------------------|------------------------------------------------------------------| - | ma_ios_session_category_option_mix_with_others | AVAudioSessionCategoryOptionMixWithOthers | - | ma_ios_session_category_option_duck_others | AVAudioSessionCategoryOptionDuckOthers | - | ma_ios_session_category_option_allow_bluetooth | AVAudioSessionCategoryOptionAllowBluetooth | - | ma_ios_session_category_option_default_to_speaker | AVAudioSessionCategoryOptionDefaultToSpeaker | - | ma_ios_session_category_option_interrupt_spoken_audio_and_mix_with_others | AVAudioSessionCategoryOptionInterruptSpokenAudioAndMixWithOthers | - | ma_ios_session_category_option_allow_bluetooth_a2dp | AVAudioSessionCategoryOptionAllowBluetoothA2DP | - | ma_ios_session_category_option_allow_air_play | AVAudioSessionCategoryOptionAllowAirPlay | - |---------------------------------------------------------------------------|------------------------------------------------------------------| - - coreaudio.noAudioSessionActivate - iOS only. When set to true, does not perform an explicit [[AVAudioSession sharedInstace] setActive:true] on initialization. - - coreaudio.noAudioSessionDeactivate - iOS only. When set to true, does not perform an explicit [[AVAudioSession sharedInstace] setActive:false] on uninitialization. - - jack.pClientName - The name of the client to pass to `jack_client_open()`. - - jack.tryStartServer - Whether or not to try auto-starting the JACK server. Defaults to false. - - -It is recommended that only a single context is active at any given time because it's a bulky data structure which performs run-time linking for the -relevant backends every time it's initialized. - -The location of the context cannot change throughout it's lifetime. Consider allocating the `ma_context` object with `malloc()` if this is an issue. The -reason for this is that a pointer to the context is stored in the `ma_device` structure. - - -Example 1 - Default Initialization ----------------------------------- -The example below shows how to initialize the context using the default configuration. - -```c -ma_context context; -ma_result result = ma_context_init(NULL, 0, NULL, &context); -if (result != MA_SUCCESS) { - // Error. -} -``` - - -Example 2 - Custom Configuration --------------------------------- -The example below shows how to initialize the context using custom backend priorities and a custom configuration. In this hypothetical example, the program -wants to prioritize ALSA over PulseAudio on Linux. They also want to avoid using the WinMM backend on Windows because it's latency is too high. They also -want an error to be returned if no valid backend is available which they achieve by excluding the Null backend. - -For the configuration, the program wants to capture any log messages so they can, for example, route it to a log file and user interface. - -```c -ma_backend backends[] = { - ma_backend_alsa, - ma_backend_pulseaudio, - ma_backend_wasapi, - ma_backend_dsound -}; - -ma_log log; -ma_log_init(&log); -ma_log_register_callback(&log, ma_log_callback_init(my_log_callbac, pMyLogUserData)); - -ma_context_config config = ma_context_config_init(); -config.pLog = &log; // Specify a custom log object in the config so any logs that are posted from ma_context_init() are captured. - -ma_context context; -ma_result result = ma_context_init(backends, sizeof(backends)/sizeof(backends[0]), &config, &context); -if (result != MA_SUCCESS) { - // Error. - if (result == MA_NO_BACKEND) { - // Couldn't find an appropriate backend. - } -} - -// You could also attach a log callback post-initialization: -ma_log_register_callback(ma_context_get_log(&context), ma_log_callback_init(my_log_callback, pMyLogUserData)); -``` - - -See Also --------- -ma_context_config_init() -ma_context_uninit() -*/ -MA_API ma_result ma_context_init(const ma_backend backends[], ma_uint32 backendCount, const ma_context_config* pConfig, ma_context* pContext); - -/* -Uninitializes a context. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. Do not call this function across multiple threads as some backends read and write to global state. - - -Remarks -------- -Results are undefined if you call this while any device created by this context is still active. - - -See Also --------- -ma_context_init() -*/ -MA_API ma_result ma_context_uninit(ma_context* pContext); - -/* -Retrieves the size of the ma_context object. - -This is mainly for the purpose of bindings to know how much memory to allocate. -*/ -MA_API size_t ma_context_sizeof(void); - -/* -Retrieves a pointer to the log object associated with this context. - - -Remarks -------- -Pass the returned pointer to `ma_log_post()`, `ma_log_postv()` or `ma_log_postf()` to post a log -message. - -You can attach your own logging callback to the log with `ma_log_register_callback()` - - -Return Value ------------- -A pointer to the `ma_log` object that the context uses to post log messages. If some error occurs, -NULL will be returned. -*/ -MA_API ma_log* ma_context_get_log(ma_context* pContext); - -/* -Enumerates over every device (both playback and capture). - -This is a lower-level enumeration function to the easier to use `ma_context_get_devices()`. Use `ma_context_enumerate_devices()` if you would rather not incur -an internal heap allocation, or it simply suits your code better. - -Note that this only retrieves the ID and name/description of the device. The reason for only retrieving basic information is that it would otherwise require -opening the backend device in order to probe it for more detailed information which can be inefficient. Consider using `ma_context_get_device_info()` for this, -but don't call it from within the enumeration callback. - -Returning false from the callback will stop enumeration. Returning true will continue enumeration. - - -Parameters ----------- -pContext (in) - A pointer to the context performing the enumeration. - -callback (in) - The callback to fire for each enumerated device. - -pUserData (in) - A pointer to application-defined data passed to the callback. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Safe. This is guarded using a simple mutex lock. - - -Remarks -------- -Do _not_ assume the first enumerated device of a given type is the default device. - -Some backends and platforms may only support default playback and capture devices. - -In general, you should not do anything complicated from within the callback. In particular, do not try initializing a device from within the callback. Also, -do not try to call `ma_context_get_device_info()` from within the callback. - -Consider using `ma_context_get_devices()` for a simpler and safer API, albeit at the expense of an internal heap allocation. - - -Example 1 - Simple Enumeration ------------------------------- -ma_bool32 ma_device_enum_callback(ma_context* pContext, ma_device_type deviceType, const ma_device_info* pInfo, void* pUserData) -{ - printf("Device Name: %s\n", pInfo->name); - return MA_TRUE; -} - -ma_result result = ma_context_enumerate_devices(&context, my_device_enum_callback, pMyUserData); -if (result != MA_SUCCESS) { - // Error. -} - - -See Also --------- -ma_context_get_devices() -*/ -MA_API ma_result ma_context_enumerate_devices(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData); - -/* -Retrieves basic information about every active playback and/or capture device. - -This function will allocate memory internally for the device lists and return a pointer to them through the `ppPlaybackDeviceInfos` and `ppCaptureDeviceInfos` -parameters. If you do not want to incur the overhead of these allocations consider using `ma_context_enumerate_devices()` which will instead use a callback. - - -Parameters ----------- -pContext (in) - A pointer to the context performing the enumeration. - -ppPlaybackDeviceInfos (out) - A pointer to a pointer that will receive the address of a buffer containing the list of `ma_device_info` structures for playback devices. - -pPlaybackDeviceCount (out) - A pointer to an unsigned integer that will receive the number of playback devices. - -ppCaptureDeviceInfos (out) - A pointer to a pointer that will receive the address of a buffer containing the list of `ma_device_info` structures for capture devices. - -pCaptureDeviceCount (out) - A pointer to an unsigned integer that will receive the number of capture devices. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. Since each call to this function invalidates the pointers from the previous call, you should not be calling this simultaneously across multiple -threads. Instead, you need to make a copy of the returned data with your own higher level synchronization. - - -Remarks -------- -It is _not_ safe to assume the first device in the list is the default device. - -You can pass in NULL for the playback or capture lists in which case they'll be ignored. - -The returned pointers will become invalid upon the next call this this function, or when the context is uninitialized. Do not free the returned pointers. - - -See Also --------- -ma_context_get_devices() -*/ -MA_API ma_result ma_context_get_devices(ma_context* pContext, ma_device_info** ppPlaybackDeviceInfos, ma_uint32* pPlaybackDeviceCount, ma_device_info** ppCaptureDeviceInfos, ma_uint32* pCaptureDeviceCount); - -/* -Retrieves information about a device of the given type, with the specified ID and share mode. - - -Parameters ----------- -pContext (in) - A pointer to the context performing the query. - -deviceType (in) - The type of the device being queried. Must be either `ma_device_type_playback` or `ma_device_type_capture`. - -pDeviceID (in) - The ID of the device being queried. - -pDeviceInfo (out) - A pointer to the `ma_device_info` structure that will receive the device information. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Safe. This is guarded using a simple mutex lock. - - -Remarks -------- -Do _not_ call this from within the `ma_context_enumerate_devices()` callback. - -It's possible for a device to have different information and capabilities depending on whether or not it's opened in shared or exclusive mode. For example, in -shared mode, WASAPI always uses floating point samples for mixing, but in exclusive mode it can be anything. Therefore, this function allows you to specify -which share mode you want information for. Note that not all backends and devices support shared or exclusive mode, in which case this function will fail if -the requested share mode is unsupported. - -This leaves pDeviceInfo unmodified in the result of an error. -*/ -MA_API ma_result ma_context_get_device_info(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo); - -/* -Determines if the given context supports loopback mode. - - -Parameters ----------- -pContext (in) - A pointer to the context getting queried. - - -Return Value ------------- -MA_TRUE if the context supports loopback mode; MA_FALSE otherwise. -*/ -MA_API ma_bool32 ma_context_is_loopback_supported(ma_context* pContext); - - - -/* -Initializes a device config with default settings. - - -Parameters ----------- -deviceType (in) - The type of the device this config is being initialized for. This must set to one of the following: - - |-------------------------| - | Device Type | - |-------------------------| - | ma_device_type_playback | - | ma_device_type_capture | - | ma_device_type_duplex | - | ma_device_type_loopback | - |-------------------------| - - -Return Value ------------- -A new device config object with default settings. You will typically want to adjust the config after this function returns. See remarks. - - -Thread Safety -------------- -Safe. - - -Callback Safety ---------------- -Safe, but don't try initializing a device in a callback. - - -Remarks -------- -The returned config will be initialized to defaults. You will normally want to customize a few variables before initializing the device. See Example 1 for a -typical configuration which sets the sample format, channel count, sample rate, data callback and user data. These are usually things you will want to change -before initializing the device. - -See `ma_device_init()` for details on specific configuration options. - - -Example 1 - Simple Configuration --------------------------------- -The example below is what a program will typically want to configure for each device at a minimum. Notice how `ma_device_config_init()` is called first, and -then the returned object is modified directly. This is important because it ensures that your program continues to work as new configuration options are added -to the `ma_device_config` structure. - -```c -ma_device_config config = ma_device_config_init(ma_device_type_playback); -config.playback.format = ma_format_f32; -config.playback.channels = 2; -config.sampleRate = 48000; -config.dataCallback = ma_data_callback; -config.pUserData = pMyUserData; -``` - - -See Also --------- -ma_device_init() -ma_device_init_ex() -*/ -MA_API ma_device_config ma_device_config_init(ma_device_type deviceType); - - -/* -Initializes a device. - -A device represents a physical audio device. The idea is you send or receive audio data from the device to either play it back through a speaker, or capture it -from a microphone. Whether or not you should send or receive data from the device (or both) depends on the type of device you are initializing which can be -playback, capture, full-duplex or loopback. (Note that loopback mode is only supported on select backends.) Sending and receiving audio data to and from the -device is done via a callback which is fired by miniaudio at periodic time intervals. - -The frequency at which data is delivered to and from a device depends on the size of it's period. The size of the period can be defined in terms of PCM frames -or milliseconds, whichever is more convenient. Generally speaking, the smaller the period, the lower the latency at the expense of higher CPU usage and -increased risk of glitching due to the more frequent and granular data deliver intervals. The size of a period will depend on your requirements, but -miniaudio's defaults should work fine for most scenarios. If you're building a game you should leave this fairly small, whereas if you're building a simple -media player you can make it larger. Note that the period size you request is actually just a hint - miniaudio will tell the backend what you want, but the -backend is ultimately responsible for what it gives you. You cannot assume you will get exactly what you ask for. - -When delivering data to and from a device you need to make sure it's in the correct format which you can set through the device configuration. You just set the -format that you want to use and miniaudio will perform all of the necessary conversion for you internally. When delivering data to and from the callback you -can assume the format is the same as what you requested when you initialized the device. See Remarks for more details on miniaudio's data conversion pipeline. - - -Parameters ----------- -pContext (in, optional) - A pointer to the context that owns the device. This can be null, in which case it creates a default context internally. - -pConfig (in) - A pointer to the device configuration. Cannot be null. See remarks for details. - -pDevice (out) - A pointer to the device object being initialized. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. It is not safe to call this function simultaneously for different devices because some backends depend on and mutate global state. The same applies to -calling this at the same time as `ma_device_uninit()`. - - -Callback Safety ---------------- -Unsafe. It is not safe to call this inside any callback. - - -Remarks -------- -Setting `pContext` to NULL will result in miniaudio creating a default context internally and is equivalent to passing in a context initialized like so: - - ```c - ma_context_init(NULL, 0, NULL, &context); - ``` - -Do not set `pContext` to NULL if you are needing to open multiple devices. You can, however, use NULL when initializing the first device, and then use -device.pContext for the initialization of other devices. - -The device can be configured via the `pConfig` argument. The config object is initialized with `ma_device_config_init()`. Individual configuration settings can -then be set directly on the structure. Below are the members of the `ma_device_config` object. - - deviceType - Must be `ma_device_type_playback`, `ma_device_type_capture`, `ma_device_type_duplex` of `ma_device_type_loopback`. - - sampleRate - The sample rate, in hertz. The most common sample rates are 48000 and 44100. Setting this to 0 will use the device's native sample rate. - - periodSizeInFrames - The desired size of a period in PCM frames. If this is 0, `periodSizeInMilliseconds` will be used instead. If both are 0 the default buffer size will - be used depending on the selected performance profile. This value affects latency. See below for details. - - periodSizeInMilliseconds - The desired size of a period in milliseconds. If this is 0, `periodSizeInFrames` will be used instead. If both are 0 the default buffer size will be - used depending on the selected performance profile. The value affects latency. See below for details. - - periods - The number of periods making up the device's entire buffer. The total buffer size is `periodSizeInFrames` or `periodSizeInMilliseconds` multiplied by - this value. This is just a hint as backends will be the ones who ultimately decide how your periods will be configured. - - performanceProfile - A hint to miniaudio as to the performance requirements of your program. Can be either `ma_performance_profile_low_latency` (default) or - `ma_performance_profile_conservative`. This mainly affects the size of default buffers and can usually be left at it's default value. - - noPreSilencedOutputBuffer - When set to true, the contents of the output buffer passed into the data callback will be left undefined. When set to false (default), the contents of - the output buffer will be cleared the zero. You can use this to avoid the overhead of zeroing out the buffer if you can guarantee that your data - callback will write to every sample in the output buffer, or if you are doing your own clearing. - - noClip - When set to true, the contents of the output buffer passed into the data callback will be clipped after returning. When set to false (default), the - contents of the output buffer are left alone after returning and it will be left up to the backend itself to decide whether or not the clip. This only - applies when the playback sample format is f32. - - noDisableDenormals - By default, miniaudio will disable denormals when the data callback is called. Setting this to true will prevent the disabling of denormals. - - noFixedSizedCallback - Allows miniaudio to fire the data callback with any frame count. When this is set to false (the default), the data callback will be fired with a - consistent frame count as specified by `periodSizeInFrames` or `periodSizeInMilliseconds`. When set to true, miniaudio will fire the callback with - whatever the backend requests, which could be anything. - - dataCallback - The callback to fire whenever data is ready to be delivered to or from the device. - - notificationCallback - The callback to fire when something has changed with the device, such as whether or not it has been started or stopped. - - pUserData - The user data pointer to use with the device. You can access this directly from the device object like `device.pUserData`. - - resampling.algorithm - The resampling algorithm to use when miniaudio needs to perform resampling between the rate specified by `sampleRate` and the device's native rate. The - default value is `ma_resample_algorithm_linear`, and the quality can be configured with `resampling.linear.lpfOrder`. - - resampling.pBackendVTable - A pointer to an optional vtable that can be used for plugging in a custom resampler. - - resampling.pBackendUserData - A pointer that will passed to callbacks in pBackendVTable. - - resampling.linear.lpfOrder - The linear resampler applies a low-pass filter as part of it's processing for anti-aliasing. This setting controls the order of the filter. The higher - the value, the better the quality, in general. Setting this to 0 will disable low-pass filtering altogether. The maximum value is - `MA_MAX_FILTER_ORDER`. The default value is `min(4, MA_MAX_FILTER_ORDER)`. - - playback.pDeviceID - A pointer to a `ma_device_id` structure containing the ID of the playback device to initialize. Setting this NULL (default) will use the system's - default playback device. Retrieve the device ID from the `ma_device_info` structure, which can be retrieved using device enumeration. - - playback.format - The sample format to use for playback. When set to `ma_format_unknown` the device's native format will be used. This can be retrieved after - initialization from the device object directly with `device.playback.format`. - - playback.channels - The number of channels to use for playback. When set to 0 the device's native channel count will be used. This can be retrieved after initialization - from the device object directly with `device.playback.channels`. - - playback.pChannelMap - The channel map to use for playback. When left empty, the device's native channel map will be used. This can be retrieved after initialization from the - device object direct with `device.playback.pChannelMap`. When set, the buffer should contain `channels` items. - - playback.shareMode - The preferred share mode to use for playback. Can be either `ma_share_mode_shared` (default) or `ma_share_mode_exclusive`. Note that if you specify - exclusive mode, but it's not supported by the backend, initialization will fail. You can then fall back to shared mode if desired by changing this to - ma_share_mode_shared and reinitializing. - - capture.pDeviceID - A pointer to a `ma_device_id` structure containing the ID of the capture device to initialize. Setting this NULL (default) will use the system's - default capture device. Retrieve the device ID from the `ma_device_info` structure, which can be retrieved using device enumeration. - - capture.format - The sample format to use for capture. When set to `ma_format_unknown` the device's native format will be used. This can be retrieved after - initialization from the device object directly with `device.capture.format`. - - capture.channels - The number of channels to use for capture. When set to 0 the device's native channel count will be used. This can be retrieved after initialization - from the device object directly with `device.capture.channels`. - - capture.pChannelMap - The channel map to use for capture. When left empty, the device's native channel map will be used. This can be retrieved after initialization from the - device object direct with `device.capture.pChannelMap`. When set, the buffer should contain `channels` items. - - capture.shareMode - The preferred share mode to use for capture. Can be either `ma_share_mode_shared` (default) or `ma_share_mode_exclusive`. Note that if you specify - exclusive mode, but it's not supported by the backend, initialization will fail. You can then fall back to shared mode if desired by changing this to - ma_share_mode_shared and reinitializing. - - wasapi.noAutoConvertSRC - WASAPI only. When set to true, disables WASAPI's automatic resampling and forces the use of miniaudio's resampler. Defaults to false. - - wasapi.noDefaultQualitySRC - WASAPI only. Only used when `wasapi.noAutoConvertSRC` is set to false. When set to true, disables the use of `AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY`. - You should usually leave this set to false, which is the default. - - wasapi.noAutoStreamRouting - WASAPI only. When set to true, disables automatic stream routing on the WASAPI backend. Defaults to false. - - wasapi.noHardwareOffloading - WASAPI only. When set to true, disables the use of WASAPI's hardware offloading feature. Defaults to false. - - alsa.noMMap - ALSA only. When set to true, disables MMap mode. Defaults to false. - - alsa.noAutoFormat - ALSA only. When set to true, disables ALSA's automatic format conversion by including the SND_PCM_NO_AUTO_FORMAT flag. Defaults to false. - - alsa.noAutoChannels - ALSA only. When set to true, disables ALSA's automatic channel conversion by including the SND_PCM_NO_AUTO_CHANNELS flag. Defaults to false. - - alsa.noAutoResample - ALSA only. When set to true, disables ALSA's automatic resampling by including the SND_PCM_NO_AUTO_RESAMPLE flag. Defaults to false. - - pulse.pStreamNamePlayback - PulseAudio only. Sets the stream name for playback. - - pulse.pStreamNameCapture - PulseAudio only. Sets the stream name for capture. - - coreaudio.allowNominalSampleRateChange - Core Audio only. Desktop only. When enabled, allows the sample rate of the device to be changed at the operating system level. This - is disabled by default in order to prevent intrusive changes to the user's system. This is useful if you want to use a sample rate - that is known to be natively supported by the hardware thereby avoiding the cost of resampling. When set to true, miniaudio will - find the closest match between the sample rate requested in the device config and the sample rates natively supported by the - hardware. When set to false, the sample rate currently set by the operating system will always be used. - - opensl.streamType - OpenSL only. Explicitly sets the stream type. If left unset (`ma_opensl_stream_type_default`), the - stream type will be left unset. Think of this as the type of audio you're playing. - - opensl.recordingPreset - OpenSL only. Explicitly sets the type of recording your program will be doing. When left - unset, the recording preset will be left unchanged. - - aaudio.usage - AAudio only. Explicitly sets the nature of the audio the program will be consuming. When - left unset, the usage will be left unchanged. - - aaudio.contentType - AAudio only. Sets the content type. When left unset, the content type will be left unchanged. - - aaudio.inputPreset - AAudio only. Explicitly sets the type of recording your program will be doing. When left - unset, the input preset will be left unchanged. - - aaudio.noAutoStartAfterReroute - AAudio only. Controls whether or not the device should be automatically restarted after a - stream reroute. When set to false (default) the device will be restarted automatically; - otherwise the device will be stopped. - - -Once initialized, the device's config is immutable. If you need to change the config you will need to initialize a new device. - -After initializing the device it will be in a stopped state. To start it, use `ma_device_start()`. - -If both `periodSizeInFrames` and `periodSizeInMilliseconds` are set to zero, it will default to `MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_LOW_LATENCY` or -`MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE`, depending on whether or not `performanceProfile` is set to `ma_performance_profile_low_latency` or -`ma_performance_profile_conservative`. - -If you request exclusive mode and the backend does not support it an error will be returned. For robustness, you may want to first try initializing the device -in exclusive mode, and then fall back to shared mode if required. Alternatively you can just request shared mode (the default if you leave it unset in the -config) which is the most reliable option. Some backends do not have a practical way of choosing whether or not the device should be exclusive or not (ALSA, -for example) in which case it just acts as a hint. Unless you have special requirements you should try avoiding exclusive mode as it's intrusive to the user. -Starting with Windows 10, miniaudio will use low-latency shared mode where possible which may make exclusive mode unnecessary. - -When sending or receiving data to/from a device, miniaudio will internally perform a format conversion to convert between the format specified by the config -and the format used internally by the backend. If you pass in 0 for the sample format, channel count, sample rate _and_ channel map, data transmission will run -on an optimized pass-through fast path. You can retrieve the format, channel count and sample rate by inspecting the `playback/capture.format`, -`playback/capture.channels` and `sampleRate` members of the device object. - -When compiling for UWP you must ensure you call this function on the main UI thread because the operating system may need to present the user with a message -asking for permissions. Please refer to the official documentation for ActivateAudioInterfaceAsync() for more information. - -ALSA Specific: When initializing the default device, requesting shared mode will try using the "dmix" device for playback and the "dsnoop" device for capture. -If these fail it will try falling back to the "hw" device. - - -Example 1 - Simple Initialization ---------------------------------- -This example shows how to initialize a simple playback device using a standard configuration. If you are just needing to do simple playback from the default -playback device this is usually all you need. - -```c -ma_device_config config = ma_device_config_init(ma_device_type_playback); -config.playback.format = ma_format_f32; -config.playback.channels = 2; -config.sampleRate = 48000; -config.dataCallback = ma_data_callback; -config.pMyUserData = pMyUserData; - -ma_device device; -ma_result result = ma_device_init(NULL, &config, &device); -if (result != MA_SUCCESS) { - // Error -} -``` - - -Example 2 - Advanced Initialization ------------------------------------ -This example shows how you might do some more advanced initialization. In this hypothetical example we want to control the latency by setting the buffer size -and period count. We also want to allow the user to be able to choose which device to output from which means we need a context so we can perform device -enumeration. - -```c -ma_context context; -ma_result result = ma_context_init(NULL, 0, NULL, &context); -if (result != MA_SUCCESS) { - // Error -} - -ma_device_info* pPlaybackDeviceInfos; -ma_uint32 playbackDeviceCount; -result = ma_context_get_devices(&context, &pPlaybackDeviceInfos, &playbackDeviceCount, NULL, NULL); -if (result != MA_SUCCESS) { - // Error -} - -// ... choose a device from pPlaybackDeviceInfos ... - -ma_device_config config = ma_device_config_init(ma_device_type_playback); -config.playback.pDeviceID = pMyChosenDeviceID; // <-- Get this from the `id` member of one of the `ma_device_info` objects returned by ma_context_get_devices(). -config.playback.format = ma_format_f32; -config.playback.channels = 2; -config.sampleRate = 48000; -config.dataCallback = ma_data_callback; -config.pUserData = pMyUserData; -config.periodSizeInMilliseconds = 10; -config.periods = 3; - -ma_device device; -result = ma_device_init(&context, &config, &device); -if (result != MA_SUCCESS) { - // Error -} -``` - - -See Also --------- -ma_device_config_init() -ma_device_uninit() -ma_device_start() -ma_context_init() -ma_context_get_devices() -ma_context_enumerate_devices() -*/ -MA_API ma_result ma_device_init(ma_context* pContext, const ma_device_config* pConfig, ma_device* pDevice); - -/* -Initializes a device without a context, with extra parameters for controlling the configuration of the internal self-managed context. - -This is the same as `ma_device_init()`, only instead of a context being passed in, the parameters from `ma_context_init()` are passed in instead. This function -allows you to configure the internally created context. - - -Parameters ----------- -backends (in, optional) - A list of backends to try initializing, in priority order. Can be NULL, in which case it uses default priority order. - -backendCount (in, optional) - The number of items in `backend`. Ignored if `backend` is NULL. - -pContextConfig (in, optional) - The context configuration. - -pConfig (in) - A pointer to the device configuration. Cannot be null. See remarks for details. - -pDevice (out) - A pointer to the device object being initialized. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. It is not safe to call this function simultaneously for different devices because some backends depend on and mutate global state. The same applies to -calling this at the same time as `ma_device_uninit()`. - - -Callback Safety ---------------- -Unsafe. It is not safe to call this inside any callback. - - -Remarks -------- -You only need to use this function if you want to configure the context differently to it's defaults. You should never use this function if you want to manage -your own context. - -See the documentation for `ma_context_init()` for information on the different context configuration options. - - -See Also --------- -ma_device_init() -ma_device_uninit() -ma_device_config_init() -ma_context_init() -*/ -MA_API ma_result ma_device_init_ex(const ma_backend backends[], ma_uint32 backendCount, const ma_context_config* pContextConfig, const ma_device_config* pConfig, ma_device* pDevice); - -/* -Uninitializes a device. - -This will explicitly stop the device. You do not need to call `ma_device_stop()` beforehand, but it's harmless if you do. - - -Parameters ----------- -pDevice (in) - A pointer to the device to stop. - - -Return Value ------------- -Nothing - - -Thread Safety -------------- -Unsafe. As soon as this API is called the device should be considered undefined. - - -Callback Safety ---------------- -Unsafe. It is not safe to call this inside any callback. Doing this will result in a deadlock. - - -See Also --------- -ma_device_init() -ma_device_stop() -*/ -MA_API void ma_device_uninit(ma_device* pDevice); - - -/* -Retrieves a pointer to the context that owns the given device. -*/ -MA_API ma_context* ma_device_get_context(ma_device* pDevice); - -/* -Helper function for retrieving the log object associated with the context that owns this device. -*/ -MA_API ma_log* ma_device_get_log(ma_device* pDevice); - - -/* -Retrieves information about the device. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose information is being retrieved. - -type (in) - The device type. This parameter is required for duplex devices. When retrieving device - information, you are doing so for an individual playback or capture device. - -pDeviceInfo (out) - A pointer to the `ma_device_info` that will receive the device information. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. This should be considered unsafe because it may be calling into the backend which may or -may not be safe. - - -Callback Safety ---------------- -Unsafe. You should avoid calling this in the data callback because it may call into the backend -which may or may not be safe. -*/ -MA_API ma_result ma_device_get_info(ma_device* pDevice, ma_device_type type, ma_device_info* pDeviceInfo); - - -/* -Retrieves the name of the device. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose information is being retrieved. - -type (in) - The device type. This parameter is required for duplex devices. When retrieving device - information, you are doing so for an individual playback or capture device. - -pName (out) - A pointer to the buffer that will receive the name. - -nameCap (in) - The capacity of the output buffer, including space for the null terminator. - -pLengthNotIncludingNullTerminator (out, optional) - A pointer to the variable that will receive the length of the name, not including the null - terminator. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Unsafe. This should be considered unsafe because it may be calling into the backend which may or -may not be safe. - - -Callback Safety ---------------- -Unsafe. You should avoid calling this in the data callback because it may call into the backend -which may or may not be safe. - - -Remarks -------- -If the name does not fully fit into the output buffer, it'll be truncated. You can pass in NULL to -`pName` if you want to first get the length of the name for the purpose of memory allocation of the -output buffer. Allocating a buffer of size `MA_MAX_DEVICE_NAME_LENGTH + 1` should be enough for -most cases and will avoid the need for the inefficiency of calling this function twice. - -This is implemented in terms of `ma_device_get_info()`. -*/ -MA_API ma_result ma_device_get_name(ma_device* pDevice, ma_device_type type, char* pName, size_t nameCap, size_t* pLengthNotIncludingNullTerminator); - - -/* -Starts the device. For playback devices this begins playback. For capture devices it begins recording. - -Use `ma_device_stop()` to stop the device. - - -Parameters ----------- -pDevice (in) - A pointer to the device to start. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Safe. It's safe to call this from any thread with the exception of the callback thread. - - -Callback Safety ---------------- -Unsafe. It is not safe to call this inside any callback. - - -Remarks -------- -For a playback device, this will retrieve an initial chunk of audio data from the client before returning. The reason for this is to ensure there is valid -audio data in the buffer, which needs to be done before the device begins playback. - -This API waits until the backend device has been started for real by the worker thread. It also waits on a mutex for thread-safety. - -Do not call this in any callback. - - -See Also --------- -ma_device_stop() -*/ -MA_API ma_result ma_device_start(ma_device* pDevice); - -/* -Stops the device. For playback devices this stops playback. For capture devices it stops recording. - -Use `ma_device_start()` to start the device again. - - -Parameters ----------- -pDevice (in) - A pointer to the device to stop. - - -Return Value ------------- -MA_SUCCESS if successful; any other error code otherwise. - - -Thread Safety -------------- -Safe. It's safe to call this from any thread with the exception of the callback thread. - - -Callback Safety ---------------- -Unsafe. It is not safe to call this inside any callback. Doing this will result in a deadlock. - - -Remarks -------- -This API needs to wait on the worker thread to stop the backend device properly before returning. It also waits on a mutex for thread-safety. In addition, some -backends need to wait for the device to finish playback/recording of the current fragment which can take some time (usually proportionate to the buffer size -that was specified at initialization time). - -Backends are required to either pause the stream in-place or drain the buffer if pausing is not possible. The reason for this is that stopping the device and -the resuming it with ma_device_start() (which you might do when your program loses focus) may result in a situation where those samples are never output to the -speakers or received from the microphone which can in turn result in de-syncs. - -Do not call this in any callback. - -This will be called implicitly by `ma_device_uninit()`. - - -See Also --------- -ma_device_start() -*/ -MA_API ma_result ma_device_stop(ma_device* pDevice); - -/* -Determines whether or not the device is started. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose start state is being retrieved. - - -Return Value ------------- -True if the device is started, false otherwise. - - -Thread Safety -------------- -Safe. If another thread calls `ma_device_start()` or `ma_device_stop()` at this same time as this function is called, there's a very small chance the return -value will be out of sync. - - -Callback Safety ---------------- -Safe. This is implemented as a simple accessor. - - -See Also --------- -ma_device_start() -ma_device_stop() -*/ -MA_API ma_bool32 ma_device_is_started(const ma_device* pDevice); - - -/* -Retrieves the state of the device. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose state is being retrieved. - - -Return Value ------------- -The current state of the device. The return value will be one of the following: - - +-------------------------------+------------------------------------------------------------------------------+ - | ma_device_state_uninitialized | Will only be returned if the device is in the middle of initialization. | - +-------------------------------+------------------------------------------------------------------------------+ - | ma_device_state_stopped | The device is stopped. The initial state of the device after initialization. | - +-------------------------------+------------------------------------------------------------------------------+ - | ma_device_state_started | The device started and requesting and/or delivering audio data. | - +-------------------------------+------------------------------------------------------------------------------+ - | ma_device_state_starting | The device is in the process of starting. | - +-------------------------------+------------------------------------------------------------------------------+ - | ma_device_state_stopping | The device is in the process of stopping. | - +-------------------------------+------------------------------------------------------------------------------+ - - -Thread Safety -------------- -Safe. This is implemented as a simple accessor. Note that if the device is started or stopped at the same time as this function is called, -there's a possibility the return value could be out of sync. See remarks. - - -Callback Safety ---------------- -Safe. This is implemented as a simple accessor. - - -Remarks -------- -The general flow of a devices state goes like this: - - ``` - ma_device_init() -> ma_device_state_uninitialized -> ma_device_state_stopped - ma_device_start() -> ma_device_state_starting -> ma_device_state_started - ma_device_stop() -> ma_device_state_stopping -> ma_device_state_stopped - ``` - -When the state of the device is changed with `ma_device_start()` or `ma_device_stop()` at this same time as this function is called, the -value returned by this function could potentially be out of sync. If this is significant to your program you need to implement your own -synchronization. -*/ -MA_API ma_device_state ma_device_get_state(const ma_device* pDevice); - - -/* -Performs post backend initialization routines for setting up internal data conversion. - -This should be called whenever the backend is initialized. The only time this should be called from -outside of miniaudio is if you're implementing a custom backend, and you would only do it if you -are reinitializing the backend due to rerouting or reinitializing for some reason. - - -Parameters ----------- -pDevice [in] - A pointer to the device. - -deviceType [in] - The type of the device that was just reinitialized. - -pPlaybackDescriptor [in] - The descriptor of the playback device containing the internal data format and buffer sizes. - -pPlaybackDescriptor [in] - The descriptor of the capture device containing the internal data format and buffer sizes. - - -Return Value ------------- -MA_SUCCESS if successful; any other error otherwise. - - -Thread Safety -------------- -Unsafe. This will be reinitializing internal data converters which may be in use by another thread. - - -Callback Safety ---------------- -Unsafe. This will be reinitializing internal data converters which may be in use by the callback. - - -Remarks -------- -For a duplex device, you can call this for only one side of the system. This is why the deviceType -is specified as a parameter rather than deriving it from the device. - -You do not need to call this manually unless you are doing a custom backend, in which case you need -only do it if you're manually performing rerouting or reinitialization. -*/ -MA_API ma_result ma_device_post_init(ma_device* pDevice, ma_device_type deviceType, const ma_device_descriptor* pPlaybackDescriptor, const ma_device_descriptor* pCaptureDescriptor); - - -/* -Sets the master volume factor for the device. - -The volume factor must be between 0 (silence) and 1 (full volume). Use `ma_device_set_master_volume_db()` to use decibel notation, where 0 is full volume and -values less than 0 decreases the volume. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose volume is being set. - -volume (in) - The new volume factor. Must be >= 0. - - -Return Value ------------- -MA_SUCCESS if the volume was set successfully. -MA_INVALID_ARGS if pDevice is NULL. -MA_INVALID_ARGS if volume is negative. - - -Thread Safety -------------- -Safe. This just sets a local member of the device object. - - -Callback Safety ---------------- -Safe. If you set the volume in the data callback, that data written to the output buffer will have the new volume applied. - - -Remarks -------- -This applies the volume factor across all channels. - -This does not change the operating system's volume. It only affects the volume for the given `ma_device` object's audio stream. - - -See Also --------- -ma_device_get_master_volume() -ma_device_set_master_volume_db() -ma_device_get_master_volume_db() -*/ -MA_API ma_result ma_device_set_master_volume(ma_device* pDevice, float volume); - -/* -Retrieves the master volume factor for the device. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose volume factor is being retrieved. - -pVolume (in) - A pointer to the variable that will receive the volume factor. The returned value will be in the range of [0, 1]. - - -Return Value ------------- -MA_SUCCESS if successful. -MA_INVALID_ARGS if pDevice is NULL. -MA_INVALID_ARGS if pVolume is NULL. - - -Thread Safety -------------- -Safe. This just a simple member retrieval. - - -Callback Safety ---------------- -Safe. - - -Remarks -------- -If an error occurs, `*pVolume` will be set to 0. - - -See Also --------- -ma_device_set_master_volume() -ma_device_set_master_volume_gain_db() -ma_device_get_master_volume_gain_db() -*/ -MA_API ma_result ma_device_get_master_volume(ma_device* pDevice, float* pVolume); - -/* -Sets the master volume for the device as gain in decibels. - -A gain of 0 is full volume, whereas a gain of < 0 will decrease the volume. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose gain is being set. - -gainDB (in) - The new volume as gain in decibels. Must be less than or equal to 0, where 0 is full volume and anything less than 0 decreases the volume. - - -Return Value ------------- -MA_SUCCESS if the volume was set successfully. -MA_INVALID_ARGS if pDevice is NULL. -MA_INVALID_ARGS if the gain is > 0. - - -Thread Safety -------------- -Safe. This just sets a local member of the device object. - - -Callback Safety ---------------- -Safe. If you set the volume in the data callback, that data written to the output buffer will have the new volume applied. - - -Remarks -------- -This applies the gain across all channels. - -This does not change the operating system's volume. It only affects the volume for the given `ma_device` object's audio stream. - - -See Also --------- -ma_device_get_master_volume_gain_db() -ma_device_set_master_volume() -ma_device_get_master_volume() -*/ -MA_API ma_result ma_device_set_master_volume_db(ma_device* pDevice, float gainDB); - -/* -Retrieves the master gain in decibels. - - -Parameters ----------- -pDevice (in) - A pointer to the device whose gain is being retrieved. - -pGainDB (in) - A pointer to the variable that will receive the gain in decibels. The returned value will be <= 0. - - -Return Value ------------- -MA_SUCCESS if successful. -MA_INVALID_ARGS if pDevice is NULL. -MA_INVALID_ARGS if pGainDB is NULL. - - -Thread Safety -------------- -Safe. This just a simple member retrieval. - - -Callback Safety ---------------- -Safe. - - -Remarks -------- -If an error occurs, `*pGainDB` will be set to 0. - - -See Also --------- -ma_device_set_master_volume_db() -ma_device_set_master_volume() -ma_device_get_master_volume() -*/ -MA_API ma_result ma_device_get_master_volume_db(ma_device* pDevice, float* pGainDB); - - -/* -Called from the data callback of asynchronous backends to allow miniaudio to process the data and fire the miniaudio data callback. - - -Parameters ----------- -pDevice (in) - A pointer to device whose processing the data callback. - -pOutput (out) - A pointer to the buffer that will receive the output PCM frame data. On a playback device this must not be NULL. On a duplex device - this can be NULL, in which case pInput must not be NULL. - -pInput (in) - A pointer to the buffer containing input PCM frame data. On a capture device this must not be NULL. On a duplex device this can be - NULL, in which case `pOutput` must not be NULL. - -frameCount (in) - The number of frames being processed. - - -Return Value ------------- -MA_SUCCESS if successful; any other result code otherwise. - - -Thread Safety -------------- -This function should only ever be called from the internal data callback of the backend. It is safe to call this simultaneously between a -playback and capture device in duplex setups. - - -Callback Safety ---------------- -Do not call this from the miniaudio data callback. It should only ever be called from the internal data callback of the backend. - - -Remarks -------- -If both `pOutput` and `pInput` are NULL, and error will be returned. In duplex scenarios, both `pOutput` and `pInput` can be non-NULL, in -which case `pInput` will be processed first, followed by `pOutput`. - -If you are implementing a custom backend, and that backend uses a callback for data delivery, you'll need to call this from inside that -callback. -*/ -MA_API ma_result ma_device_handle_backend_data_callback(ma_device* pDevice, void* pOutput, const void* pInput, ma_uint32 frameCount); - - -/* -Calculates an appropriate buffer size from a descriptor, native sample rate and performance profile. - -This function is used by backends for helping determine an appropriately sized buffer to use with -the device depending on the values of `periodSizeInFrames` and `periodSizeInMilliseconds` in the -`pDescriptor` object. Since buffer size calculations based on time depends on the sample rate, a -best guess at the device's native sample rate is also required which is where `nativeSampleRate` -comes in. In addition, the performance profile is also needed for cases where both the period size -in frames and milliseconds are both zero. - - -Parameters ----------- -pDescriptor (in) - A pointer to device descriptor whose `periodSizeInFrames` and `periodSizeInMilliseconds` members - will be used for the calculation of the buffer size. - -nativeSampleRate (in) - The device's native sample rate. This is only ever used when the `periodSizeInFrames` member of - `pDescriptor` is zero. In this case, `periodSizeInMilliseconds` will be used instead, in which - case a sample rate is required to convert to a size in frames. - -performanceProfile (in) - When both the `periodSizeInFrames` and `periodSizeInMilliseconds` members of `pDescriptor` are - zero, miniaudio will fall back to a buffer size based on the performance profile. The profile - to use for this calculation is determine by this parameter. - - -Return Value ------------- -The calculated buffer size in frames. - - -Thread Safety -------------- -This is safe so long as nothing modifies `pDescriptor` at the same time. However, this function -should only ever be called from within the backend's device initialization routine and therefore -shouldn't have any multithreading concerns. - - -Callback Safety ---------------- -This is safe to call within the data callback, but there is no reason to ever do this. - - -Remarks -------- -If `nativeSampleRate` is zero, this function will fall back to `pDescriptor->sampleRate`. If that -is also zero, `MA_DEFAULT_SAMPLE_RATE` will be used instead. -*/ -MA_API ma_uint32 ma_calculate_buffer_size_in_frames_from_descriptor(const ma_device_descriptor* pDescriptor, ma_uint32 nativeSampleRate, ma_performance_profile performanceProfile); - - - -/* -Retrieves a friendly name for a backend. -*/ -MA_API const char* ma_get_backend_name(ma_backend backend); - -/* -Retrieves the backend enum from the given name. -*/ -MA_API ma_result ma_get_backend_from_name(const char* pBackendName, ma_backend* pBackend); - -/* -Determines whether or not the given backend is available by the compilation environment. -*/ -MA_API ma_bool32 ma_is_backend_enabled(ma_backend backend); - -/* -Retrieves compile-time enabled backends. - - -Parameters ----------- -pBackends (out, optional) - A pointer to the buffer that will receive the enabled backends. Set to NULL to retrieve the backend count. Setting - the capacity of the buffer to `MA_BUFFER_COUNT` will guarantee it's large enough for all backends. - -backendCap (in) - The capacity of the `pBackends` buffer. - -pBackendCount (out) - A pointer to the variable that will receive the enabled backend count. - - -Return Value ------------- -MA_SUCCESS if successful. -MA_INVALID_ARGS if `pBackendCount` is NULL. -MA_NO_SPACE if the capacity of `pBackends` is not large enough. - -If `MA_NO_SPACE` is returned, the `pBackends` buffer will be filled with `*pBackendCount` values. - - -Thread Safety -------------- -Safe. - - -Callback Safety ---------------- -Safe. - - -Remarks -------- -If you want to retrieve the number of backends so you can determine the capacity of `pBackends` buffer, you can call -this function with `pBackends` set to NULL. - -This will also enumerate the null backend. If you don't want to include this you need to check for `ma_backend_null` -when you enumerate over the returned backends and handle it appropriately. Alternatively, you can disable it at -compile time with `MA_NO_NULL`. - -The returned backends are determined based on compile time settings, not the platform it's currently running on. For -example, PulseAudio will be returned if it was enabled at compile time, even when the user doesn't actually have -PulseAudio installed. - - -Example 1 ---------- -The example below retrieves the enabled backend count using a fixed sized buffer allocated on the stack. The buffer is -given a capacity of `MA_BACKEND_COUNT` which will guarantee it'll be large enough to store all available backends. -Since `MA_BACKEND_COUNT` is always a relatively small value, this should be suitable for most scenarios. - -``` -ma_backend enabledBackends[MA_BACKEND_COUNT]; -size_t enabledBackendCount; - -result = ma_get_enabled_backends(enabledBackends, MA_BACKEND_COUNT, &enabledBackendCount); -if (result != MA_SUCCESS) { - // Failed to retrieve enabled backends. Should never happen in this example since all inputs are valid. -} -``` - - -See Also --------- -ma_is_backend_enabled() -*/ -MA_API ma_result ma_get_enabled_backends(ma_backend* pBackends, size_t backendCap, size_t* pBackendCount); - -/* -Determines whether or not loopback mode is support by a backend. -*/ -MA_API ma_bool32 ma_is_loopback_supported(ma_backend backend); - -#endif /* MA_NO_DEVICE_IO */ - - - -/************************************************************************************************************************************************************ - -Utilities - -************************************************************************************************************************************************************/ - -/* -Calculates a buffer size in milliseconds from the specified number of frames and sample rate. -*/ -MA_API ma_uint32 ma_calculate_buffer_size_in_milliseconds_from_frames(ma_uint32 bufferSizeInFrames, ma_uint32 sampleRate); - -/* -Calculates a buffer size in frames from the specified number of milliseconds and sample rate. -*/ -MA_API ma_uint32 ma_calculate_buffer_size_in_frames_from_milliseconds(ma_uint32 bufferSizeInMilliseconds, ma_uint32 sampleRate); - -/* -Copies PCM frames from one buffer to another. -*/ -MA_API void ma_copy_pcm_frames(void* dst, const void* src, ma_uint64 frameCount, ma_format format, ma_uint32 channels); - -/* -Copies silent frames into the given buffer. - -Remarks -------- -For all formats except `ma_format_u8`, the output buffer will be filled with 0. For `ma_format_u8` it will be filled with 128. The reason for this is that it -makes more sense for the purpose of mixing to initialize it to the center point. -*/ -MA_API void ma_silence_pcm_frames(void* p, ma_uint64 frameCount, ma_format format, ma_uint32 channels); - - -/* -Offsets a pointer by the specified number of PCM frames. -*/ -MA_API void* ma_offset_pcm_frames_ptr(void* p, ma_uint64 offsetInFrames, ma_format format, ma_uint32 channels); -MA_API const void* ma_offset_pcm_frames_const_ptr(const void* p, ma_uint64 offsetInFrames, ma_format format, ma_uint32 channels); -static MA_INLINE float* ma_offset_pcm_frames_ptr_f32(float* p, ma_uint64 offsetInFrames, ma_uint32 channels) { return (float*)ma_offset_pcm_frames_ptr((void*)p, offsetInFrames, ma_format_f32, channels); } -static MA_INLINE const float* ma_offset_pcm_frames_const_ptr_f32(const float* p, ma_uint64 offsetInFrames, ma_uint32 channels) { return (const float*)ma_offset_pcm_frames_const_ptr((const void*)p, offsetInFrames, ma_format_f32, channels); } - - -/* -Clips samples. -*/ -MA_API void ma_clip_samples_u8(ma_uint8* pDst, const ma_int16* pSrc, ma_uint64 count); -MA_API void ma_clip_samples_s16(ma_int16* pDst, const ma_int32* pSrc, ma_uint64 count); -MA_API void ma_clip_samples_s24(ma_uint8* pDst, const ma_int64* pSrc, ma_uint64 count); -MA_API void ma_clip_samples_s32(ma_int32* pDst, const ma_int64* pSrc, ma_uint64 count); -MA_API void ma_clip_samples_f32(float* pDst, const float* pSrc, ma_uint64 count); -MA_API void ma_clip_pcm_frames(void* pDst, const void* pSrc, ma_uint64 frameCount, ma_format format, ma_uint32 channels); - -/* -Helper for applying a volume factor to samples. - -Note that the source and destination buffers can be the same, in which case it'll perform the operation in-place. -*/ -MA_API void ma_copy_and_apply_volume_factor_u8(ma_uint8* pSamplesOut, const ma_uint8* pSamplesIn, ma_uint64 sampleCount, float factor); -MA_API void ma_copy_and_apply_volume_factor_s16(ma_int16* pSamplesOut, const ma_int16* pSamplesIn, ma_uint64 sampleCount, float factor); -MA_API void ma_copy_and_apply_volume_factor_s24(void* pSamplesOut, const void* pSamplesIn, ma_uint64 sampleCount, float factor); -MA_API void ma_copy_and_apply_volume_factor_s32(ma_int32* pSamplesOut, const ma_int32* pSamplesIn, ma_uint64 sampleCount, float factor); -MA_API void ma_copy_and_apply_volume_factor_f32(float* pSamplesOut, const float* pSamplesIn, ma_uint64 sampleCount, float factor); - -MA_API void ma_apply_volume_factor_u8(ma_uint8* pSamples, ma_uint64 sampleCount, float factor); -MA_API void ma_apply_volume_factor_s16(ma_int16* pSamples, ma_uint64 sampleCount, float factor); -MA_API void ma_apply_volume_factor_s24(void* pSamples, ma_uint64 sampleCount, float factor); -MA_API void ma_apply_volume_factor_s32(ma_int32* pSamples, ma_uint64 sampleCount, float factor); -MA_API void ma_apply_volume_factor_f32(float* pSamples, ma_uint64 sampleCount, float factor); - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_u8(ma_uint8* pFramesOut, const ma_uint8* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_s16(ma_int16* pFramesOut, const ma_int16* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_s24(void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_s32(ma_int32* pFramesOut, const ma_int32* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_f32(float* pFramesOut, const float* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_copy_and_apply_volume_factor_pcm_frames(void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount, ma_format format, ma_uint32 channels, float factor); - -MA_API void ma_apply_volume_factor_pcm_frames_u8(ma_uint8* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_apply_volume_factor_pcm_frames_s16(ma_int16* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_apply_volume_factor_pcm_frames_s24(void* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_apply_volume_factor_pcm_frames_s32(ma_int32* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_apply_volume_factor_pcm_frames_f32(float* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor); -MA_API void ma_apply_volume_factor_pcm_frames(void* pFrames, ma_uint64 frameCount, ma_format format, ma_uint32 channels, float factor); - -MA_API void ma_copy_and_apply_volume_factor_per_channel_f32(float* pFramesOut, const float* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float* pChannelGains); - - -MA_API void ma_copy_and_apply_volume_and_clip_samples_u8(ma_uint8* pDst, const ma_int16* pSrc, ma_uint64 count, float volume); -MA_API void ma_copy_and_apply_volume_and_clip_samples_s16(ma_int16* pDst, const ma_int32* pSrc, ma_uint64 count, float volume); -MA_API void ma_copy_and_apply_volume_and_clip_samples_s24(ma_uint8* pDst, const ma_int64* pSrc, ma_uint64 count, float volume); -MA_API void ma_copy_and_apply_volume_and_clip_samples_s32(ma_int32* pDst, const ma_int64* pSrc, ma_uint64 count, float volume); -MA_API void ma_copy_and_apply_volume_and_clip_samples_f32(float* pDst, const float* pSrc, ma_uint64 count, float volume); -MA_API void ma_copy_and_apply_volume_and_clip_pcm_frames(void* pDst, const void* pSrc, ma_uint64 frameCount, ma_format format, ma_uint32 channels, float volume); - - -/* -Helper for converting a linear factor to gain in decibels. -*/ -MA_API float ma_volume_linear_to_db(float factor); - -/* -Helper for converting gain in decibels to a linear factor. -*/ -MA_API float ma_volume_db_to_linear(float gain); - - -/* -Mixes the specified number of frames in floating point format with a volume factor. - -This will run on an optimized path when the volume is equal to 1. -*/ -MA_API ma_result ma_mix_pcm_frames_f32(float* pDst, const float* pSrc, ma_uint64 frameCount, ma_uint32 channels, float volume); - - -/************************************************************************************************** - -Data Source - -**************************************************************************************************/ -typedef void ma_data_source; - -#define MA_DATA_SOURCE_SELF_MANAGED_RANGE_AND_LOOP_POINT 0x00000001 - -typedef struct -{ - ma_result (* onRead)(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); - ma_result (* onSeek)(ma_data_source* pDataSource, ma_uint64 frameIndex); - ma_result (* onGetDataFormat)(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); - ma_result (* onGetCursor)(ma_data_source* pDataSource, ma_uint64* pCursor); - ma_result (* onGetLength)(ma_data_source* pDataSource, ma_uint64* pLength); - ma_result (* onSetLooping)(ma_data_source* pDataSource, ma_bool32 isLooping); - ma_uint32 flags; -} ma_data_source_vtable; - -typedef ma_data_source* (* ma_data_source_get_next_proc)(ma_data_source* pDataSource); - -typedef struct -{ - const ma_data_source_vtable* vtable; -} ma_data_source_config; - -MA_API ma_data_source_config ma_data_source_config_init(void); - - -typedef struct -{ - const ma_data_source_vtable* vtable; - ma_uint64 rangeBegInFrames; - ma_uint64 rangeEndInFrames; /* Set to -1 for unranged (default). */ - ma_uint64 loopBegInFrames; /* Relative to rangeBegInFrames. */ - ma_uint64 loopEndInFrames; /* Relative to rangeBegInFrames. Set to -1 for the end of the range. */ - ma_data_source* pCurrent; /* When non-NULL, the data source being initialized will act as a proxy and will route all operations to pCurrent. Used in conjunction with pNext/onGetNext for seamless chaining. */ - ma_data_source* pNext; /* When set to NULL, onGetNext will be used. */ - ma_data_source_get_next_proc onGetNext; /* Will be used when pNext is NULL. If both are NULL, no next will be used. */ - MA_ATOMIC(4, ma_bool32) isLooping; -} ma_data_source_base; - -MA_API ma_result ma_data_source_init(const ma_data_source_config* pConfig, ma_data_source* pDataSource); -MA_API void ma_data_source_uninit(ma_data_source* pDataSource); -MA_API ma_result ma_data_source_read_pcm_frames(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); /* Must support pFramesOut = NULL in which case a forward seek should be performed. */ -MA_API ma_result ma_data_source_seek_pcm_frames(ma_data_source* pDataSource, ma_uint64 frameCount, ma_uint64* pFramesSeeked); /* Can only seek forward. Equivalent to ma_data_source_read_pcm_frames(pDataSource, NULL, frameCount, &framesRead); */ -MA_API ma_result ma_data_source_seek_to_pcm_frame(ma_data_source* pDataSource, ma_uint64 frameIndex); -MA_API ma_result ma_data_source_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_data_source_get_cursor_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pCursor); -MA_API ma_result ma_data_source_get_length_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pLength); /* Returns MA_NOT_IMPLEMENTED if the length is unknown or cannot be determined. Decoders can return this. */ -MA_API ma_result ma_data_source_get_cursor_in_seconds(ma_data_source* pDataSource, float* pCursor); -MA_API ma_result ma_data_source_get_length_in_seconds(ma_data_source* pDataSource, float* pLength); -MA_API ma_result ma_data_source_set_looping(ma_data_source* pDataSource, ma_bool32 isLooping); -MA_API ma_bool32 ma_data_source_is_looping(const ma_data_source* pDataSource); -MA_API ma_result ma_data_source_set_range_in_pcm_frames(ma_data_source* pDataSource, ma_uint64 rangeBegInFrames, ma_uint64 rangeEndInFrames); -MA_API void ma_data_source_get_range_in_pcm_frames(const ma_data_source* pDataSource, ma_uint64* pRangeBegInFrames, ma_uint64* pRangeEndInFrames); -MA_API ma_result ma_data_source_set_loop_point_in_pcm_frames(ma_data_source* pDataSource, ma_uint64 loopBegInFrames, ma_uint64 loopEndInFrames); -MA_API void ma_data_source_get_loop_point_in_pcm_frames(const ma_data_source* pDataSource, ma_uint64* pLoopBegInFrames, ma_uint64* pLoopEndInFrames); -MA_API ma_result ma_data_source_set_current(ma_data_source* pDataSource, ma_data_source* pCurrentDataSource); -MA_API ma_data_source* ma_data_source_get_current(const ma_data_source* pDataSource); -MA_API ma_result ma_data_source_set_next(ma_data_source* pDataSource, ma_data_source* pNextDataSource); -MA_API ma_data_source* ma_data_source_get_next(const ma_data_source* pDataSource); -MA_API ma_result ma_data_source_set_next_callback(ma_data_source* pDataSource, ma_data_source_get_next_proc onGetNext); -MA_API ma_data_source_get_next_proc ma_data_source_get_next_callback(const ma_data_source* pDataSource); - - -typedef struct -{ - ma_data_source_base ds; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint64 cursor; - ma_uint64 sizeInFrames; - const void* pData; -} ma_audio_buffer_ref; - -MA_API ma_result ma_audio_buffer_ref_init(ma_format format, ma_uint32 channels, const void* pData, ma_uint64 sizeInFrames, ma_audio_buffer_ref* pAudioBufferRef); -MA_API void ma_audio_buffer_ref_uninit(ma_audio_buffer_ref* pAudioBufferRef); -MA_API ma_result ma_audio_buffer_ref_set_data(ma_audio_buffer_ref* pAudioBufferRef, const void* pData, ma_uint64 sizeInFrames); -MA_API ma_uint64 ma_audio_buffer_ref_read_pcm_frames(ma_audio_buffer_ref* pAudioBufferRef, void* pFramesOut, ma_uint64 frameCount, ma_bool32 loop); -MA_API ma_result ma_audio_buffer_ref_seek_to_pcm_frame(ma_audio_buffer_ref* pAudioBufferRef, ma_uint64 frameIndex); -MA_API ma_result ma_audio_buffer_ref_map(ma_audio_buffer_ref* pAudioBufferRef, void** ppFramesOut, ma_uint64* pFrameCount); -MA_API ma_result ma_audio_buffer_ref_unmap(ma_audio_buffer_ref* pAudioBufferRef, ma_uint64 frameCount); /* Returns MA_AT_END if the end has been reached. This should be considered successful. */ -MA_API ma_bool32 ma_audio_buffer_ref_at_end(const ma_audio_buffer_ref* pAudioBufferRef); -MA_API ma_result ma_audio_buffer_ref_get_cursor_in_pcm_frames(const ma_audio_buffer_ref* pAudioBufferRef, ma_uint64* pCursor); -MA_API ma_result ma_audio_buffer_ref_get_length_in_pcm_frames(const ma_audio_buffer_ref* pAudioBufferRef, ma_uint64* pLength); -MA_API ma_result ma_audio_buffer_ref_get_available_frames(const ma_audio_buffer_ref* pAudioBufferRef, ma_uint64* pAvailableFrames); - - - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint64 sizeInFrames; - const void* pData; /* If set to NULL, will allocate a block of memory for you. */ - ma_allocation_callbacks allocationCallbacks; -} ma_audio_buffer_config; - -MA_API ma_audio_buffer_config ma_audio_buffer_config_init(ma_format format, ma_uint32 channels, ma_uint64 sizeInFrames, const void* pData, const ma_allocation_callbacks* pAllocationCallbacks); - -typedef struct -{ - ma_audio_buffer_ref ref; - ma_allocation_callbacks allocationCallbacks; - ma_bool32 ownsData; /* Used to control whether or not miniaudio owns the data buffer. If set to true, pData will be freed in ma_audio_buffer_uninit(). */ - ma_uint8 _pExtraData[1]; /* For allocating a buffer with the memory located directly after the other memory of the structure. */ -} ma_audio_buffer; - -MA_API ma_result ma_audio_buffer_init(const ma_audio_buffer_config* pConfig, ma_audio_buffer* pAudioBuffer); -MA_API ma_result ma_audio_buffer_init_copy(const ma_audio_buffer_config* pConfig, ma_audio_buffer* pAudioBuffer); -MA_API ma_result ma_audio_buffer_alloc_and_init(const ma_audio_buffer_config* pConfig, ma_audio_buffer** ppAudioBuffer); /* Always copies the data. Doesn't make sense to use this otherwise. Use ma_audio_buffer_uninit_and_free() to uninit. */ -MA_API void ma_audio_buffer_uninit(ma_audio_buffer* pAudioBuffer); -MA_API void ma_audio_buffer_uninit_and_free(ma_audio_buffer* pAudioBuffer); -MA_API ma_uint64 ma_audio_buffer_read_pcm_frames(ma_audio_buffer* pAudioBuffer, void* pFramesOut, ma_uint64 frameCount, ma_bool32 loop); -MA_API ma_result ma_audio_buffer_seek_to_pcm_frame(ma_audio_buffer* pAudioBuffer, ma_uint64 frameIndex); -MA_API ma_result ma_audio_buffer_map(ma_audio_buffer* pAudioBuffer, void** ppFramesOut, ma_uint64* pFrameCount); -MA_API ma_result ma_audio_buffer_unmap(ma_audio_buffer* pAudioBuffer, ma_uint64 frameCount); /* Returns MA_AT_END if the end has been reached. This should be considered successful. */ -MA_API ma_bool32 ma_audio_buffer_at_end(const ma_audio_buffer* pAudioBuffer); -MA_API ma_result ma_audio_buffer_get_cursor_in_pcm_frames(const ma_audio_buffer* pAudioBuffer, ma_uint64* pCursor); -MA_API ma_result ma_audio_buffer_get_length_in_pcm_frames(const ma_audio_buffer* pAudioBuffer, ma_uint64* pLength); -MA_API ma_result ma_audio_buffer_get_available_frames(const ma_audio_buffer* pAudioBuffer, ma_uint64* pAvailableFrames); - - -/* -Paged Audio Buffer -================== -A paged audio buffer is made up of a linked list of pages. It's expandable, but not shrinkable. It -can be used for cases where audio data is streamed in asynchronously while allowing data to be read -at the same time. - -This is lock-free, but not 100% thread safe. You can append a page and read from the buffer across -simultaneously across different threads, however only one thread at a time can append, and only one -thread at a time can read and seek. -*/ -typedef struct ma_paged_audio_buffer_page ma_paged_audio_buffer_page; -struct ma_paged_audio_buffer_page -{ - MA_ATOMIC(MA_SIZEOF_PTR, ma_paged_audio_buffer_page*) pNext; - ma_uint64 sizeInFrames; - ma_uint8 pAudioData[1]; -}; - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_paged_audio_buffer_page head; /* Dummy head for the lock-free algorithm. Always has a size of 0. */ - MA_ATOMIC(MA_SIZEOF_PTR, ma_paged_audio_buffer_page*) pTail; /* Never null. Initially set to &head. */ -} ma_paged_audio_buffer_data; - -MA_API ma_result ma_paged_audio_buffer_data_init(ma_format format, ma_uint32 channels, ma_paged_audio_buffer_data* pData); -MA_API void ma_paged_audio_buffer_data_uninit(ma_paged_audio_buffer_data* pData, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_paged_audio_buffer_page* ma_paged_audio_buffer_data_get_head(ma_paged_audio_buffer_data* pData); -MA_API ma_paged_audio_buffer_page* ma_paged_audio_buffer_data_get_tail(ma_paged_audio_buffer_data* pData); -MA_API ma_result ma_paged_audio_buffer_data_get_length_in_pcm_frames(ma_paged_audio_buffer_data* pData, ma_uint64* pLength); -MA_API ma_result ma_paged_audio_buffer_data_allocate_page(ma_paged_audio_buffer_data* pData, ma_uint64 pageSizeInFrames, const void* pInitialData, const ma_allocation_callbacks* pAllocationCallbacks, ma_paged_audio_buffer_page** ppPage); -MA_API ma_result ma_paged_audio_buffer_data_free_page(ma_paged_audio_buffer_data* pData, ma_paged_audio_buffer_page* pPage, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_paged_audio_buffer_data_append_page(ma_paged_audio_buffer_data* pData, ma_paged_audio_buffer_page* pPage); -MA_API ma_result ma_paged_audio_buffer_data_allocate_and_append_page(ma_paged_audio_buffer_data* pData, ma_uint32 pageSizeInFrames, const void* pInitialData, const ma_allocation_callbacks* pAllocationCallbacks); - - -typedef struct -{ - ma_paged_audio_buffer_data* pData; /* Must not be null. */ -} ma_paged_audio_buffer_config; - -MA_API ma_paged_audio_buffer_config ma_paged_audio_buffer_config_init(ma_paged_audio_buffer_data* pData); - - -typedef struct -{ - ma_data_source_base ds; - ma_paged_audio_buffer_data* pData; /* Audio data is read from here. Cannot be null. */ - ma_paged_audio_buffer_page* pCurrent; - ma_uint64 relativeCursor; /* Relative to the current page. */ - ma_uint64 absoluteCursor; -} ma_paged_audio_buffer; - -MA_API ma_result ma_paged_audio_buffer_init(const ma_paged_audio_buffer_config* pConfig, ma_paged_audio_buffer* pPagedAudioBuffer); -MA_API void ma_paged_audio_buffer_uninit(ma_paged_audio_buffer* pPagedAudioBuffer); -MA_API ma_result ma_paged_audio_buffer_read_pcm_frames(ma_paged_audio_buffer* pPagedAudioBuffer, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); /* Returns MA_AT_END if no more pages available. */ -MA_API ma_result ma_paged_audio_buffer_seek_to_pcm_frame(ma_paged_audio_buffer* pPagedAudioBuffer, ma_uint64 frameIndex); -MA_API ma_result ma_paged_audio_buffer_get_cursor_in_pcm_frames(ma_paged_audio_buffer* pPagedAudioBuffer, ma_uint64* pCursor); -MA_API ma_result ma_paged_audio_buffer_get_length_in_pcm_frames(ma_paged_audio_buffer* pPagedAudioBuffer, ma_uint64* pLength); - - - -/************************************************************************************************************************************************************ - -VFS -=== - -The VFS object (virtual file system) is what's used to customize file access. This is useful in cases where stdio FILE* based APIs may not be entirely -appropriate for a given situation. - -************************************************************************************************************************************************************/ -typedef void ma_vfs; -typedef ma_handle ma_vfs_file; - -typedef enum -{ - MA_OPEN_MODE_READ = 0x00000001, - MA_OPEN_MODE_WRITE = 0x00000002 -} ma_open_mode_flags; - -typedef enum -{ - ma_seek_origin_start, - ma_seek_origin_current, - ma_seek_origin_end /* Not used by decoders. */ -} ma_seek_origin; - -typedef struct -{ - ma_uint64 sizeInBytes; -} ma_file_info; - -typedef struct -{ - ma_result (* onOpen) (ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile); - ma_result (* onOpenW)(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile); - ma_result (* onClose)(ma_vfs* pVFS, ma_vfs_file file); - ma_result (* onRead) (ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead); - ma_result (* onWrite)(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten); - ma_result (* onSeek) (ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin); - ma_result (* onTell) (ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor); - ma_result (* onInfo) (ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo); -} ma_vfs_callbacks; - -MA_API ma_result ma_vfs_open(ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile); -MA_API ma_result ma_vfs_open_w(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile); -MA_API ma_result ma_vfs_close(ma_vfs* pVFS, ma_vfs_file file); -MA_API ma_result ma_vfs_read(ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead); -MA_API ma_result ma_vfs_write(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten); -MA_API ma_result ma_vfs_seek(ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin); -MA_API ma_result ma_vfs_tell(ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor); -MA_API ma_result ma_vfs_info(ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo); -MA_API ma_result ma_vfs_open_and_read_file(ma_vfs* pVFS, const char* pFilePath, void** ppData, size_t* pSize, const ma_allocation_callbacks* pAllocationCallbacks); - -typedef struct -{ - ma_vfs_callbacks cb; - ma_allocation_callbacks allocationCallbacks; /* Only used for the wchar_t version of open() on non-Windows platforms. */ -} ma_default_vfs; - -MA_API ma_result ma_default_vfs_init(ma_default_vfs* pVFS, const ma_allocation_callbacks* pAllocationCallbacks); - - - -typedef ma_result (* ma_read_proc)(void* pUserData, void* pBufferOut, size_t bytesToRead, size_t* pBytesRead); -typedef ma_result (* ma_seek_proc)(void* pUserData, ma_int64 offset, ma_seek_origin origin); -typedef ma_result (* ma_tell_proc)(void* pUserData, ma_int64* pCursor); - - - -#if !defined(MA_NO_DECODING) || !defined(MA_NO_ENCODING) -typedef enum -{ - ma_encoding_format_unknown = 0, - ma_encoding_format_wav, - ma_encoding_format_flac, - ma_encoding_format_mp3, - ma_encoding_format_vorbis -} ma_encoding_format; -#endif - -/************************************************************************************************************************************************************ - -Decoding -======== - -Decoders are independent of the main device API. Decoding APIs can be called freely inside the device's data callback, but they are not thread safe unless -you do your own synchronization. - -************************************************************************************************************************************************************/ -#ifndef MA_NO_DECODING -typedef struct ma_decoder ma_decoder; - - -typedef struct -{ - ma_format preferredFormat; - ma_uint32 seekPointCount; /* Set to > 0 to generate a seektable if the decoding backend supports it. */ -} ma_decoding_backend_config; - -MA_API ma_decoding_backend_config ma_decoding_backend_config_init(ma_format preferredFormat, ma_uint32 seekPointCount); - - -typedef struct -{ - ma_result (* onInit )(void* pUserData, ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend); - ma_result (* onInitFile )(void* pUserData, const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend); /* Optional. */ - ma_result (* onInitFileW )(void* pUserData, const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend); /* Optional. */ - ma_result (* onInitMemory)(void* pUserData, const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend); /* Optional. */ - void (* onUninit )(void* pUserData, ma_data_source* pBackend, const ma_allocation_callbacks* pAllocationCallbacks); -} ma_decoding_backend_vtable; - - -typedef ma_result (* ma_decoder_read_proc)(ma_decoder* pDecoder, void* pBufferOut, size_t bytesToRead, size_t* pBytesRead); /* Returns the number of bytes read. */ -typedef ma_result (* ma_decoder_seek_proc)(ma_decoder* pDecoder, ma_int64 byteOffset, ma_seek_origin origin); -typedef ma_result (* ma_decoder_tell_proc)(ma_decoder* pDecoder, ma_int64* pCursor); - -typedef struct -{ - ma_format format; /* Set to 0 or ma_format_unknown to use the stream's internal format. */ - ma_uint32 channels; /* Set to 0 to use the stream's internal channels. */ - ma_uint32 sampleRate; /* Set to 0 to use the stream's internal sample rate. */ - ma_channel* pChannelMap; - ma_channel_mix_mode channelMixMode; - ma_dither_mode ditherMode; - ma_resampler_config resampling; - ma_allocation_callbacks allocationCallbacks; - ma_encoding_format encodingFormat; - ma_uint32 seekPointCount; /* When set to > 0, specifies the number of seek points to use for the generation of a seek table. Not all decoding backends support this. */ - ma_decoding_backend_vtable** ppCustomBackendVTables; - ma_uint32 customBackendCount; - void* pCustomBackendUserData; -} ma_decoder_config; - -struct ma_decoder -{ - ma_data_source_base ds; - ma_data_source* pBackend; /* The decoding backend we'll be pulling data from. */ - const ma_decoding_backend_vtable* pBackendVTable; /* The vtable for the decoding backend. This needs to be stored so we can access the onUninit() callback. */ - void* pBackendUserData; - ma_decoder_read_proc onRead; - ma_decoder_seek_proc onSeek; - ma_decoder_tell_proc onTell; - void* pUserData; - ma_uint64 readPointerInPCMFrames; /* In output sample rate. Used for keeping track of how many frames are available for decoding. */ - ma_format outputFormat; - ma_uint32 outputChannels; - ma_uint32 outputSampleRate; - ma_data_converter converter; /* Data conversion is achieved by running frames through this. */ - void* pInputCache; /* In input format. Can be null if it's not needed. */ - ma_uint64 inputCacheCap; /* The capacity of the input cache. */ - ma_uint64 inputCacheConsumed; /* The number of frames that have been consumed in the cache. Used for determining the next valid frame. */ - ma_uint64 inputCacheRemaining; /* The number of valid frames remaining in the cahce. */ - ma_allocation_callbacks allocationCallbacks; - union - { - struct - { - ma_vfs* pVFS; - ma_vfs_file file; - } vfs; - struct - { - const ma_uint8* pData; - size_t dataSize; - size_t currentReadPos; - } memory; /* Only used for decoders that were opened against a block of memory. */ - } data; -}; - -MA_API ma_decoder_config ma_decoder_config_init(ma_format outputFormat, ma_uint32 outputChannels, ma_uint32 outputSampleRate); -MA_API ma_decoder_config ma_decoder_config_init_default(void); - -MA_API ma_result ma_decoder_init(ma_decoder_read_proc onRead, ma_decoder_seek_proc onSeek, void* pUserData, const ma_decoder_config* pConfig, ma_decoder* pDecoder); -MA_API ma_result ma_decoder_init_memory(const void* pData, size_t dataSize, const ma_decoder_config* pConfig, ma_decoder* pDecoder); -MA_API ma_result ma_decoder_init_vfs(ma_vfs* pVFS, const char* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder); -MA_API ma_result ma_decoder_init_vfs_w(ma_vfs* pVFS, const wchar_t* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder); -MA_API ma_result ma_decoder_init_file(const char* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder); -MA_API ma_result ma_decoder_init_file_w(const wchar_t* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder); - -/* -Uninitializes a decoder. -*/ -MA_API ma_result ma_decoder_uninit(ma_decoder* pDecoder); - -/* -Reads PCM frames from the given decoder. - -This is not thread safe without your own synchronization. -*/ -MA_API ma_result ma_decoder_read_pcm_frames(ma_decoder* pDecoder, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); - -/* -Seeks to a PCM frame based on it's absolute index. - -This is not thread safe without your own synchronization. -*/ -MA_API ma_result ma_decoder_seek_to_pcm_frame(ma_decoder* pDecoder, ma_uint64 frameIndex); - -/* -Retrieves the decoder's output data format. -*/ -MA_API ma_result ma_decoder_get_data_format(ma_decoder* pDecoder, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); - -/* -Retrieves the current position of the read cursor in PCM frames. -*/ -MA_API ma_result ma_decoder_get_cursor_in_pcm_frames(ma_decoder* pDecoder, ma_uint64* pCursor); - -/* -Retrieves the length of the decoder in PCM frames. - -Do not call this on streams of an undefined length, such as internet radio. - -If the length is unknown or an error occurs, 0 will be returned. - -This will always return 0 for Vorbis decoders. This is due to a limitation with stb_vorbis in push mode which is what miniaudio -uses internally. - -For MP3's, this will decode the entire file. Do not call this in time critical scenarios. - -This function is not thread safe without your own synchronization. -*/ -MA_API ma_result ma_decoder_get_length_in_pcm_frames(ma_decoder* pDecoder, ma_uint64* pLength); - -/* -Retrieves the number of frames that can be read before reaching the end. - -This calls `ma_decoder_get_length_in_pcm_frames()` so you need to be aware of the rules for that function, in -particular ensuring you do not call it on streams of an undefined length, such as internet radio. - -If the total length of the decoder cannot be retrieved, such as with Vorbis decoders, `MA_NOT_IMPLEMENTED` will be -returned. -*/ -MA_API ma_result ma_decoder_get_available_frames(ma_decoder* pDecoder, ma_uint64* pAvailableFrames); - -/* -Helper for opening and decoding a file into a heap allocated block of memory. Free the returned pointer with ma_free(). On input, -pConfig should be set to what you want. On output it will be set to what you got. -*/ -MA_API ma_result ma_decode_from_vfs(ma_vfs* pVFS, const char* pFilePath, ma_decoder_config* pConfig, ma_uint64* pFrameCountOut, void** ppPCMFramesOut); -MA_API ma_result ma_decode_file(const char* pFilePath, ma_decoder_config* pConfig, ma_uint64* pFrameCountOut, void** ppPCMFramesOut); -MA_API ma_result ma_decode_memory(const void* pData, size_t dataSize, ma_decoder_config* pConfig, ma_uint64* pFrameCountOut, void** ppPCMFramesOut); - -#endif /* MA_NO_DECODING */ - - -/************************************************************************************************************************************************************ - -Encoding -======== - -Encoders do not perform any format conversion for you. If your target format does not support the format, and error will be returned. - -************************************************************************************************************************************************************/ -#ifndef MA_NO_ENCODING -typedef struct ma_encoder ma_encoder; - -typedef ma_result (* ma_encoder_write_proc) (ma_encoder* pEncoder, const void* pBufferIn, size_t bytesToWrite, size_t* pBytesWritten); -typedef ma_result (* ma_encoder_seek_proc) (ma_encoder* pEncoder, ma_int64 offset, ma_seek_origin origin); -typedef ma_result (* ma_encoder_init_proc) (ma_encoder* pEncoder); -typedef void (* ma_encoder_uninit_proc) (ma_encoder* pEncoder); -typedef ma_result (* ma_encoder_write_pcm_frames_proc)(ma_encoder* pEncoder, const void* pFramesIn, ma_uint64 frameCount, ma_uint64* pFramesWritten); - -typedef struct -{ - ma_encoding_format encodingFormat; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_allocation_callbacks allocationCallbacks; -} ma_encoder_config; - -MA_API ma_encoder_config ma_encoder_config_init(ma_encoding_format encodingFormat, ma_format format, ma_uint32 channels, ma_uint32 sampleRate); - -struct ma_encoder -{ - ma_encoder_config config; - ma_encoder_write_proc onWrite; - ma_encoder_seek_proc onSeek; - ma_encoder_init_proc onInit; - ma_encoder_uninit_proc onUninit; - ma_encoder_write_pcm_frames_proc onWritePCMFrames; - void* pUserData; - void* pInternalEncoder; /* <-- The drwav/drflac/stb_vorbis/etc. objects. */ - union - { - struct - { - ma_vfs* pVFS; - ma_vfs_file file; - } vfs; - } data; -}; - -MA_API ma_result ma_encoder_init(ma_encoder_write_proc onWrite, ma_encoder_seek_proc onSeek, void* pUserData, const ma_encoder_config* pConfig, ma_encoder* pEncoder); -MA_API ma_result ma_encoder_init_vfs(ma_vfs* pVFS, const char* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder); -MA_API ma_result ma_encoder_init_vfs_w(ma_vfs* pVFS, const wchar_t* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder); -MA_API ma_result ma_encoder_init_file(const char* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder); -MA_API ma_result ma_encoder_init_file_w(const wchar_t* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder); -MA_API void ma_encoder_uninit(ma_encoder* pEncoder); -MA_API ma_result ma_encoder_write_pcm_frames(ma_encoder* pEncoder, const void* pFramesIn, ma_uint64 frameCount, ma_uint64* pFramesWritten); - -#endif /* MA_NO_ENCODING */ - - -/************************************************************************************************************************************************************ - -Generation - -************************************************************************************************************************************************************/ -#ifndef MA_NO_GENERATION -typedef enum -{ - ma_waveform_type_sine, - ma_waveform_type_square, - ma_waveform_type_triangle, - ma_waveform_type_sawtooth -} ma_waveform_type; - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_waveform_type type; - double amplitude; - double frequency; -} ma_waveform_config; - -MA_API ma_waveform_config ma_waveform_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, ma_waveform_type type, double amplitude, double frequency); - -typedef struct -{ - ma_data_source_base ds; - ma_waveform_config config; - double advance; - double time; -} ma_waveform; - -MA_API ma_result ma_waveform_init(const ma_waveform_config* pConfig, ma_waveform* pWaveform); -MA_API void ma_waveform_uninit(ma_waveform* pWaveform); -MA_API ma_result ma_waveform_read_pcm_frames(ma_waveform* pWaveform, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_waveform_seek_to_pcm_frame(ma_waveform* pWaveform, ma_uint64 frameIndex); -MA_API ma_result ma_waveform_set_amplitude(ma_waveform* pWaveform, double amplitude); -MA_API ma_result ma_waveform_set_frequency(ma_waveform* pWaveform, double frequency); -MA_API ma_result ma_waveform_set_type(ma_waveform* pWaveform, ma_waveform_type type); -MA_API ma_result ma_waveform_set_sample_rate(ma_waveform* pWaveform, ma_uint32 sampleRate); - -typedef enum -{ - ma_noise_type_white, - ma_noise_type_pink, - ma_noise_type_brownian -} ma_noise_type; - - -typedef struct -{ - ma_format format; - ma_uint32 channels; - ma_noise_type type; - ma_int32 seed; - double amplitude; - ma_bool32 duplicateChannels; -} ma_noise_config; - -MA_API ma_noise_config ma_noise_config_init(ma_format format, ma_uint32 channels, ma_noise_type type, ma_int32 seed, double amplitude); - -typedef struct -{ - ma_data_source_vtable ds; - ma_noise_config config; - ma_lcg lcg; - union - { - struct - { - double** bin; - double* accumulation; - ma_uint32* counter; - } pink; - struct - { - double* accumulation; - } brownian; - } state; - - /* Memory management. */ - void* _pHeap; - ma_bool32 _ownsHeap; -} ma_noise; - -MA_API ma_result ma_noise_get_heap_size(const ma_noise_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_noise_init_preallocated(const ma_noise_config* pConfig, void* pHeap, ma_noise* pNoise); -MA_API ma_result ma_noise_init(const ma_noise_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_noise* pNoise); -MA_API void ma_noise_uninit(ma_noise* pNoise, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_noise_read_pcm_frames(ma_noise* pNoise, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_noise_set_amplitude(ma_noise* pNoise, double amplitude); -MA_API ma_result ma_noise_set_seed(ma_noise* pNoise, ma_int32 seed); -MA_API ma_result ma_noise_set_type(ma_noise* pNoise, ma_noise_type type); - -#endif /* MA_NO_GENERATION */ - - - -/************************************************************************************************************************************************************ - -Resource Manager - -************************************************************************************************************************************************************/ -/* The resource manager cannot be enabled if there is no decoder. */ -#if !defined(MA_NO_RESOURCE_MANAGER) && defined(MA_NO_DECODING) -#define MA_NO_RESOURCE_MANAGER -#endif - -#ifndef MA_NO_RESOURCE_MANAGER -typedef struct ma_resource_manager ma_resource_manager; -typedef struct ma_resource_manager_data_buffer_node ma_resource_manager_data_buffer_node; -typedef struct ma_resource_manager_data_buffer ma_resource_manager_data_buffer; -typedef struct ma_resource_manager_data_stream ma_resource_manager_data_stream; -typedef struct ma_resource_manager_data_source ma_resource_manager_data_source; - -typedef enum -{ - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM = 0x00000001, /* When set, does not load the entire data source in memory. Disk I/O will happen on job threads. */ - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE = 0x00000002, /* Decode data before storing in memory. When set, decoding is done at the resource manager level rather than the mixing thread. Results in faster mixing, but higher memory usage. */ - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC = 0x00000004, /* When set, the resource manager will load the data source asynchronously. */ - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT = 0x00000008, /* When set, waits for initialization of the underlying data source before returning from ma_resource_manager_data_source_init(). */ - MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_UNKNOWN_LENGTH = 0x00000010 /* Gives the resource manager a hint that the length of the data source is unknown and calling `ma_data_source_get_length_in_pcm_frames()` should be avoided. */ -} ma_resource_manager_data_source_flags; - - -/* -Pipeline notifications used by the resource manager. Made up of both an async notification and a fence, both of which are optional. -*/ -typedef struct -{ - ma_async_notification* pNotification; - ma_fence* pFence; -} ma_resource_manager_pipeline_stage_notification; - -typedef struct -{ - ma_resource_manager_pipeline_stage_notification init; /* Initialization of the decoder. */ - ma_resource_manager_pipeline_stage_notification done; /* Decoding fully completed. */ -} ma_resource_manager_pipeline_notifications; - -MA_API ma_resource_manager_pipeline_notifications ma_resource_manager_pipeline_notifications_init(void); - - - -/* BEGIN BACKWARDS COMPATIBILITY */ -/* TODO: Remove this block in version 0.12. */ -#if 1 -#define ma_resource_manager_job ma_job -#define ma_resource_manager_job_init ma_job_init -#define MA_JOB_TYPE_RESOURCE_MANAGER_QUEUE_FLAG_NON_BLOCKING MA_JOB_QUEUE_FLAG_NON_BLOCKING -#define ma_resource_manager_job_queue_config ma_job_queue_config -#define ma_resource_manager_job_queue_config_init ma_job_queue_config_init -#define ma_resource_manager_job_queue ma_job_queue -#define ma_resource_manager_job_queue_get_heap_size ma_job_queue_get_heap_size -#define ma_resource_manager_job_queue_init_preallocated ma_job_queue_init_preallocated -#define ma_resource_manager_job_queue_init ma_job_queue_init -#define ma_resource_manager_job_queue_uninit ma_job_queue_uninit -#define ma_resource_manager_job_queue_post ma_job_queue_post -#define ma_resource_manager_job_queue_next ma_job_queue_next -#endif -/* END BACKWARDS COMPATIBILITY */ - - - - -/* Maximum job thread count will be restricted to this, but this may be removed later and replaced with a heap allocation thereby removing any limitation. */ -#ifndef MA_RESOURCE_MANAGER_MAX_JOB_THREAD_COUNT -#define MA_RESOURCE_MANAGER_MAX_JOB_THREAD_COUNT 64 -#endif - -typedef enum -{ - /* Indicates ma_resource_manager_next_job() should not block. Only valid when the job thread count is 0. */ - MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING = 0x00000001, - - /* Disables any kind of multithreading. Implicitly enables MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING. */ - MA_RESOURCE_MANAGER_FLAG_NO_THREADING = 0x00000002 -} ma_resource_manager_flags; - -typedef struct -{ - const char* pFilePath; - const wchar_t* pFilePathW; - const ma_resource_manager_pipeline_notifications* pNotifications; - ma_uint64 initialSeekPointInPCMFrames; - ma_uint64 rangeBegInPCMFrames; - ma_uint64 rangeEndInPCMFrames; - ma_uint64 loopPointBegInPCMFrames; - ma_uint64 loopPointEndInPCMFrames; - ma_bool32 isLooping; - ma_uint32 flags; -} ma_resource_manager_data_source_config; - -MA_API ma_resource_manager_data_source_config ma_resource_manager_data_source_config_init(void); - - -typedef enum -{ - ma_resource_manager_data_supply_type_unknown = 0, /* Used for determining whether or the data supply has been initialized. */ - ma_resource_manager_data_supply_type_encoded, /* Data supply is an encoded buffer. Connector is ma_decoder. */ - ma_resource_manager_data_supply_type_decoded, /* Data supply is a decoded buffer. Connector is ma_audio_buffer. */ - ma_resource_manager_data_supply_type_decoded_paged /* Data supply is a linked list of decoded buffers. Connector is ma_paged_audio_buffer. */ -} ma_resource_manager_data_supply_type; - -typedef struct -{ - MA_ATOMIC(4, ma_resource_manager_data_supply_type) type; /* Read and written from different threads so needs to be accessed atomically. */ - union - { - struct - { - const void* pData; - size_t sizeInBytes; - } encoded; - struct - { - const void* pData; - ma_uint64 totalFrameCount; - ma_uint64 decodedFrameCount; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - } decoded; - struct - { - ma_paged_audio_buffer_data data; - ma_uint64 decodedFrameCount; - ma_uint32 sampleRate; - } decodedPaged; - } backend; -} ma_resource_manager_data_supply; - -struct ma_resource_manager_data_buffer_node -{ - ma_uint32 hashedName32; /* The hashed name. This is the key. */ - ma_uint32 refCount; - MA_ATOMIC(4, ma_result) result; /* Result from asynchronous loading. When loading set to MA_BUSY. When fully loaded set to MA_SUCCESS. When deleting set to MA_UNAVAILABLE. */ - MA_ATOMIC(4, ma_uint32) executionCounter; /* For allocating execution orders for jobs. */ - MA_ATOMIC(4, ma_uint32) executionPointer; /* For managing the order of execution for asynchronous jobs relating to this object. Incremented as jobs complete processing. */ - ma_bool32 isDataOwnedByResourceManager; /* Set to true when the underlying data buffer was allocated the resource manager. Set to false if it is owned by the application (via ma_resource_manager_register_*()). */ - ma_resource_manager_data_supply data; - ma_resource_manager_data_buffer_node* pParent; - ma_resource_manager_data_buffer_node* pChildLo; - ma_resource_manager_data_buffer_node* pChildHi; -}; - -struct ma_resource_manager_data_buffer -{ - ma_data_source_base ds; /* Base data source. A data buffer is a data source. */ - ma_resource_manager* pResourceManager; /* A pointer to the resource manager that owns this buffer. */ - ma_resource_manager_data_buffer_node* pNode; /* The data node. This is reference counted and is what supplies the data. */ - ma_uint32 flags; /* The flags that were passed used to initialize the buffer. */ - MA_ATOMIC(4, ma_uint32) executionCounter; /* For allocating execution orders for jobs. */ - MA_ATOMIC(4, ma_uint32) executionPointer; /* For managing the order of execution for asynchronous jobs relating to this object. Incremented as jobs complete processing. */ - ma_uint64 seekTargetInPCMFrames; /* Only updated by the public API. Never written nor read from the job thread. */ - ma_bool32 seekToCursorOnNextRead; /* On the next read we need to seek to the frame cursor. */ - MA_ATOMIC(4, ma_result) result; /* Keeps track of a result of decoding. Set to MA_BUSY while the buffer is still loading. Set to MA_SUCCESS when loading is finished successfully. Otherwise set to some other code. */ - MA_ATOMIC(4, ma_bool32) isLooping; /* Can be read and written by different threads at the same time. Must be used atomically. */ - ma_atomic_bool32 isConnectorInitialized; /* Used for asynchronous loading to ensure we don't try to initialize the connector multiple times while waiting for the node to fully load. */ - union - { - ma_decoder decoder; /* Supply type is ma_resource_manager_data_supply_type_encoded */ - ma_audio_buffer buffer; /* Supply type is ma_resource_manager_data_supply_type_decoded */ - ma_paged_audio_buffer pagedBuffer; /* Supply type is ma_resource_manager_data_supply_type_decoded_paged */ - } connector; /* Connects this object to the node's data supply. */ -}; - -struct ma_resource_manager_data_stream -{ - ma_data_source_base ds; /* Base data source. A data stream is a data source. */ - ma_resource_manager* pResourceManager; /* A pointer to the resource manager that owns this data stream. */ - ma_uint32 flags; /* The flags that were passed used to initialize the stream. */ - ma_decoder decoder; /* Used for filling pages with data. This is only ever accessed by the job thread. The public API should never touch this. */ - ma_bool32 isDecoderInitialized; /* Required for determining whether or not the decoder should be uninitialized in MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_STREAM. */ - ma_uint64 totalLengthInPCMFrames; /* This is calculated when first loaded by the MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_STREAM. */ - ma_uint32 relativeCursor; /* The playback cursor, relative to the current page. Only ever accessed by the public API. Never accessed by the job thread. */ - MA_ATOMIC(8, ma_uint64) absoluteCursor; /* The playback cursor, in absolute position starting from the start of the file. */ - ma_uint32 currentPageIndex; /* Toggles between 0 and 1. Index 0 is the first half of pPageData. Index 1 is the second half. Only ever accessed by the public API. Never accessed by the job thread. */ - MA_ATOMIC(4, ma_uint32) executionCounter; /* For allocating execution orders for jobs. */ - MA_ATOMIC(4, ma_uint32) executionPointer; /* For managing the order of execution for asynchronous jobs relating to this object. Incremented as jobs complete processing. */ - - /* Written by the public API, read by the job thread. */ - MA_ATOMIC(4, ma_bool32) isLooping; /* Whether or not the stream is looping. It's important to set the looping flag at the data stream level for smooth loop transitions. */ - - /* Written by the job thread, read by the public API. */ - void* pPageData; /* Buffer containing the decoded data of each page. Allocated once at initialization time. */ - MA_ATOMIC(4, ma_uint32) pageFrameCount[2]; /* The number of valid PCM frames in each page. Used to determine the last valid frame. */ - - /* Written and read by both the public API and the job thread. These must be atomic. */ - MA_ATOMIC(4, ma_result) result; /* Result from asynchronous loading. When loading set to MA_BUSY. When initialized set to MA_SUCCESS. When deleting set to MA_UNAVAILABLE. If an error occurs when loading, set to an error code. */ - MA_ATOMIC(4, ma_bool32) isDecoderAtEnd; /* Whether or not the decoder has reached the end. */ - MA_ATOMIC(4, ma_bool32) isPageValid[2]; /* Booleans to indicate whether or not a page is valid. Set to false by the public API, set to true by the job thread. Set to false as the pages are consumed, true when they are filled. */ - MA_ATOMIC(4, ma_bool32) seekCounter; /* When 0, no seeking is being performed. When > 0, a seek is being performed and reading should be delayed with MA_BUSY. */ -}; - -struct ma_resource_manager_data_source -{ - union - { - ma_resource_manager_data_buffer buffer; - ma_resource_manager_data_stream stream; - } backend; /* Must be the first item because we need the first item to be the data source callbacks for the buffer or stream. */ - - ma_uint32 flags; /* The flags that were passed in to ma_resource_manager_data_source_init(). */ - MA_ATOMIC(4, ma_uint32) executionCounter; /* For allocating execution orders for jobs. */ - MA_ATOMIC(4, ma_uint32) executionPointer; /* For managing the order of execution for asynchronous jobs relating to this object. Incremented as jobs complete processing. */ -}; - -typedef struct -{ - ma_allocation_callbacks allocationCallbacks; - ma_log* pLog; - ma_format decodedFormat; /* The decoded format to use. Set to ma_format_unknown (default) to use the file's native format. */ - ma_uint32 decodedChannels; /* The decoded channel count to use. Set to 0 (default) to use the file's native channel count. */ - ma_uint32 decodedSampleRate; /* the decoded sample rate to use. Set to 0 (default) to use the file's native sample rate. */ - ma_uint32 jobThreadCount; /* Set to 0 if you want to self-manage your job threads. Defaults to 1. */ - size_t jobThreadStackSize; - ma_uint32 jobQueueCapacity; /* The maximum number of jobs that can fit in the queue at a time. Defaults to MA_JOB_TYPE_RESOURCE_MANAGER_QUEUE_CAPACITY. Cannot be zero. */ - ma_uint32 flags; - ma_vfs* pVFS; /* Can be NULL in which case defaults will be used. */ - ma_decoding_backend_vtable** ppCustomDecodingBackendVTables; - ma_uint32 customDecodingBackendCount; - void* pCustomDecodingBackendUserData; -} ma_resource_manager_config; - -MA_API ma_resource_manager_config ma_resource_manager_config_init(void); - -struct ma_resource_manager -{ - ma_resource_manager_config config; - ma_resource_manager_data_buffer_node* pRootDataBufferNode; /* The root buffer in the binary tree. */ -#ifndef MA_NO_THREADING - ma_mutex dataBufferBSTLock; /* For synchronizing access to the data buffer binary tree. */ - ma_thread jobThreads[MA_RESOURCE_MANAGER_MAX_JOB_THREAD_COUNT]; /* The threads for executing jobs. */ -#endif - ma_job_queue jobQueue; /* Multi-consumer, multi-producer job queue for managing jobs for asynchronous decoding and streaming. */ - ma_default_vfs defaultVFS; /* Only used if a custom VFS is not specified. */ - ma_log log; /* Only used if no log was specified in the config. */ -}; - -/* Init. */ -MA_API ma_result ma_resource_manager_init(const ma_resource_manager_config* pConfig, ma_resource_manager* pResourceManager); -MA_API void ma_resource_manager_uninit(ma_resource_manager* pResourceManager); -MA_API ma_log* ma_resource_manager_get_log(ma_resource_manager* pResourceManager); - -/* Registration. */ -MA_API ma_result ma_resource_manager_register_file(ma_resource_manager* pResourceManager, const char* pFilePath, ma_uint32 flags); -MA_API ma_result ma_resource_manager_register_file_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath, ma_uint32 flags); -MA_API ma_result ma_resource_manager_register_decoded_data(ma_resource_manager* pResourceManager, const char* pName, const void* pData, ma_uint64 frameCount, ma_format format, ma_uint32 channels, ma_uint32 sampleRate); /* Does not copy. Increments the reference count if already exists and returns MA_SUCCESS. */ -MA_API ma_result ma_resource_manager_register_decoded_data_w(ma_resource_manager* pResourceManager, const wchar_t* pName, const void* pData, ma_uint64 frameCount, ma_format format, ma_uint32 channels, ma_uint32 sampleRate); -MA_API ma_result ma_resource_manager_register_encoded_data(ma_resource_manager* pResourceManager, const char* pName, const void* pData, size_t sizeInBytes); /* Does not copy. Increments the reference count if already exists and returns MA_SUCCESS. */ -MA_API ma_result ma_resource_manager_register_encoded_data_w(ma_resource_manager* pResourceManager, const wchar_t* pName, const void* pData, size_t sizeInBytes); -MA_API ma_result ma_resource_manager_unregister_file(ma_resource_manager* pResourceManager, const char* pFilePath); -MA_API ma_result ma_resource_manager_unregister_file_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath); -MA_API ma_result ma_resource_manager_unregister_data(ma_resource_manager* pResourceManager, const char* pName); -MA_API ma_result ma_resource_manager_unregister_data_w(ma_resource_manager* pResourceManager, const wchar_t* pName); - -/* Data Buffers. */ -MA_API ma_result ma_resource_manager_data_buffer_init_ex(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_init(ma_resource_manager* pResourceManager, const char* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_init_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_init_copy(ma_resource_manager* pResourceManager, const ma_resource_manager_data_buffer* pExistingDataBuffer, ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_uninit(ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_read_pcm_frames(ma_resource_manager_data_buffer* pDataBuffer, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_resource_manager_data_buffer_seek_to_pcm_frame(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64 frameIndex); -MA_API ma_result ma_resource_manager_data_buffer_get_data_format(ma_resource_manager_data_buffer* pDataBuffer, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_resource_manager_data_buffer_get_cursor_in_pcm_frames(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64* pCursor); -MA_API ma_result ma_resource_manager_data_buffer_get_length_in_pcm_frames(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64* pLength); -MA_API ma_result ma_resource_manager_data_buffer_result(const ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_set_looping(ma_resource_manager_data_buffer* pDataBuffer, ma_bool32 isLooping); -MA_API ma_bool32 ma_resource_manager_data_buffer_is_looping(const ma_resource_manager_data_buffer* pDataBuffer); -MA_API ma_result ma_resource_manager_data_buffer_get_available_frames(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64* pAvailableFrames); - -/* Data Streams. */ -MA_API ma_result ma_resource_manager_data_stream_init_ex(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_stream* pDataStream); -MA_API ma_result ma_resource_manager_data_stream_init(ma_resource_manager* pResourceManager, const char* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_stream* pDataStream); -MA_API ma_result ma_resource_manager_data_stream_init_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_stream* pDataStream); -MA_API ma_result ma_resource_manager_data_stream_uninit(ma_resource_manager_data_stream* pDataStream); -MA_API ma_result ma_resource_manager_data_stream_read_pcm_frames(ma_resource_manager_data_stream* pDataStream, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_resource_manager_data_stream_seek_to_pcm_frame(ma_resource_manager_data_stream* pDataStream, ma_uint64 frameIndex); -MA_API ma_result ma_resource_manager_data_stream_get_data_format(ma_resource_manager_data_stream* pDataStream, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_resource_manager_data_stream_get_cursor_in_pcm_frames(ma_resource_manager_data_stream* pDataStream, ma_uint64* pCursor); -MA_API ma_result ma_resource_manager_data_stream_get_length_in_pcm_frames(ma_resource_manager_data_stream* pDataStream, ma_uint64* pLength); -MA_API ma_result ma_resource_manager_data_stream_result(const ma_resource_manager_data_stream* pDataStream); -MA_API ma_result ma_resource_manager_data_stream_set_looping(ma_resource_manager_data_stream* pDataStream, ma_bool32 isLooping); -MA_API ma_bool32 ma_resource_manager_data_stream_is_looping(const ma_resource_manager_data_stream* pDataStream); -MA_API ma_result ma_resource_manager_data_stream_get_available_frames(ma_resource_manager_data_stream* pDataStream, ma_uint64* pAvailableFrames); - -/* Data Sources. */ -MA_API ma_result ma_resource_manager_data_source_init_ex(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_init(ma_resource_manager* pResourceManager, const char* pName, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_init_w(ma_resource_manager* pResourceManager, const wchar_t* pName, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_init_copy(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source* pExistingDataSource, ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_uninit(ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_read_pcm_frames(ma_resource_manager_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_resource_manager_data_source_seek_to_pcm_frame(ma_resource_manager_data_source* pDataSource, ma_uint64 frameIndex); -MA_API ma_result ma_resource_manager_data_source_get_data_format(ma_resource_manager_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_resource_manager_data_source_get_cursor_in_pcm_frames(ma_resource_manager_data_source* pDataSource, ma_uint64* pCursor); -MA_API ma_result ma_resource_manager_data_source_get_length_in_pcm_frames(ma_resource_manager_data_source* pDataSource, ma_uint64* pLength); -MA_API ma_result ma_resource_manager_data_source_result(const ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_set_looping(ma_resource_manager_data_source* pDataSource, ma_bool32 isLooping); -MA_API ma_bool32 ma_resource_manager_data_source_is_looping(const ma_resource_manager_data_source* pDataSource); -MA_API ma_result ma_resource_manager_data_source_get_available_frames(ma_resource_manager_data_source* pDataSource, ma_uint64* pAvailableFrames); - -/* Job management. */ -MA_API ma_result ma_resource_manager_post_job(ma_resource_manager* pResourceManager, const ma_job* pJob); -MA_API ma_result ma_resource_manager_post_job_quit(ma_resource_manager* pResourceManager); /* Helper for posting a quit job. */ -MA_API ma_result ma_resource_manager_next_job(ma_resource_manager* pResourceManager, ma_job* pJob); -MA_API ma_result ma_resource_manager_process_job(ma_resource_manager* pResourceManager, ma_job* pJob); /* DEPRECATED. Use ma_job_process(). Will be removed in version 0.12. */ -MA_API ma_result ma_resource_manager_process_next_job(ma_resource_manager* pResourceManager); /* Returns MA_CANCELLED if a MA_JOB_TYPE_QUIT job is found. In non-blocking mode, returns MA_NO_DATA_AVAILABLE if no jobs are available. */ -#endif /* MA_NO_RESOURCE_MANAGER */ - - - -/************************************************************************************************************************************************************ - -Node Graph - -************************************************************************************************************************************************************/ -#ifndef MA_NO_NODE_GRAPH -/* Must never exceed 254. */ -#ifndef MA_MAX_NODE_BUS_COUNT -#define MA_MAX_NODE_BUS_COUNT 254 -#endif - -/* Used internally by miniaudio for memory management. Must never exceed MA_MAX_NODE_BUS_COUNT. */ -#ifndef MA_MAX_NODE_LOCAL_BUS_COUNT -#define MA_MAX_NODE_LOCAL_BUS_COUNT 2 -#endif - -/* Use this when the bus count is determined by the node instance rather than the vtable. */ -#define MA_NODE_BUS_COUNT_UNKNOWN 255 - -typedef struct ma_node_graph ma_node_graph; -typedef void ma_node; - - -/* Node flags. */ -typedef enum -{ - MA_NODE_FLAG_PASSTHROUGH = 0x00000001, - MA_NODE_FLAG_CONTINUOUS_PROCESSING = 0x00000002, - MA_NODE_FLAG_ALLOW_NULL_INPUT = 0x00000004, - MA_NODE_FLAG_DIFFERENT_PROCESSING_RATES = 0x00000008, - MA_NODE_FLAG_SILENT_OUTPUT = 0x00000010 -} ma_node_flags; - - -/* The playback state of a node. Either started or stopped. */ -typedef enum -{ - ma_node_state_started = 0, - ma_node_state_stopped = 1 -} ma_node_state; - - -typedef struct -{ - /* - Extended processing callback. This callback is used for effects that process input and output - at different rates (i.e. they perform resampling). This is similar to the simple version, only - they take two seperate frame counts: one for input, and one for output. - - On input, `pFrameCountOut` is equal to the capacity of the output buffer for each bus, whereas - `pFrameCountIn` will be equal to the number of PCM frames in each of the buffers in `ppFramesIn`. - - On output, set `pFrameCountOut` to the number of PCM frames that were actually output and set - `pFrameCountIn` to the number of input frames that were consumed. - */ - void (* onProcess)(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut); - - /* - A callback for retrieving the number of a input frames that are required to output the - specified number of output frames. You would only want to implement this when the node performs - resampling. This is optional, even for nodes that perform resampling, but it does offer a - small reduction in latency as it allows miniaudio to calculate the exact number of input frames - to read at a time instead of having to estimate. - */ - ma_result (* onGetRequiredInputFrameCount)(ma_node* pNode, ma_uint32 outputFrameCount, ma_uint32* pInputFrameCount); - - /* - The number of input buses. This is how many sub-buffers will be contained in the `ppFramesIn` - parameters of the callbacks above. - */ - ma_uint8 inputBusCount; - - /* - The number of output buses. This is how many sub-buffers will be contained in the `ppFramesOut` - parameters of the callbacks above. - */ - ma_uint8 outputBusCount; - - /* - Flags describing characteristics of the node. This is currently just a placeholder for some - ideas for later on. - */ - ma_uint32 flags; -} ma_node_vtable; - -typedef struct -{ - const ma_node_vtable* vtable; /* Should never be null. Initialization of the node will fail if so. */ - ma_node_state initialState; /* Defaults to ma_node_state_started. */ - ma_uint32 inputBusCount; /* Only used if the vtable specifies an input bus count of `MA_NODE_BUS_COUNT_UNKNOWN`, otherwise must be set to `MA_NODE_BUS_COUNT_UNKNOWN` (default). */ - ma_uint32 outputBusCount; /* Only used if the vtable specifies an output bus count of `MA_NODE_BUS_COUNT_UNKNOWN`, otherwise be set to `MA_NODE_BUS_COUNT_UNKNOWN` (default). */ - const ma_uint32* pInputChannels; /* The number of elements are determined by the input bus count as determined by the vtable, or `inputBusCount` if the vtable specifies `MA_NODE_BUS_COUNT_UNKNOWN`. */ - const ma_uint32* pOutputChannels; /* The number of elements are determined by the output bus count as determined by the vtable, or `outputBusCount` if the vtable specifies `MA_NODE_BUS_COUNT_UNKNOWN`. */ -} ma_node_config; - -MA_API ma_node_config ma_node_config_init(void); - - -/* -A node has multiple output buses. An output bus is attached to an input bus as an item in a linked -list. Think of the input bus as a linked list, with the output bus being an item in that list. -*/ -typedef struct ma_node_output_bus ma_node_output_bus; -struct ma_node_output_bus -{ - /* Immutable. */ - ma_node* pNode; /* The node that owns this output bus. The input node. Will be null for dummy head and tail nodes. */ - ma_uint8 outputBusIndex; /* The index of the output bus on pNode that this output bus represents. */ - ma_uint8 channels; /* The number of channels in the audio stream for this bus. */ - - /* Mutable via multiple threads. Must be used atomically. The weird ordering here is for packing reasons. */ - ma_uint8 inputNodeInputBusIndex; /* The index of the input bus on the input. Required for detaching. Will only be used within the spinlock so does not need to be atomic. */ - MA_ATOMIC(4, ma_uint32) flags; /* Some state flags for tracking the read state of the output buffer. A combination of MA_NODE_OUTPUT_BUS_FLAG_*. */ - MA_ATOMIC(4, ma_uint32) refCount; /* Reference count for some thread-safety when detaching. */ - MA_ATOMIC(4, ma_bool32) isAttached; /* This is used to prevent iteration of nodes that are in the middle of being detached. Used for thread safety. */ - MA_ATOMIC(4, ma_spinlock) lock; /* Unfortunate lock, but significantly simplifies the implementation. Required for thread-safe attaching and detaching. */ - MA_ATOMIC(4, float) volume; /* Linear. */ - MA_ATOMIC(MA_SIZEOF_PTR, ma_node_output_bus*) pNext; /* If null, it's the tail node or detached. */ - MA_ATOMIC(MA_SIZEOF_PTR, ma_node_output_bus*) pPrev; /* If null, it's the head node or detached. */ - MA_ATOMIC(MA_SIZEOF_PTR, ma_node*) pInputNode; /* The node that this output bus is attached to. Required for detaching. */ -}; - -/* -A node has multiple input buses. The output buses of a node are connecting to the input busses of -another. An input bus is essentially just a linked list of output buses. -*/ -typedef struct ma_node_input_bus ma_node_input_bus; -struct ma_node_input_bus -{ - /* Mutable via multiple threads. */ - ma_node_output_bus head; /* Dummy head node for simplifying some lock-free thread-safety stuff. */ - MA_ATOMIC(4, ma_uint32) nextCounter; /* This is used to determine whether or not the input bus is finding the next node in the list. Used for thread safety when detaching output buses. */ - MA_ATOMIC(4, ma_spinlock) lock; /* Unfortunate lock, but significantly simplifies the implementation. Required for thread-safe attaching and detaching. */ - - /* Set once at startup. */ - ma_uint8 channels; /* The number of channels in the audio stream for this bus. */ -}; - - -typedef struct ma_node_base ma_node_base; -struct ma_node_base -{ - /* These variables are set once at startup. */ - ma_node_graph* pNodeGraph; /* The graph this node belongs to. */ - const ma_node_vtable* vtable; - float* pCachedData; /* Allocated on the heap. Fixed size. Needs to be stored on the heap because reading from output buses is done in separate function calls. */ - ma_uint16 cachedDataCapInFramesPerBus; /* The capacity of the input data cache in frames, per bus. */ - - /* These variables are read and written only from the audio thread. */ - ma_uint16 cachedFrameCountOut; - ma_uint16 cachedFrameCountIn; - ma_uint16 consumedFrameCountIn; - - /* These variables are read and written between different threads. */ - MA_ATOMIC(4, ma_node_state) state; /* When set to stopped, nothing will be read, regardless of the times in stateTimes. */ - MA_ATOMIC(8, ma_uint64) stateTimes[2]; /* Indexed by ma_node_state. Specifies the time based on the global clock that a node should be considered to be in the relevant state. */ - MA_ATOMIC(8, ma_uint64) localTime; /* The node's local clock. This is just a running sum of the number of output frames that have been processed. Can be modified by any thread with `ma_node_set_time()`. */ - ma_uint32 inputBusCount; - ma_uint32 outputBusCount; - ma_node_input_bus* pInputBuses; - ma_node_output_bus* pOutputBuses; - - /* Memory management. */ - ma_node_input_bus _inputBuses[MA_MAX_NODE_LOCAL_BUS_COUNT]; - ma_node_output_bus _outputBuses[MA_MAX_NODE_LOCAL_BUS_COUNT]; - void* _pHeap; /* A heap allocation for internal use only. pInputBuses and/or pOutputBuses will point to this if the bus count exceeds MA_MAX_NODE_LOCAL_BUS_COUNT. */ - ma_bool32 _ownsHeap; /* If set to true, the node owns the heap allocation and _pHeap will be freed in ma_node_uninit(). */ -}; - -MA_API ma_result ma_node_get_heap_size(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_node_init_preallocated(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, void* pHeap, ma_node* pNode); -MA_API ma_result ma_node_init(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_node* pNode); -MA_API void ma_node_uninit(ma_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_node_graph* ma_node_get_node_graph(const ma_node* pNode); -MA_API ma_uint32 ma_node_get_input_bus_count(const ma_node* pNode); -MA_API ma_uint32 ma_node_get_output_bus_count(const ma_node* pNode); -MA_API ma_uint32 ma_node_get_input_channels(const ma_node* pNode, ma_uint32 inputBusIndex); -MA_API ma_uint32 ma_node_get_output_channels(const ma_node* pNode, ma_uint32 outputBusIndex); -MA_API ma_result ma_node_attach_output_bus(ma_node* pNode, ma_uint32 outputBusIndex, ma_node* pOtherNode, ma_uint32 otherNodeInputBusIndex); -MA_API ma_result ma_node_detach_output_bus(ma_node* pNode, ma_uint32 outputBusIndex); -MA_API ma_result ma_node_detach_all_output_buses(ma_node* pNode); -MA_API ma_result ma_node_set_output_bus_volume(ma_node* pNode, ma_uint32 outputBusIndex, float volume); -MA_API float ma_node_get_output_bus_volume(const ma_node* pNode, ma_uint32 outputBusIndex); -MA_API ma_result ma_node_set_state(ma_node* pNode, ma_node_state state); -MA_API ma_node_state ma_node_get_state(const ma_node* pNode); -MA_API ma_result ma_node_set_state_time(ma_node* pNode, ma_node_state state, ma_uint64 globalTime); -MA_API ma_uint64 ma_node_get_state_time(const ma_node* pNode, ma_node_state state); -MA_API ma_node_state ma_node_get_state_by_time(const ma_node* pNode, ma_uint64 globalTime); -MA_API ma_node_state ma_node_get_state_by_time_range(const ma_node* pNode, ma_uint64 globalTimeBeg, ma_uint64 globalTimeEnd); -MA_API ma_uint64 ma_node_get_time(const ma_node* pNode); -MA_API ma_result ma_node_set_time(ma_node* pNode, ma_uint64 localTime); - - -typedef struct -{ - ma_uint32 channels; - ma_uint16 nodeCacheCapInFrames; -} ma_node_graph_config; - -MA_API ma_node_graph_config ma_node_graph_config_init(ma_uint32 channels); - - -struct ma_node_graph -{ - /* Immutable. */ - ma_node_base base; /* The node graph itself is a node so it can be connected as an input to different node graph. This has zero inputs and calls ma_node_graph_read_pcm_frames() to generate it's output. */ - ma_node_base endpoint; /* Special node that all nodes eventually connect to. Data is read from this node in ma_node_graph_read_pcm_frames(). */ - ma_uint16 nodeCacheCapInFrames; - - /* Read and written by multiple threads. */ - MA_ATOMIC(4, ma_bool32) isReading; -}; - -MA_API ma_result ma_node_graph_init(const ma_node_graph_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_node_graph* pNodeGraph); -MA_API void ma_node_graph_uninit(ma_node_graph* pNodeGraph, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_node* ma_node_graph_get_endpoint(ma_node_graph* pNodeGraph); -MA_API ma_result ma_node_graph_read_pcm_frames(ma_node_graph* pNodeGraph, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_uint32 ma_node_graph_get_channels(const ma_node_graph* pNodeGraph); -MA_API ma_uint64 ma_node_graph_get_time(const ma_node_graph* pNodeGraph); -MA_API ma_result ma_node_graph_set_time(ma_node_graph* pNodeGraph, ma_uint64 globalTime); - - - -/* Data source node. 0 input buses, 1 output bus. Used for reading from a data source. */ -typedef struct -{ - ma_node_config nodeConfig; - ma_data_source* pDataSource; -} ma_data_source_node_config; - -MA_API ma_data_source_node_config ma_data_source_node_config_init(ma_data_source* pDataSource); - - -typedef struct -{ - ma_node_base base; - ma_data_source* pDataSource; -} ma_data_source_node; - -MA_API ma_result ma_data_source_node_init(ma_node_graph* pNodeGraph, const ma_data_source_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source_node* pDataSourceNode); -MA_API void ma_data_source_node_uninit(ma_data_source_node* pDataSourceNode, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_data_source_node_set_looping(ma_data_source_node* pDataSourceNode, ma_bool32 isLooping); -MA_API ma_bool32 ma_data_source_node_is_looping(ma_data_source_node* pDataSourceNode); - - -/* Splitter Node. 1 input, many outputs. Used for splitting/copying a stream so it can be as input into two separate output nodes. */ -typedef struct -{ - ma_node_config nodeConfig; - ma_uint32 channels; - ma_uint32 outputBusCount; -} ma_splitter_node_config; - -MA_API ma_splitter_node_config ma_splitter_node_config_init(ma_uint32 channels); - - -typedef struct -{ - ma_node_base base; -} ma_splitter_node; - -MA_API ma_result ma_splitter_node_init(ma_node_graph* pNodeGraph, const ma_splitter_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_splitter_node* pSplitterNode); -MA_API void ma_splitter_node_uninit(ma_splitter_node* pSplitterNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -Biquad Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_biquad_config biquad; -} ma_biquad_node_config; - -MA_API ma_biquad_node_config ma_biquad_node_config_init(ma_uint32 channels, float b0, float b1, float b2, float a0, float a1, float a2); - - -typedef struct -{ - ma_node_base baseNode; - ma_biquad biquad; -} ma_biquad_node; - -MA_API ma_result ma_biquad_node_init(ma_node_graph* pNodeGraph, const ma_biquad_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_biquad_node* pNode); -MA_API ma_result ma_biquad_node_reinit(const ma_biquad_config* pConfig, ma_biquad_node* pNode); -MA_API void ma_biquad_node_uninit(ma_biquad_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -Low Pass Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_lpf_config lpf; -} ma_lpf_node_config; - -MA_API ma_lpf_node_config ma_lpf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order); - - -typedef struct -{ - ma_node_base baseNode; - ma_lpf lpf; -} ma_lpf_node; - -MA_API ma_result ma_lpf_node_init(ma_node_graph* pNodeGraph, const ma_lpf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf_node* pNode); -MA_API ma_result ma_lpf_node_reinit(const ma_lpf_config* pConfig, ma_lpf_node* pNode); -MA_API void ma_lpf_node_uninit(ma_lpf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -High Pass Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_hpf_config hpf; -} ma_hpf_node_config; - -MA_API ma_hpf_node_config ma_hpf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order); - - -typedef struct -{ - ma_node_base baseNode; - ma_hpf hpf; -} ma_hpf_node; - -MA_API ma_result ma_hpf_node_init(ma_node_graph* pNodeGraph, const ma_hpf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf_node* pNode); -MA_API ma_result ma_hpf_node_reinit(const ma_hpf_config* pConfig, ma_hpf_node* pNode); -MA_API void ma_hpf_node_uninit(ma_hpf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -Band Pass Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_bpf_config bpf; -} ma_bpf_node_config; - -MA_API ma_bpf_node_config ma_bpf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order); - - -typedef struct -{ - ma_node_base baseNode; - ma_bpf bpf; -} ma_bpf_node; - -MA_API ma_result ma_bpf_node_init(ma_node_graph* pNodeGraph, const ma_bpf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_bpf_node* pNode); -MA_API ma_result ma_bpf_node_reinit(const ma_bpf_config* pConfig, ma_bpf_node* pNode); -MA_API void ma_bpf_node_uninit(ma_bpf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -Notching Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_notch_config notch; -} ma_notch_node_config; - -MA_API ma_notch_node_config ma_notch_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double q, double frequency); - - -typedef struct -{ - ma_node_base baseNode; - ma_notch2 notch; -} ma_notch_node; - -MA_API ma_result ma_notch_node_init(ma_node_graph* pNodeGraph, const ma_notch_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_notch_node* pNode); -MA_API ma_result ma_notch_node_reinit(const ma_notch_config* pConfig, ma_notch_node* pNode); -MA_API void ma_notch_node_uninit(ma_notch_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -Peaking Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_peak_config peak; -} ma_peak_node_config; - -MA_API ma_peak_node_config ma_peak_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency); - - -typedef struct -{ - ma_node_base baseNode; - ma_peak2 peak; -} ma_peak_node; - -MA_API ma_result ma_peak_node_init(ma_node_graph* pNodeGraph, const ma_peak_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_peak_node* pNode); -MA_API ma_result ma_peak_node_reinit(const ma_peak_config* pConfig, ma_peak_node* pNode); -MA_API void ma_peak_node_uninit(ma_peak_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -Low Shelf Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_loshelf_config loshelf; -} ma_loshelf_node_config; - -MA_API ma_loshelf_node_config ma_loshelf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency); - - -typedef struct -{ - ma_node_base baseNode; - ma_loshelf2 loshelf; -} ma_loshelf_node; - -MA_API ma_result ma_loshelf_node_init(ma_node_graph* pNodeGraph, const ma_loshelf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_loshelf_node* pNode); -MA_API ma_result ma_loshelf_node_reinit(const ma_loshelf_config* pConfig, ma_loshelf_node* pNode); -MA_API void ma_loshelf_node_uninit(ma_loshelf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -/* -High Shelf Filter Node -*/ -typedef struct -{ - ma_node_config nodeConfig; - ma_hishelf_config hishelf; -} ma_hishelf_node_config; - -MA_API ma_hishelf_node_config ma_hishelf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency); - - -typedef struct -{ - ma_node_base baseNode; - ma_hishelf2 hishelf; -} ma_hishelf_node; - -MA_API ma_result ma_hishelf_node_init(ma_node_graph* pNodeGraph, const ma_hishelf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hishelf_node* pNode); -MA_API ma_result ma_hishelf_node_reinit(const ma_hishelf_config* pConfig, ma_hishelf_node* pNode); -MA_API void ma_hishelf_node_uninit(ma_hishelf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -typedef struct -{ - ma_node_config nodeConfig; - ma_delay_config delay; -} ma_delay_node_config; - -MA_API ma_delay_node_config ma_delay_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, ma_uint32 delayInFrames, float decay); - - -typedef struct -{ - ma_node_base baseNode; - ma_delay delay; -} ma_delay_node; - -MA_API ma_result ma_delay_node_init(ma_node_graph* pNodeGraph, const ma_delay_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_delay_node* pDelayNode); -MA_API void ma_delay_node_uninit(ma_delay_node* pDelayNode, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API void ma_delay_node_set_wet(ma_delay_node* pDelayNode, float value); -MA_API float ma_delay_node_get_wet(const ma_delay_node* pDelayNode); -MA_API void ma_delay_node_set_dry(ma_delay_node* pDelayNode, float value); -MA_API float ma_delay_node_get_dry(const ma_delay_node* pDelayNode); -MA_API void ma_delay_node_set_decay(ma_delay_node* pDelayNode, float value); -MA_API float ma_delay_node_get_decay(const ma_delay_node* pDelayNode); -#endif /* MA_NO_NODE_GRAPH */ - - -/* SECTION: miniaudio_engine.h */ -/************************************************************************************************************************************************************ - -Engine - -************************************************************************************************************************************************************/ -#if !defined(MA_NO_ENGINE) && !defined(MA_NO_NODE_GRAPH) -typedef struct ma_engine ma_engine; -typedef struct ma_sound ma_sound; - - -/* Sound flags. */ -typedef enum -{ - MA_SOUND_FLAG_STREAM = 0x00000001, /* MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM */ - MA_SOUND_FLAG_DECODE = 0x00000002, /* MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE */ - MA_SOUND_FLAG_ASYNC = 0x00000004, /* MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC */ - MA_SOUND_FLAG_WAIT_INIT = 0x00000008, /* MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT */ - MA_SOUND_FLAG_NO_DEFAULT_ATTACHMENT = 0x00000010, /* Do not attach to the endpoint by default. Useful for when setting up nodes in a complex graph system. */ - MA_SOUND_FLAG_NO_PITCH = 0x00000020, /* Disable pitch shifting with ma_sound_set_pitch() and ma_sound_group_set_pitch(). This is an optimization. */ - MA_SOUND_FLAG_NO_SPATIALIZATION = 0x00000040 /* Disable spatialization. */ -} ma_sound_flags; - -#ifndef MA_ENGINE_MAX_LISTENERS -#define MA_ENGINE_MAX_LISTENERS 4 -#endif - -#define MA_LISTENER_INDEX_CLOSEST ((ma_uint8)-1) - -typedef enum -{ - ma_engine_node_type_sound, - ma_engine_node_type_group -} ma_engine_node_type; - -typedef struct -{ - ma_engine* pEngine; - ma_engine_node_type type; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_uint32 sampleRate; /* Only used when the type is set to ma_engine_node_type_sound. */ - ma_mono_expansion_mode monoExpansionMode; - ma_bool8 isPitchDisabled; /* Pitching can be explicitly disabled with MA_SOUND_FLAG_NO_PITCH to optimize processing. */ - ma_bool8 isSpatializationDisabled; /* Spatialization can be explicitly disabled with MA_SOUND_FLAG_NO_SPATIALIZATION. */ - ma_uint8 pinnedListenerIndex; /* The index of the listener this node should always use for spatialization. If set to MA_LISTENER_INDEX_CLOSEST the engine will use the closest listener. */ -} ma_engine_node_config; - -MA_API ma_engine_node_config ma_engine_node_config_init(ma_engine* pEngine, ma_engine_node_type type, ma_uint32 flags); - - -/* Base node object for both ma_sound and ma_sound_group. */ -typedef struct -{ - ma_node_base baseNode; /* Must be the first member for compatiblity with the ma_node API. */ - ma_engine* pEngine; /* A pointer to the engine. Set based on the value from the config. */ - ma_uint32 sampleRate; /* The sample rate of the input data. For sounds backed by a data source, this will be the data source's sample rate. Otherwise it'll be the engine's sample rate. */ - ma_mono_expansion_mode monoExpansionMode; - ma_fader fader; - ma_linear_resampler resampler; /* For pitch shift. */ - ma_spatializer spatializer; - ma_panner panner; - MA_ATOMIC(4, float) pitch; - float oldPitch; /* For determining whether or not the resampler needs to be updated to reflect the new pitch. The resampler will be updated on the mixing thread. */ - float oldDopplerPitch; /* For determining whether or not the resampler needs to be updated to take a new doppler pitch into account. */ - MA_ATOMIC(4, ma_bool32) isPitchDisabled; /* When set to true, pitching will be disabled which will allow the resampler to be bypassed to save some computation. */ - MA_ATOMIC(4, ma_bool32) isSpatializationDisabled; /* Set to false by default. When set to false, will not have spatialisation applied. */ - MA_ATOMIC(4, ma_uint32) pinnedListenerIndex; /* The index of the listener this node should always use for spatialization. If set to MA_LISTENER_INDEX_CLOSEST the engine will use the closest listener. */ - - /* Memory management. */ - ma_bool8 _ownsHeap; - void* _pHeap; -} ma_engine_node; - -MA_API ma_result ma_engine_node_get_heap_size(const ma_engine_node_config* pConfig, size_t* pHeapSizeInBytes); -MA_API ma_result ma_engine_node_init_preallocated(const ma_engine_node_config* pConfig, void* pHeap, ma_engine_node* pEngineNode); -MA_API ma_result ma_engine_node_init(const ma_engine_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_engine_node* pEngineNode); -MA_API void ma_engine_node_uninit(ma_engine_node* pEngineNode, const ma_allocation_callbacks* pAllocationCallbacks); - - -#define MA_SOUND_SOURCE_CHANNEL_COUNT 0xFFFFFFFF - -/* Callback for when a sound reaches the end. */ -typedef void (* ma_sound_end_proc)(void* pUserData, ma_sound* pSound); - -typedef struct -{ - const char* pFilePath; /* Set this to load from the resource manager. */ - const wchar_t* pFilePathW; /* Set this to load from the resource manager. */ - ma_data_source* pDataSource; /* Set this to load from an existing data source. */ - ma_node* pInitialAttachment; /* If set, the sound will be attached to an input of this node. This can be set to a ma_sound. If set to NULL, the sound will be attached directly to the endpoint unless MA_SOUND_FLAG_NO_DEFAULT_ATTACHMENT is set in `flags`. */ - ma_uint32 initialAttachmentInputBusIndex; /* The index of the input bus of pInitialAttachment to attach the sound to. */ - ma_uint32 channelsIn; /* Ignored if using a data source as input (the data source's channel count will be used always). Otherwise, setting to 0 will cause the engine's channel count to be used. */ - ma_uint32 channelsOut; /* Set this to 0 (default) to use the engine's channel count. Set to MA_SOUND_SOURCE_CHANNEL_COUNT to use the data source's channel count (only used if using a data source as input). */ - ma_mono_expansion_mode monoExpansionMode; /* Controls how the mono channel should be expanded to other channels when spatialization is disabled on a sound. */ - ma_uint32 flags; /* A combination of MA_SOUND_FLAG_* flags. */ - ma_uint64 initialSeekPointInPCMFrames; /* Initializes the sound such that it's seeked to this location by default. */ - ma_uint64 rangeBegInPCMFrames; - ma_uint64 rangeEndInPCMFrames; - ma_uint64 loopPointBegInPCMFrames; - ma_uint64 loopPointEndInPCMFrames; - ma_bool32 isLooping; - ma_sound_end_proc endCallback; /* Fired when the sound reaches the end. Will be fired from the audio thread. Do not restart, uninitialize or otherwise change the state of the sound from here. Instead fire an event or set a variable to indicate to a different thread to change the start of the sound. Will not be fired in response to a scheduled stop with ma_sound_set_stop_time_*(). */ - void* pEndCallbackUserData; -#ifndef MA_NO_RESOURCE_MANAGER - ma_resource_manager_pipeline_notifications initNotifications; -#endif - ma_fence* pDoneFence; /* Deprecated. Use initNotifications instead. Released when the resource manager has finished decoding the entire sound. Not used with streams. */ -} ma_sound_config; - -MA_API ma_sound_config ma_sound_config_init(void); /* Deprecated. Will be removed in version 0.12. Use ma_sound_config_2() instead. */ -MA_API ma_sound_config ma_sound_config_init_2(ma_engine* pEngine); /* Will be renamed to ma_sound_config_init() in version 0.12. */ - -struct ma_sound -{ - ma_engine_node engineNode; /* Must be the first member for compatibility with the ma_node API. */ - ma_data_source* pDataSource; - MA_ATOMIC(8, ma_uint64) seekTarget; /* The PCM frame index to seek to in the mixing thread. Set to (~(ma_uint64)0) to not perform any seeking. */ - MA_ATOMIC(4, ma_bool32) atEnd; - ma_sound_end_proc endCallback; - void* pEndCallbackUserData; - ma_bool8 ownsDataSource; - - /* - We're declaring a resource manager data source object here to save us a malloc when loading a - sound via the resource manager, which I *think* will be the most common scenario. - */ -#ifndef MA_NO_RESOURCE_MANAGER - ma_resource_manager_data_source* pResourceManagerDataSource; -#endif -}; - -/* Structure specifically for sounds played with ma_engine_play_sound(). Making this a separate structure to reduce overhead. */ -typedef struct ma_sound_inlined ma_sound_inlined; -struct ma_sound_inlined -{ - ma_sound sound; - ma_sound_inlined* pNext; - ma_sound_inlined* pPrev; -}; - -/* A sound group is just a sound. */ -typedef ma_sound_config ma_sound_group_config; -typedef ma_sound ma_sound_group; - -MA_API ma_sound_group_config ma_sound_group_config_init(void); /* Deprecated. Will be removed in version 0.12. Use ma_sound_config_2() instead. */ -MA_API ma_sound_group_config ma_sound_group_config_init_2(ma_engine* pEngine); /* Will be renamed to ma_sound_config_init() in version 0.12. */ - -typedef struct -{ -#if !defined(MA_NO_RESOURCE_MANAGER) - ma_resource_manager* pResourceManager; /* Can be null in which case a resource manager will be created for you. */ -#endif -#if !defined(MA_NO_DEVICE_IO) - ma_context* pContext; - ma_device* pDevice; /* If set, the caller is responsible for calling ma_engine_data_callback() in the device's data callback. */ - ma_device_id* pPlaybackDeviceID; /* The ID of the playback device to use with the default listener. */ - ma_device_notification_proc notificationCallback; -#endif - ma_log* pLog; /* When set to NULL, will use the context's log. */ - ma_uint32 listenerCount; /* Must be between 1 and MA_ENGINE_MAX_LISTENERS. */ - ma_uint32 channels; /* The number of channels to use when mixing and spatializing. When set to 0, will use the native channel count of the device. */ - ma_uint32 sampleRate; /* The sample rate. When set to 0 will use the native channel count of the device. */ - ma_uint32 periodSizeInFrames; /* If set to something other than 0, updates will always be exactly this size. The underlying device may be a different size, but from the perspective of the mixer that won't matter.*/ - ma_uint32 periodSizeInMilliseconds; /* Used if periodSizeInFrames is unset. */ - ma_uint32 gainSmoothTimeInFrames; /* The number of frames to interpolate the gain of spatialized sounds across. If set to 0, will use gainSmoothTimeInMilliseconds. */ - ma_uint32 gainSmoothTimeInMilliseconds; /* When set to 0, gainSmoothTimeInFrames will be used. If both are set to 0, a default value will be used. */ - ma_allocation_callbacks allocationCallbacks; - ma_bool32 noAutoStart; /* When set to true, requires an explicit call to ma_engine_start(). This is false by default, meaning the engine will be started automatically in ma_engine_init(). */ - ma_bool32 noDevice; /* When set to true, don't create a default device. ma_engine_read_pcm_frames() can be called manually to read data. */ - ma_mono_expansion_mode monoExpansionMode; /* Controls how the mono channel should be expanded to other channels when spatialization is disabled on a sound. */ - ma_vfs* pResourceManagerVFS; /* A pointer to a pre-allocated VFS object to use with the resource manager. This is ignored if pResourceManager is not NULL. */ -} ma_engine_config; - -MA_API ma_engine_config ma_engine_config_init(void); - - -struct ma_engine -{ - ma_node_graph nodeGraph; /* An engine is a node graph. It should be able to be plugged into any ma_node_graph API (with a cast) which means this must be the first member of this struct. */ -#if !defined(MA_NO_RESOURCE_MANAGER) - ma_resource_manager* pResourceManager; -#endif -#if !defined(MA_NO_DEVICE_IO) - ma_device* pDevice; /* Optionally set via the config, otherwise allocated by the engine in ma_engine_init(). */ -#endif - ma_log* pLog; - ma_uint32 sampleRate; - ma_uint32 listenerCount; - ma_spatializer_listener listeners[MA_ENGINE_MAX_LISTENERS]; - ma_allocation_callbacks allocationCallbacks; - ma_bool8 ownsResourceManager; - ma_bool8 ownsDevice; - ma_spinlock inlinedSoundLock; /* For synchronizing access so the inlined sound list. */ - ma_sound_inlined* pInlinedSoundHead; /* The first inlined sound. Inlined sounds are tracked in a linked list. */ - MA_ATOMIC(4, ma_uint32) inlinedSoundCount; /* The total number of allocated inlined sound objects. Used for debugging. */ - ma_uint32 gainSmoothTimeInFrames; /* The number of frames to interpolate the gain of spatialized sounds across. */ - ma_mono_expansion_mode monoExpansionMode; -}; - -MA_API ma_result ma_engine_init(const ma_engine_config* pConfig, ma_engine* pEngine); -MA_API void ma_engine_uninit(ma_engine* pEngine); -MA_API ma_result ma_engine_read_pcm_frames(ma_engine* pEngine, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_node_graph* ma_engine_get_node_graph(ma_engine* pEngine); -#if !defined(MA_NO_RESOURCE_MANAGER) -MA_API ma_resource_manager* ma_engine_get_resource_manager(ma_engine* pEngine); -#endif -MA_API ma_device* ma_engine_get_device(ma_engine* pEngine); -MA_API ma_log* ma_engine_get_log(ma_engine* pEngine); -MA_API ma_node* ma_engine_get_endpoint(ma_engine* pEngine); -MA_API ma_uint64 ma_engine_get_time(const ma_engine* pEngine); -MA_API ma_result ma_engine_set_time(ma_engine* pEngine, ma_uint64 globalTime); -MA_API ma_uint32 ma_engine_get_channels(const ma_engine* pEngine); -MA_API ma_uint32 ma_engine_get_sample_rate(const ma_engine* pEngine); - -MA_API ma_result ma_engine_start(ma_engine* pEngine); -MA_API ma_result ma_engine_stop(ma_engine* pEngine); -MA_API ma_result ma_engine_set_volume(ma_engine* pEngine, float volume); -MA_API ma_result ma_engine_set_gain_db(ma_engine* pEngine, float gainDB); - -MA_API ma_uint32 ma_engine_get_listener_count(const ma_engine* pEngine); -MA_API ma_uint32 ma_engine_find_closest_listener(const ma_engine* pEngine, float absolutePosX, float absolutePosY, float absolutePosZ); -MA_API void ma_engine_listener_set_position(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z); -MA_API ma_vec3f ma_engine_listener_get_position(const ma_engine* pEngine, ma_uint32 listenerIndex); -MA_API void ma_engine_listener_set_direction(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z); -MA_API ma_vec3f ma_engine_listener_get_direction(const ma_engine* pEngine, ma_uint32 listenerIndex); -MA_API void ma_engine_listener_set_velocity(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z); -MA_API ma_vec3f ma_engine_listener_get_velocity(const ma_engine* pEngine, ma_uint32 listenerIndex); -MA_API void ma_engine_listener_set_cone(ma_engine* pEngine, ma_uint32 listenerIndex, float innerAngleInRadians, float outerAngleInRadians, float outerGain); -MA_API void ma_engine_listener_get_cone(const ma_engine* pEngine, ma_uint32 listenerIndex, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain); -MA_API void ma_engine_listener_set_world_up(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z); -MA_API ma_vec3f ma_engine_listener_get_world_up(const ma_engine* pEngine, ma_uint32 listenerIndex); -MA_API void ma_engine_listener_set_enabled(ma_engine* pEngine, ma_uint32 listenerIndex, ma_bool32 isEnabled); -MA_API ma_bool32 ma_engine_listener_is_enabled(const ma_engine* pEngine, ma_uint32 listenerIndex); - -#ifndef MA_NO_RESOURCE_MANAGER -MA_API ma_result ma_engine_play_sound_ex(ma_engine* pEngine, const char* pFilePath, ma_node* pNode, ma_uint32 nodeInputBusIndex); -MA_API ma_result ma_engine_play_sound(ma_engine* pEngine, const char* pFilePath, ma_sound_group* pGroup); /* Fire and forget. */ -#endif - -#ifndef MA_NO_RESOURCE_MANAGER -MA_API ma_result ma_sound_init_from_file(ma_engine* pEngine, const char* pFilePath, ma_uint32 flags, ma_sound_group* pGroup, ma_fence* pDoneFence, ma_sound* pSound); -MA_API ma_result ma_sound_init_from_file_w(ma_engine* pEngine, const wchar_t* pFilePath, ma_uint32 flags, ma_sound_group* pGroup, ma_fence* pDoneFence, ma_sound* pSound); -MA_API ma_result ma_sound_init_copy(ma_engine* pEngine, const ma_sound* pExistingSound, ma_uint32 flags, ma_sound_group* pGroup, ma_sound* pSound); -#endif -MA_API ma_result ma_sound_init_from_data_source(ma_engine* pEngine, ma_data_source* pDataSource, ma_uint32 flags, ma_sound_group* pGroup, ma_sound* pSound); -MA_API ma_result ma_sound_init_ex(ma_engine* pEngine, const ma_sound_config* pConfig, ma_sound* pSound); -MA_API void ma_sound_uninit(ma_sound* pSound); -MA_API ma_engine* ma_sound_get_engine(const ma_sound* pSound); -MA_API ma_data_source* ma_sound_get_data_source(const ma_sound* pSound); -MA_API ma_result ma_sound_start(ma_sound* pSound); -MA_API ma_result ma_sound_stop(ma_sound* pSound); -MA_API void ma_sound_set_volume(ma_sound* pSound, float volume); -MA_API float ma_sound_get_volume(const ma_sound* pSound); -MA_API void ma_sound_set_pan(ma_sound* pSound, float pan); -MA_API float ma_sound_get_pan(const ma_sound* pSound); -MA_API void ma_sound_set_pan_mode(ma_sound* pSound, ma_pan_mode panMode); -MA_API ma_pan_mode ma_sound_get_pan_mode(const ma_sound* pSound); -MA_API void ma_sound_set_pitch(ma_sound* pSound, float pitch); -MA_API float ma_sound_get_pitch(const ma_sound* pSound); -MA_API void ma_sound_set_spatialization_enabled(ma_sound* pSound, ma_bool32 enabled); -MA_API ma_bool32 ma_sound_is_spatialization_enabled(const ma_sound* pSound); -MA_API void ma_sound_set_pinned_listener_index(ma_sound* pSound, ma_uint32 listenerIndex); -MA_API ma_uint32 ma_sound_get_pinned_listener_index(const ma_sound* pSound); -MA_API ma_uint32 ma_sound_get_listener_index(const ma_sound* pSound); -MA_API ma_vec3f ma_sound_get_direction_to_listener(const ma_sound* pSound); -MA_API void ma_sound_set_position(ma_sound* pSound, float x, float y, float z); -MA_API ma_vec3f ma_sound_get_position(const ma_sound* pSound); -MA_API void ma_sound_set_direction(ma_sound* pSound, float x, float y, float z); -MA_API ma_vec3f ma_sound_get_direction(const ma_sound* pSound); -MA_API void ma_sound_set_velocity(ma_sound* pSound, float x, float y, float z); -MA_API ma_vec3f ma_sound_get_velocity(const ma_sound* pSound); -MA_API void ma_sound_set_attenuation_model(ma_sound* pSound, ma_attenuation_model attenuationModel); -MA_API ma_attenuation_model ma_sound_get_attenuation_model(const ma_sound* pSound); -MA_API void ma_sound_set_positioning(ma_sound* pSound, ma_positioning positioning); -MA_API ma_positioning ma_sound_get_positioning(const ma_sound* pSound); -MA_API void ma_sound_set_rolloff(ma_sound* pSound, float rolloff); -MA_API float ma_sound_get_rolloff(const ma_sound* pSound); -MA_API void ma_sound_set_min_gain(ma_sound* pSound, float minGain); -MA_API float ma_sound_get_min_gain(const ma_sound* pSound); -MA_API void ma_sound_set_max_gain(ma_sound* pSound, float maxGain); -MA_API float ma_sound_get_max_gain(const ma_sound* pSound); -MA_API void ma_sound_set_min_distance(ma_sound* pSound, float minDistance); -MA_API float ma_sound_get_min_distance(const ma_sound* pSound); -MA_API void ma_sound_set_max_distance(ma_sound* pSound, float maxDistance); -MA_API float ma_sound_get_max_distance(const ma_sound* pSound); -MA_API void ma_sound_set_cone(ma_sound* pSound, float innerAngleInRadians, float outerAngleInRadians, float outerGain); -MA_API void ma_sound_get_cone(const ma_sound* pSound, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain); -MA_API void ma_sound_set_doppler_factor(ma_sound* pSound, float dopplerFactor); -MA_API float ma_sound_get_doppler_factor(const ma_sound* pSound); -MA_API void ma_sound_set_directional_attenuation_factor(ma_sound* pSound, float directionalAttenuationFactor); -MA_API float ma_sound_get_directional_attenuation_factor(const ma_sound* pSound); -MA_API void ma_sound_set_fade_in_pcm_frames(ma_sound* pSound, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInFrames); -MA_API void ma_sound_set_fade_in_milliseconds(ma_sound* pSound, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInMilliseconds); -MA_API float ma_sound_get_current_fade_volume(const ma_sound* pSound); -MA_API void ma_sound_set_start_time_in_pcm_frames(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInFrames); -MA_API void ma_sound_set_start_time_in_milliseconds(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInMilliseconds); -MA_API void ma_sound_set_stop_time_in_pcm_frames(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInFrames); -MA_API void ma_sound_set_stop_time_in_milliseconds(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInMilliseconds); -MA_API ma_bool32 ma_sound_is_playing(const ma_sound* pSound); -MA_API ma_uint64 ma_sound_get_time_in_pcm_frames(const ma_sound* pSound); -MA_API void ma_sound_set_looping(ma_sound* pSound, ma_bool32 isLooping); -MA_API ma_bool32 ma_sound_is_looping(const ma_sound* pSound); -MA_API ma_bool32 ma_sound_at_end(const ma_sound* pSound); -MA_API ma_result ma_sound_seek_to_pcm_frame(ma_sound* pSound, ma_uint64 frameIndex); /* Just a wrapper around ma_data_source_seek_to_pcm_frame(). */ -MA_API ma_result ma_sound_get_data_format(ma_sound* pSound, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_sound_get_cursor_in_pcm_frames(ma_sound* pSound, ma_uint64* pCursor); -MA_API ma_result ma_sound_get_length_in_pcm_frames(ma_sound* pSound, ma_uint64* pLength); -MA_API ma_result ma_sound_get_cursor_in_seconds(ma_sound* pSound, float* pCursor); -MA_API ma_result ma_sound_get_length_in_seconds(ma_sound* pSound, float* pLength); -MA_API ma_result ma_sound_set_end_callback(ma_sound* pSound, ma_sound_end_proc callback, void* pUserData); - -MA_API ma_result ma_sound_group_init(ma_engine* pEngine, ma_uint32 flags, ma_sound_group* pParentGroup, ma_sound_group* pGroup); -MA_API ma_result ma_sound_group_init_ex(ma_engine* pEngine, const ma_sound_group_config* pConfig, ma_sound_group* pGroup); -MA_API void ma_sound_group_uninit(ma_sound_group* pGroup); -MA_API ma_engine* ma_sound_group_get_engine(const ma_sound_group* pGroup); -MA_API ma_result ma_sound_group_start(ma_sound_group* pGroup); -MA_API ma_result ma_sound_group_stop(ma_sound_group* pGroup); -MA_API void ma_sound_group_set_volume(ma_sound_group* pGroup, float volume); -MA_API float ma_sound_group_get_volume(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_pan(ma_sound_group* pGroup, float pan); -MA_API float ma_sound_group_get_pan(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_pan_mode(ma_sound_group* pGroup, ma_pan_mode panMode); -MA_API ma_pan_mode ma_sound_group_get_pan_mode(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_pitch(ma_sound_group* pGroup, float pitch); -MA_API float ma_sound_group_get_pitch(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_spatialization_enabled(ma_sound_group* pGroup, ma_bool32 enabled); -MA_API ma_bool32 ma_sound_group_is_spatialization_enabled(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_pinned_listener_index(ma_sound_group* pGroup, ma_uint32 listenerIndex); -MA_API ma_uint32 ma_sound_group_get_pinned_listener_index(const ma_sound_group* pGroup); -MA_API ma_uint32 ma_sound_group_get_listener_index(const ma_sound_group* pGroup); -MA_API ma_vec3f ma_sound_group_get_direction_to_listener(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_position(ma_sound_group* pGroup, float x, float y, float z); -MA_API ma_vec3f ma_sound_group_get_position(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_direction(ma_sound_group* pGroup, float x, float y, float z); -MA_API ma_vec3f ma_sound_group_get_direction(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_velocity(ma_sound_group* pGroup, float x, float y, float z); -MA_API ma_vec3f ma_sound_group_get_velocity(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_attenuation_model(ma_sound_group* pGroup, ma_attenuation_model attenuationModel); -MA_API ma_attenuation_model ma_sound_group_get_attenuation_model(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_positioning(ma_sound_group* pGroup, ma_positioning positioning); -MA_API ma_positioning ma_sound_group_get_positioning(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_rolloff(ma_sound_group* pGroup, float rolloff); -MA_API float ma_sound_group_get_rolloff(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_min_gain(ma_sound_group* pGroup, float minGain); -MA_API float ma_sound_group_get_min_gain(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_max_gain(ma_sound_group* pGroup, float maxGain); -MA_API float ma_sound_group_get_max_gain(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_min_distance(ma_sound_group* pGroup, float minDistance); -MA_API float ma_sound_group_get_min_distance(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_max_distance(ma_sound_group* pGroup, float maxDistance); -MA_API float ma_sound_group_get_max_distance(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_cone(ma_sound_group* pGroup, float innerAngleInRadians, float outerAngleInRadians, float outerGain); -MA_API void ma_sound_group_get_cone(const ma_sound_group* pGroup, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain); -MA_API void ma_sound_group_set_doppler_factor(ma_sound_group* pGroup, float dopplerFactor); -MA_API float ma_sound_group_get_doppler_factor(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_directional_attenuation_factor(ma_sound_group* pGroup, float directionalAttenuationFactor); -MA_API float ma_sound_group_get_directional_attenuation_factor(const ma_sound_group* pGroup); -MA_API void ma_sound_group_set_fade_in_pcm_frames(ma_sound_group* pGroup, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInFrames); -MA_API void ma_sound_group_set_fade_in_milliseconds(ma_sound_group* pGroup, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInMilliseconds); -MA_API float ma_sound_group_get_current_fade_volume(ma_sound_group* pGroup); -MA_API void ma_sound_group_set_start_time_in_pcm_frames(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInFrames); -MA_API void ma_sound_group_set_start_time_in_milliseconds(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInMilliseconds); -MA_API void ma_sound_group_set_stop_time_in_pcm_frames(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInFrames); -MA_API void ma_sound_group_set_stop_time_in_milliseconds(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInMilliseconds); -MA_API ma_bool32 ma_sound_group_is_playing(const ma_sound_group* pGroup); -MA_API ma_uint64 ma_sound_group_get_time_in_pcm_frames(const ma_sound_group* pGroup); -#endif /* MA_NO_ENGINE */ -/* END SECTION: miniaudio_engine.h */ - -#ifdef __cplusplus -} -#endif -#endif /* miniaudio_h */ - - -/* -This is for preventing greying out of the implementation section. -*/ -#if defined(Q_CREATOR_RUN) || defined(__INTELLISENSE__) || defined(__CDT_PARSER__) -#define MINIAUDIO_IMPLEMENTATION -#endif - -/************************************************************************************************************************************************************ -************************************************************************************************************************************************************* - -IMPLEMENTATION - -************************************************************************************************************************************************************* -************************************************************************************************************************************************************/ -#if defined(MINIAUDIO_IMPLEMENTATION) || defined(MA_IMPLEMENTATION) -#ifndef miniaudio_c -#define miniaudio_c - -#include -#include /* For INT_MAX */ -#include /* sin(), etc. */ -#include /* For malloc(), free(), wcstombs(). */ -#include /* For memset() */ - -#include -#include -#if !defined(_MSC_VER) && !defined(__DMC__) - #include /* For strcasecmp(). */ - #include /* For wcslen(), wcsrtombs() */ -#endif -#ifdef _MSC_VER - #include /* For _controlfp_s constants */ -#endif - -#if defined(MA_WIN32) - #include -#endif - -#if !defined(MA_WIN32) -#include -#include /* select() (used for ma_sleep()). */ -#include -#endif - -#ifdef MA_NX -#include /* For nanosleep() */ -#endif - -#include /* For fstat(), etc. */ - -#ifdef MA_EMSCRIPTEN -#include -#endif - - -#if !defined(MA_64BIT) && !defined(MA_32BIT) -#ifdef _WIN32 -#ifdef _WIN64 -#define MA_64BIT -#else -#define MA_32BIT -#endif -#endif -#endif - -#if !defined(MA_64BIT) && !defined(MA_32BIT) -#ifdef __GNUC__ -#ifdef __LP64__ -#define MA_64BIT -#else -#define MA_32BIT -#endif -#endif -#endif - -#if !defined(MA_64BIT) && !defined(MA_32BIT) -#include -#if INTPTR_MAX == INT64_MAX -#define MA_64BIT -#else -#define MA_32BIT -#endif -#endif - -/* Architecture Detection */ -#if defined(__x86_64__) || defined(_M_X64) -#define MA_X64 -#elif defined(__i386) || defined(_M_IX86) -#define MA_X86 -#elif defined(__arm__) || defined(_M_ARM) || defined(__arm64) || defined(__arm64__) || defined(__aarch64__) || defined(_M_ARM64) -#define MA_ARM -#endif - -/* Intrinsics Support */ -#if (defined(MA_X64) || defined(MA_X86)) && !defined(__COSMOPOLITAN__) - #if defined(_MSC_VER) && !defined(__clang__) - /* MSVC. */ - #if _MSC_VER >= 1400 && !defined(MA_NO_SSE2) /* 2005 */ - #define MA_SUPPORT_SSE2 - #endif - /*#if _MSC_VER >= 1600 && !defined(MA_NO_AVX)*/ /* 2010 */ - /* #define MA_SUPPORT_AVX*/ - /*#endif*/ - #if _MSC_VER >= 1700 && !defined(MA_NO_AVX2) /* 2012 */ - #define MA_SUPPORT_AVX2 - #endif - #else - /* Assume GNUC-style. */ - #if defined(__SSE2__) && !defined(MA_NO_SSE2) - #define MA_SUPPORT_SSE2 - #endif - /*#if defined(__AVX__) && !defined(MA_NO_AVX)*/ - /* #define MA_SUPPORT_AVX*/ - /*#endif*/ - #if defined(__AVX2__) && !defined(MA_NO_AVX2) - #define MA_SUPPORT_AVX2 - #endif - #endif - - /* If at this point we still haven't determined compiler support for the intrinsics just fall back to __has_include. */ - #if !defined(__GNUC__) && !defined(__clang__) && defined(__has_include) - #if !defined(MA_SUPPORT_SSE2) && !defined(MA_NO_SSE2) && __has_include() - #define MA_SUPPORT_SSE2 - #endif - /*#if !defined(MA_SUPPORT_AVX) && !defined(MA_NO_AVX) && __has_include()*/ - /* #define MA_SUPPORT_AVX*/ - /*#endif*/ - #if !defined(MA_SUPPORT_AVX2) && !defined(MA_NO_AVX2) && __has_include() - #define MA_SUPPORT_AVX2 - #endif - #endif - - #if defined(MA_SUPPORT_AVX2) || defined(MA_SUPPORT_AVX) - #include - #elif defined(MA_SUPPORT_SSE2) - #include - #endif -#endif - -#if defined(MA_ARM) - #if !defined(MA_NO_NEON) && (defined(__ARM_NEON) || defined(__aarch64__) || defined(_M_ARM64)) - #define MA_SUPPORT_NEON - #include - #endif -#endif - -/* Begin globally disabled warnings. */ -#if defined(_MSC_VER) - #pragma warning(push) - #pragma warning(disable:4752) /* found Intel(R) Advanced Vector Extensions; consider using /arch:AVX */ - #pragma warning(disable:4049) /* compiler limit : terminating line number emission */ -#endif - -#if defined(MA_X64) || defined(MA_X86) - #if defined(_MSC_VER) && !defined(__clang__) - #if _MSC_VER >= 1400 - #include - static MA_INLINE void ma_cpuid(int info[4], int fid) - { - __cpuid(info, fid); - } - #else - #define MA_NO_CPUID - #endif - - #if _MSC_VER >= 1600 && (defined(_MSC_FULL_VER) && _MSC_FULL_VER >= 160040219) - static MA_INLINE unsigned __int64 ma_xgetbv(int reg) - { - return _xgetbv(reg); - } - #else - #define MA_NO_XGETBV - #endif - #elif (defined(__GNUC__) || defined(__clang__)) && !defined(MA_ANDROID) - static MA_INLINE void ma_cpuid(int info[4], int fid) - { - /* - It looks like the -fPIC option uses the ebx register which GCC complains about. We can work around this by just using a different register, the - specific register of which I'm letting the compiler decide on. The "k" prefix is used to specify a 32-bit register. The {...} syntax is for - supporting different assembly dialects. - - What's basically happening is that we're saving and restoring the ebx register manually. - */ - #if defined(DRFLAC_X86) && defined(__PIC__) - __asm__ __volatile__ ( - "xchg{l} {%%}ebx, %k1;" - "cpuid;" - "xchg{l} {%%}ebx, %k1;" - : "=a"(info[0]), "=&r"(info[1]), "=c"(info[2]), "=d"(info[3]) : "a"(fid), "c"(0) - ); - #else - __asm__ __volatile__ ( - "cpuid" : "=a"(info[0]), "=b"(info[1]), "=c"(info[2]), "=d"(info[3]) : "a"(fid), "c"(0) - ); - #endif - } - - static MA_INLINE ma_uint64 ma_xgetbv(int reg) - { - unsigned int hi; - unsigned int lo; - - __asm__ __volatile__ ( - "xgetbv" : "=a"(lo), "=d"(hi) : "c"(reg) - ); - - return ((ma_uint64)hi << 32) | (ma_uint64)lo; - } - #else - #define MA_NO_CPUID - #define MA_NO_XGETBV - #endif -#else - #define MA_NO_CPUID - #define MA_NO_XGETBV -#endif - -static MA_INLINE ma_bool32 ma_has_sse2(void) -{ -#if defined(MA_SUPPORT_SSE2) - #if (defined(MA_X64) || defined(MA_X86)) && !defined(MA_NO_SSE2) - #if defined(MA_X64) - return MA_TRUE; /* 64-bit targets always support SSE2. */ - #elif (defined(_M_IX86_FP) && _M_IX86_FP == 2) || defined(__SSE2__) - return MA_TRUE; /* If the compiler is allowed to freely generate SSE2 code we can assume support. */ - #else - #if defined(MA_NO_CPUID) - return MA_FALSE; - #else - int info[4]; - ma_cpuid(info, 1); - return (info[3] & (1 << 26)) != 0; - #endif - #endif - #else - return MA_FALSE; /* SSE2 is only supported on x86 and x64 architectures. */ - #endif -#else - return MA_FALSE; /* No compiler support. */ -#endif -} - -#if 0 -static MA_INLINE ma_bool32 ma_has_avx() -{ -#if defined(MA_SUPPORT_AVX) - #if (defined(MA_X64) || defined(MA_X86)) && !defined(MA_NO_AVX) - #if defined(_AVX_) || defined(__AVX__) - return MA_TRUE; /* If the compiler is allowed to freely generate AVX code we can assume support. */ - #else - /* AVX requires both CPU and OS support. */ - #if defined(MA_NO_CPUID) || defined(MA_NO_XGETBV) - return MA_FALSE; - #else - int info[4]; - ma_cpuid(info, 1); - if (((info[2] & (1 << 27)) != 0) && ((info[2] & (1 << 28)) != 0)) { - ma_uint64 xrc = ma_xgetbv(0); - if ((xrc & 0x06) == 0x06) { - return MA_TRUE; - } else { - return MA_FALSE; - } - } else { - return MA_FALSE; - } - #endif - #endif - #else - return MA_FALSE; /* AVX is only supported on x86 and x64 architectures. */ - #endif -#else - return MA_FALSE; /* No compiler support. */ -#endif -} -#endif - -static MA_INLINE ma_bool32 ma_has_avx2(void) -{ -#if defined(MA_SUPPORT_AVX2) - #if (defined(MA_X64) || defined(MA_X86)) && !defined(MA_NO_AVX2) - #if defined(_AVX2_) || defined(__AVX2__) - return MA_TRUE; /* If the compiler is allowed to freely generate AVX2 code we can assume support. */ - #else - /* AVX2 requires both CPU and OS support. */ - #if defined(MA_NO_CPUID) || defined(MA_NO_XGETBV) - return MA_FALSE; - #else - int info1[4]; - int info7[4]; - ma_cpuid(info1, 1); - ma_cpuid(info7, 7); - if (((info1[2] & (1 << 27)) != 0) && ((info7[1] & (1 << 5)) != 0)) { - ma_uint64 xrc = ma_xgetbv(0); - if ((xrc & 0x06) == 0x06) { - return MA_TRUE; - } else { - return MA_FALSE; - } - } else { - return MA_FALSE; - } - #endif - #endif - #else - return MA_FALSE; /* AVX2 is only supported on x86 and x64 architectures. */ - #endif -#else - return MA_FALSE; /* No compiler support. */ -#endif -} - -static MA_INLINE ma_bool32 ma_has_neon(void) -{ -#if defined(MA_SUPPORT_NEON) - #if defined(MA_ARM) && !defined(MA_NO_NEON) - #if (defined(__ARM_NEON) || defined(__aarch64__) || defined(_M_ARM64)) - return MA_TRUE; /* If the compiler is allowed to freely generate NEON code we can assume support. */ - #else - /* TODO: Runtime check. */ - return MA_FALSE; - #endif - #else - return MA_FALSE; /* NEON is only supported on ARM architectures. */ - #endif -#else - return MA_FALSE; /* No compiler support. */ -#endif -} - -#if defined(__has_builtin) - #define MA_COMPILER_HAS_BUILTIN(x) __has_builtin(x) -#else - #define MA_COMPILER_HAS_BUILTIN(x) 0 -#endif - -#ifndef MA_ASSUME - #if MA_COMPILER_HAS_BUILTIN(__builtin_assume) - #define MA_ASSUME(x) __builtin_assume(x) - #elif MA_COMPILER_HAS_BUILTIN(__builtin_unreachable) - #define MA_ASSUME(x) do { if (!(x)) __builtin_unreachable(); } while (0) - #elif defined(_MSC_VER) - #define MA_ASSUME(x) __assume(x) - #else - #define MA_ASSUME(x) (void)(x) - #endif -#endif - -#ifndef MA_RESTRICT - #if defined(__clang__) || defined(__GNUC__) || defined(_MSC_VER) - #define MA_RESTRICT __restrict - #else - #define MA_RESTRICT - #endif -#endif - -#if defined(_MSC_VER) && _MSC_VER >= 1400 - #define MA_HAS_BYTESWAP16_INTRINSIC - #define MA_HAS_BYTESWAP32_INTRINSIC - #define MA_HAS_BYTESWAP64_INTRINSIC -#elif defined(__clang__) - #if MA_COMPILER_HAS_BUILTIN(__builtin_bswap16) - #define MA_HAS_BYTESWAP16_INTRINSIC - #endif - #if MA_COMPILER_HAS_BUILTIN(__builtin_bswap32) - #define MA_HAS_BYTESWAP32_INTRINSIC - #endif - #if MA_COMPILER_HAS_BUILTIN(__builtin_bswap64) - #define MA_HAS_BYTESWAP64_INTRINSIC - #endif -#elif defined(__GNUC__) - #if ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)) - #define MA_HAS_BYTESWAP32_INTRINSIC - #define MA_HAS_BYTESWAP64_INTRINSIC - #endif - #if ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8)) - #define MA_HAS_BYTESWAP16_INTRINSIC - #endif -#endif - - -static MA_INLINE ma_bool32 ma_is_little_endian(void) -{ -#if defined(MA_X86) || defined(MA_X64) - return MA_TRUE; -#else - int n = 1; - return (*(char*)&n) == 1; -#endif -} - -static MA_INLINE ma_bool32 ma_is_big_endian(void) -{ - return !ma_is_little_endian(); -} - - -static MA_INLINE ma_uint32 ma_swap_endian_uint32(ma_uint32 n) -{ -#ifdef MA_HAS_BYTESWAP32_INTRINSIC - #if defined(_MSC_VER) - return _byteswap_ulong(n); - #elif defined(__GNUC__) || defined(__clang__) - #if defined(MA_ARM) && (defined(__ARM_ARCH) && __ARM_ARCH >= 6) && !defined(MA_64BIT) /* <-- 64-bit inline assembly has not been tested, so disabling for now. */ - /* Inline assembly optimized implementation for ARM. In my testing, GCC does not generate optimized code with __builtin_bswap32(). */ - ma_uint32 r; - __asm__ __volatile__ ( - #if defined(MA_64BIT) - "rev %w[out], %w[in]" : [out]"=r"(r) : [in]"r"(n) /* <-- This is untested. If someone in the community could test this, that would be appreciated! */ - #else - "rev %[out], %[in]" : [out]"=r"(r) : [in]"r"(n) - #endif - ); - return r; - #else - return __builtin_bswap32(n); - #endif - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & 0xFF000000) >> 24) | - ((n & 0x00FF0000) >> 8) | - ((n & 0x0000FF00) << 8) | - ((n & 0x000000FF) << 24); -#endif -} - - -#if !defined(MA_EMSCRIPTEN) -#ifdef MA_WIN32 -static void ma_sleep__win32(ma_uint32 milliseconds) -{ - Sleep((DWORD)milliseconds); -} -#endif -#ifdef MA_POSIX -static void ma_sleep__posix(ma_uint32 milliseconds) -{ -#ifdef MA_EMSCRIPTEN - (void)milliseconds; - MA_ASSERT(MA_FALSE); /* The Emscripten build should never sleep. */ -#else - #if (defined(_POSIX_C_SOURCE) && _POSIX_C_SOURCE >= 199309L) || defined(MA_NX) - struct timespec ts; - ts.tv_sec = milliseconds / 1000; - ts.tv_nsec = milliseconds % 1000 * 1000000; - nanosleep(&ts, NULL); - #else - struct timeval tv; - tv.tv_sec = milliseconds / 1000; - tv.tv_usec = milliseconds % 1000 * 1000; - select(0, NULL, NULL, NULL, &tv); - #endif -#endif -} -#endif - -static MA_INLINE void ma_sleep(ma_uint32 milliseconds) -{ -#ifdef MA_WIN32 - ma_sleep__win32(milliseconds); -#endif -#ifdef MA_POSIX - ma_sleep__posix(milliseconds); -#endif -} -#endif - -static MA_INLINE void ma_yield() -{ -#if defined(__i386) || defined(_M_IX86) || defined(__x86_64__) || defined(_M_X64) - /* x86/x64 */ - #if (defined(_MSC_VER) || defined(__WATCOMC__) || defined(__DMC__)) && !defined(__clang__) - #if _MSC_VER >= 1400 - _mm_pause(); - #else - #if defined(__DMC__) - /* Digital Mars does not recognize the PAUSE opcode. Fall back to NOP. */ - __asm nop; - #else - __asm pause; - #endif - #endif - #else - __asm__ __volatile__ ("pause"); - #endif -#elif (defined(__arm__) && defined(__ARM_ARCH) && __ARM_ARCH >= 7) || defined(_M_ARM64) || (defined(_M_ARM) && _M_ARM >= 7) || defined(__ARM_ARCH_6K__) || defined(__ARM_ARCH_6T2__) - /* ARM */ - #if defined(_MSC_VER) - /* Apparently there is a __yield() intrinsic that's compatible with ARM, but I cannot find documentation for it nor can I find where it's declared. */ - __yield(); - #else - __asm__ __volatile__ ("yield"); /* ARMv6K/ARMv6T2 and above. */ - #endif -#else - /* Unknown or unsupported architecture. No-op. */ -#endif -} - - -#define MA_MM_DENORMALS_ZERO_MASK 0x0040 -#define MA_MM_FLUSH_ZERO_MASK 0x8000 - -static MA_INLINE unsigned int ma_disable_denormals() -{ - unsigned int prevState; - - #if defined(_MSC_VER) - { - /* - Older versions of Visual Studio don't support the "safe" versions of _controlfp_s(). I don't - know which version of Visual Studio first added support for _controlfp_s(), but I do know - that VC6 lacks support. _MSC_VER = 1200 is VC6, but if you get compilation errors on older - versions of Visual Studio, let me know and I'll make the necessary adjustment. - */ - #if _MSC_VER <= 1200 - { - prevState = _statusfp(); - _controlfp(prevState | _DN_FLUSH, _MCW_DN); - } - #else - { - unsigned int unused; - _controlfp_s(&prevState, 0, 0); - _controlfp_s(&unused, prevState | _DN_FLUSH, _MCW_DN); - } - #endif - } - #elif defined(MA_X86) || defined(MA_X64) - { - #if defined(__SSE2__) && !(defined(__TINYC__) || defined(__WATCOMC__) || defined(__COSMOPOLITAN__)) /* <-- Add compilers that lack support for _mm_getcsr() and _mm_setcsr() to this list. */ - { - prevState = _mm_getcsr(); - _mm_setcsr(prevState | MA_MM_DENORMALS_ZERO_MASK | MA_MM_FLUSH_ZERO_MASK); - } - #else - { - /* x88/64, but no support for _mm_getcsr()/_mm_setcsr(). May need to fall back to inlined assembly here. */ - prevState = 0; - } - #endif - } - #else - { - /* Unknown or unsupported architecture. No-op. */ - prevState = 0; - } - #endif - - return prevState; -} - -static MA_INLINE void ma_restore_denormals(unsigned int prevState) -{ - #if defined(_MSC_VER) - { - /* Older versions of Visual Studio do not support _controlfp_s(). See ma_disable_denormals(). */ - #if _MSC_VER <= 1200 - { - _controlfp(prevState, _MCW_DN); - } - #else - { - unsigned int unused; - _controlfp_s(&unused, prevState, _MCW_DN); - } - #endif - } - #elif defined(MA_X86) || defined(MA_X64) - { - #if defined(__SSE2__) && !(defined(__TINYC__) || defined(__WATCOMC__) || defined(__COSMOPOLITAN__)) /* <-- Add compilers that lack support for _mm_getcsr() and _mm_setcsr() to this list. */ - { - _mm_setcsr(prevState); - } - #else - { - /* x88/64, but no support for _mm_getcsr()/_mm_setcsr(). May need to fall back to inlined assembly here. */ - (void)prevState; - } - #endif - } - #else - { - /* Unknown or unsupported architecture. No-op. */ - (void)prevState; - } - #endif -} - - -#ifdef MA_ANDROID -#include - -int ma_android_sdk_version() -{ - char sdkVersion[PROP_VALUE_MAX + 1] = {0, }; - if (__system_property_get("ro.build.version.sdk", sdkVersion)) { - return atoi(sdkVersion); - } - - return 0; -} -#endif - - -#ifndef MA_COINIT_VALUE -#define MA_COINIT_VALUE 0 /* 0 = COINIT_MULTITHREADED */ -#endif - - -#ifndef MA_FLT_MAX - #ifdef FLT_MAX - #define MA_FLT_MAX FLT_MAX - #else - #define MA_FLT_MAX 3.402823466e+38F - #endif -#endif - - -#ifndef MA_PI -#define MA_PI 3.14159265358979323846264f -#endif -#ifndef MA_PI_D -#define MA_PI_D 3.14159265358979323846264 -#endif -#ifndef MA_TAU -#define MA_TAU 6.28318530717958647693f -#endif -#ifndef MA_TAU_D -#define MA_TAU_D 6.28318530717958647693 -#endif - - -/* The default format when ma_format_unknown (0) is requested when initializing a device. */ -#ifndef MA_DEFAULT_FORMAT -#define MA_DEFAULT_FORMAT ma_format_f32 -#endif - -/* The default channel count to use when 0 is used when initializing a device. */ -#ifndef MA_DEFAULT_CHANNELS -#define MA_DEFAULT_CHANNELS 2 -#endif - -/* The default sample rate to use when 0 is used when initializing a device. */ -#ifndef MA_DEFAULT_SAMPLE_RATE -#define MA_DEFAULT_SAMPLE_RATE 48000 -#endif - -/* Default periods when none is specified in ma_device_init(). More periods means more work on the CPU. */ -#ifndef MA_DEFAULT_PERIODS -#define MA_DEFAULT_PERIODS 3 -#endif - -/* The default period size in milliseconds for low latency mode. */ -#ifndef MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_LOW_LATENCY -#define MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_LOW_LATENCY 10 -#endif - -/* The default buffer size in milliseconds for conservative mode. */ -#ifndef MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE -#define MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE 100 -#endif - -/* The default LPF filter order for linear resampling. Note that this is clamped to MA_MAX_FILTER_ORDER. */ -#ifndef MA_DEFAULT_RESAMPLER_LPF_ORDER - #if MA_MAX_FILTER_ORDER >= 4 - #define MA_DEFAULT_RESAMPLER_LPF_ORDER 4 - #else - #define MA_DEFAULT_RESAMPLER_LPF_ORDER MA_MAX_FILTER_ORDER - #endif -#endif - - -#if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wunused-variable" -#endif - -/* Standard sample rates, in order of priority. */ -static ma_uint32 g_maStandardSampleRatePriorities[] = { - (ma_uint32)ma_standard_sample_rate_48000, - (ma_uint32)ma_standard_sample_rate_44100, - - (ma_uint32)ma_standard_sample_rate_32000, - (ma_uint32)ma_standard_sample_rate_24000, - (ma_uint32)ma_standard_sample_rate_22050, - - (ma_uint32)ma_standard_sample_rate_88200, - (ma_uint32)ma_standard_sample_rate_96000, - (ma_uint32)ma_standard_sample_rate_176400, - (ma_uint32)ma_standard_sample_rate_192000, - - (ma_uint32)ma_standard_sample_rate_16000, - (ma_uint32)ma_standard_sample_rate_11025, - (ma_uint32)ma_standard_sample_rate_8000, - - (ma_uint32)ma_standard_sample_rate_352800, - (ma_uint32)ma_standard_sample_rate_384000 -}; - -static MA_INLINE ma_bool32 ma_is_standard_sample_rate(ma_uint32 sampleRate) -{ - ma_uint32 iSampleRate; - - for (iSampleRate = 0; iSampleRate < sizeof(g_maStandardSampleRatePriorities) / sizeof(g_maStandardSampleRatePriorities[0]); iSampleRate += 1) { - if (g_maStandardSampleRatePriorities[iSampleRate] == sampleRate) { - return MA_TRUE; - } - } - - /* Getting here means the sample rate is not supported. */ - return MA_FALSE; -} - - -static ma_format g_maFormatPriorities[] = { - ma_format_s16, /* Most common */ - ma_format_f32, - - /*ma_format_s24_32,*/ /* Clean alignment */ - ma_format_s32, - - ma_format_s24, /* Unclean alignment */ - - ma_format_u8 /* Low quality */ -}; -#if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop -#endif - - -MA_API void ma_version(ma_uint32* pMajor, ma_uint32* pMinor, ma_uint32* pRevision) -{ - if (pMajor) { - *pMajor = MA_VERSION_MAJOR; - } - - if (pMinor) { - *pMinor = MA_VERSION_MINOR; - } - - if (pRevision) { - *pRevision = MA_VERSION_REVISION; - } -} - -MA_API const char* ma_version_string(void) -{ - return MA_VERSION_STRING; -} - - -/****************************************************************************** - -Standard Library Stuff - -******************************************************************************/ -#ifndef MA_ASSERT -#define MA_ASSERT(condition) assert(condition) -#endif - -#ifndef MA_MALLOC -#define MA_MALLOC(sz) malloc((sz)) -#endif -#ifndef MA_REALLOC -#define MA_REALLOC(p, sz) realloc((p), (sz)) -#endif -#ifndef MA_FREE -#define MA_FREE(p) free((p)) -#endif - -static MA_INLINE void ma_zero_memory_default(void* p, size_t sz) -{ - if (p == NULL) { - MA_ASSERT(sz == 0); /* If this is triggered there's an error with the calling code. */ - return; - } - - if (sz > 0) { - memset(p, 0, sz); - } -} - - -#ifndef MA_ZERO_MEMORY -#define MA_ZERO_MEMORY(p, sz) ma_zero_memory_default((p), (sz)) -#endif -#ifndef MA_COPY_MEMORY -#define MA_COPY_MEMORY(dst, src, sz) memcpy((dst), (src), (sz)) -#endif -#ifndef MA_MOVE_MEMORY -#define MA_MOVE_MEMORY(dst, src, sz) memmove((dst), (src), (sz)) -#endif - -#define MA_ZERO_OBJECT(p) MA_ZERO_MEMORY((p), sizeof(*(p))) - -#define ma_countof(x) (sizeof(x) / sizeof(x[0])) -#define ma_max(x, y) (((x) > (y)) ? (x) : (y)) -#define ma_min(x, y) (((x) < (y)) ? (x) : (y)) -#define ma_abs(x) (((x) > 0) ? (x) : -(x)) -#define ma_clamp(x, lo, hi) (ma_max(lo, ma_min(x, hi))) -#define ma_offset_ptr(p, offset) (((ma_uint8*)(p)) + (offset)) -#define ma_align(x, a) ((x + (a-1)) & ~(a-1)) -#define ma_align_64(x) ma_align(x, 8) - -#define ma_buffer_frame_capacity(buffer, channels, format) (sizeof(buffer) / ma_get_bytes_per_sample(format) / (channels)) - -static MA_INLINE double ma_sind(double x) -{ - /* TODO: Implement custom sin(x). */ - return sin(x); -} - -static MA_INLINE double ma_expd(double x) -{ - /* TODO: Implement custom exp(x). */ - return exp(x); -} - -static MA_INLINE double ma_logd(double x) -{ - /* TODO: Implement custom log(x). */ - return log(x); -} - -static MA_INLINE double ma_powd(double x, double y) -{ - /* TODO: Implement custom pow(x, y). */ - return pow(x, y); -} - -static MA_INLINE double ma_sqrtd(double x) -{ - /* TODO: Implement custom sqrt(x). */ - return sqrt(x); -} - - -static MA_INLINE float ma_rsqrtf(float x) -{ - #if defined(MA_SUPPORT_SSE2) && !defined(MA_NO_SSE2) && (defined(MA_X64) || (defined(_M_IX86_FP) && _M_IX86_FP == 2) || defined(__SSE2__)) - { - /* - For SSE we can use RSQRTSS. - - This Stack Overflow post suggests that compilers don't necessarily generate optimal code - when using intrinsics: - - https://web.archive.org/web/20221211012522/https://stackoverflow.com/questions/32687079/getting-fewest-instructions-for-rsqrtss-wrapper - - I'm going to do something similar here, but a bit simpler. - */ - #if defined(__GNUC__) || defined(__clang__) - { - float result; - __asm__ __volatile__("rsqrtss %1, %0" : "=x"(result) : "x"(x)); - return result; - } - #else - { - return _mm_cvtss_f32(_mm_rsqrt_ss(_mm_set_ps1(x))); - } - #endif - } - #else - { - return 1 / (float)ma_sqrtd(x); - } - #endif -} - - -static MA_INLINE float ma_sinf(float x) -{ - return (float)ma_sind((float)x); -} - -static MA_INLINE double ma_cosd(double x) -{ - return ma_sind((MA_PI_D*0.5) - x); -} - -static MA_INLINE float ma_cosf(float x) -{ - return (float)ma_cosd((float)x); -} - -static MA_INLINE double ma_log10d(double x) -{ - return ma_logd(x) * 0.43429448190325182765; -} - -static MA_INLINE float ma_powf(float x, float y) -{ - return (float)ma_powd((double)x, (double)y); -} - -static MA_INLINE float ma_log10f(float x) -{ - return (float)ma_log10d((double)x); -} - - -static MA_INLINE double ma_degrees_to_radians(double degrees) -{ - return degrees * 0.01745329252; -} - -static MA_INLINE double ma_radians_to_degrees(double radians) -{ - return radians * 57.295779512896; -} - -static MA_INLINE float ma_degrees_to_radians_f(float degrees) -{ - return degrees * 0.01745329252f; -} - -static MA_INLINE float ma_radians_to_degrees_f(float radians) -{ - return radians * 57.295779512896f; -} - - -/* -Return Values: - 0: Success - 22: EINVAL - 34: ERANGE - -Not using symbolic constants for errors because I want to avoid #including errno.h -*/ -MA_API int ma_strcpy_s(char* dst, size_t dstSizeInBytes, const char* src) -{ - size_t i; - - if (dst == 0) { - return 22; - } - if (dstSizeInBytes == 0) { - return 34; - } - if (src == 0) { - dst[0] = '\0'; - return 22; - } - - for (i = 0; i < dstSizeInBytes && src[i] != '\0'; ++i) { - dst[i] = src[i]; - } - - if (i < dstSizeInBytes) { - dst[i] = '\0'; - return 0; - } - - dst[0] = '\0'; - return 34; -} - -MA_API int ma_wcscpy_s(wchar_t* dst, size_t dstCap, const wchar_t* src) -{ - size_t i; - - if (dst == 0) { - return 22; - } - if (dstCap == 0) { - return 34; - } - if (src == 0) { - dst[0] = '\0'; - return 22; - } - - for (i = 0; i < dstCap && src[i] != '\0'; ++i) { - dst[i] = src[i]; - } - - if (i < dstCap) { - dst[i] = '\0'; - return 0; - } - - dst[0] = '\0'; - return 34; -} - - -MA_API int ma_strncpy_s(char* dst, size_t dstSizeInBytes, const char* src, size_t count) -{ - size_t maxcount; - size_t i; - - if (dst == 0) { - return 22; - } - if (dstSizeInBytes == 0) { - return 34; - } - if (src == 0) { - dst[0] = '\0'; - return 22; - } - - maxcount = count; - if (count == ((size_t)-1) || count >= dstSizeInBytes) { /* -1 = _TRUNCATE */ - maxcount = dstSizeInBytes - 1; - } - - for (i = 0; i < maxcount && src[i] != '\0'; ++i) { - dst[i] = src[i]; - } - - if (src[i] == '\0' || i == count || count == ((size_t)-1)) { - dst[i] = '\0'; - return 0; - } - - dst[0] = '\0'; - return 34; -} - -MA_API int ma_strcat_s(char* dst, size_t dstSizeInBytes, const char* src) -{ - char* dstorig; - - if (dst == 0) { - return 22; - } - if (dstSizeInBytes == 0) { - return 34; - } - if (src == 0) { - dst[0] = '\0'; - return 22; - } - - dstorig = dst; - - while (dstSizeInBytes > 0 && dst[0] != '\0') { - dst += 1; - dstSizeInBytes -= 1; - } - - if (dstSizeInBytes == 0) { - return 22; /* Unterminated. */ - } - - - while (dstSizeInBytes > 0 && src[0] != '\0') { - *dst++ = *src++; - dstSizeInBytes -= 1; - } - - if (dstSizeInBytes > 0) { - dst[0] = '\0'; - } else { - dstorig[0] = '\0'; - return 34; - } - - return 0; -} - -MA_API int ma_strncat_s(char* dst, size_t dstSizeInBytes, const char* src, size_t count) -{ - char* dstorig; - - if (dst == 0) { - return 22; - } - if (dstSizeInBytes == 0) { - return 34; - } - if (src == 0) { - return 22; - } - - dstorig = dst; - - while (dstSizeInBytes > 0 && dst[0] != '\0') { - dst += 1; - dstSizeInBytes -= 1; - } - - if (dstSizeInBytes == 0) { - return 22; /* Unterminated. */ - } - - - if (count == ((size_t)-1)) { /* _TRUNCATE */ - count = dstSizeInBytes - 1; - } - - while (dstSizeInBytes > 0 && src[0] != '\0' && count > 0) { - *dst++ = *src++; - dstSizeInBytes -= 1; - count -= 1; - } - - if (dstSizeInBytes > 0) { - dst[0] = '\0'; - } else { - dstorig[0] = '\0'; - return 34; - } - - return 0; -} - -MA_API int ma_itoa_s(int value, char* dst, size_t dstSizeInBytes, int radix) -{ - int sign; - unsigned int valueU; - char* dstEnd; - - if (dst == NULL || dstSizeInBytes == 0) { - return 22; - } - if (radix < 2 || radix > 36) { - dst[0] = '\0'; - return 22; - } - - sign = (value < 0 && radix == 10) ? -1 : 1; /* The negative sign is only used when the base is 10. */ - - if (value < 0) { - valueU = -value; - } else { - valueU = value; - } - - dstEnd = dst; - do - { - int remainder = valueU % radix; - if (remainder > 9) { - *dstEnd = (char)((remainder - 10) + 'a'); - } else { - *dstEnd = (char)(remainder + '0'); - } - - dstEnd += 1; - dstSizeInBytes -= 1; - valueU /= radix; - } while (dstSizeInBytes > 0 && valueU > 0); - - if (dstSizeInBytes == 0) { - dst[0] = '\0'; - return 22; /* Ran out of room in the output buffer. */ - } - - if (sign < 0) { - *dstEnd++ = '-'; - dstSizeInBytes -= 1; - } - - if (dstSizeInBytes == 0) { - dst[0] = '\0'; - return 22; /* Ran out of room in the output buffer. */ - } - - *dstEnd = '\0'; - - - /* At this point the string will be reversed. */ - dstEnd -= 1; - while (dst < dstEnd) { - char temp = *dst; - *dst = *dstEnd; - *dstEnd = temp; - - dst += 1; - dstEnd -= 1; - } - - return 0; -} - -MA_API int ma_strcmp(const char* str1, const char* str2) -{ - if (str1 == str2) return 0; - - /* These checks differ from the standard implementation. It's not important, but I prefer it just for sanity. */ - if (str1 == NULL) return -1; - if (str2 == NULL) return 1; - - for (;;) { - if (str1[0] == '\0') { - break; - } - if (str1[0] != str2[0]) { - break; - } - - str1 += 1; - str2 += 1; - } - - return ((unsigned char*)str1)[0] - ((unsigned char*)str2)[0]; -} - -MA_API int ma_strappend(char* dst, size_t dstSize, const char* srcA, const char* srcB) -{ - int result; - - result = ma_strncpy_s(dst, dstSize, srcA, (size_t)-1); - if (result != 0) { - return result; - } - - result = ma_strncat_s(dst, dstSize, srcB, (size_t)-1); - if (result != 0) { - return result; - } - - return result; -} - -MA_API char* ma_copy_string(const char* src, const ma_allocation_callbacks* pAllocationCallbacks) -{ - size_t sz; - char* dst; - - if (src == NULL) { - return NULL; - } - - sz = strlen(src)+1; - dst = (char*)ma_malloc(sz, pAllocationCallbacks); - if (dst == NULL) { - return NULL; - } - - ma_strcpy_s(dst, sz, src); - - return dst; -} - -MA_API wchar_t* ma_copy_string_w(const wchar_t* src, const ma_allocation_callbacks* pAllocationCallbacks) -{ - size_t sz = wcslen(src)+1; - wchar_t* dst = (wchar_t*)ma_malloc(sz * sizeof(*dst), pAllocationCallbacks); - if (dst == NULL) { - return NULL; - } - - ma_wcscpy_s(dst, sz, src); - - return dst; -} - - - -#include -static ma_result ma_result_from_errno(int e) -{ - if (e == 0) { - return MA_SUCCESS; - } -#ifdef EPERM - else if (e == EPERM) { return MA_INVALID_OPERATION; } -#endif -#ifdef ENOENT - else if (e == ENOENT) { return MA_DOES_NOT_EXIST; } -#endif -#ifdef ESRCH - else if (e == ESRCH) { return MA_DOES_NOT_EXIST; } -#endif -#ifdef EINTR - else if (e == EINTR) { return MA_INTERRUPT; } -#endif -#ifdef EIO - else if (e == EIO) { return MA_IO_ERROR; } -#endif -#ifdef ENXIO - else if (e == ENXIO) { return MA_DOES_NOT_EXIST; } -#endif -#ifdef E2BIG - else if (e == E2BIG) { return MA_INVALID_ARGS; } -#endif -#ifdef ENOEXEC - else if (e == ENOEXEC) { return MA_INVALID_FILE; } -#endif -#ifdef EBADF - else if (e == EBADF) { return MA_INVALID_FILE; } -#endif -#ifdef ECHILD - else if (e == ECHILD) { return MA_ERROR; } -#endif -#ifdef EAGAIN - else if (e == EAGAIN) { return MA_UNAVAILABLE; } -#endif -#ifdef ENOMEM - else if (e == ENOMEM) { return MA_OUT_OF_MEMORY; } -#endif -#ifdef EACCES - else if (e == EACCES) { return MA_ACCESS_DENIED; } -#endif -#ifdef EFAULT - else if (e == EFAULT) { return MA_BAD_ADDRESS; } -#endif -#ifdef ENOTBLK - else if (e == ENOTBLK) { return MA_ERROR; } -#endif -#ifdef EBUSY - else if (e == EBUSY) { return MA_BUSY; } -#endif -#ifdef EEXIST - else if (e == EEXIST) { return MA_ALREADY_EXISTS; } -#endif -#ifdef EXDEV - else if (e == EXDEV) { return MA_ERROR; } -#endif -#ifdef ENODEV - else if (e == ENODEV) { return MA_DOES_NOT_EXIST; } -#endif -#ifdef ENOTDIR - else if (e == ENOTDIR) { return MA_NOT_DIRECTORY; } -#endif -#ifdef EISDIR - else if (e == EISDIR) { return MA_IS_DIRECTORY; } -#endif -#ifdef EINVAL - else if (e == EINVAL) { return MA_INVALID_ARGS; } -#endif -#ifdef ENFILE - else if (e == ENFILE) { return MA_TOO_MANY_OPEN_FILES; } -#endif -#ifdef EMFILE - else if (e == EMFILE) { return MA_TOO_MANY_OPEN_FILES; } -#endif -#ifdef ENOTTY - else if (e == ENOTTY) { return MA_INVALID_OPERATION; } -#endif -#ifdef ETXTBSY - else if (e == ETXTBSY) { return MA_BUSY; } -#endif -#ifdef EFBIG - else if (e == EFBIG) { return MA_TOO_BIG; } -#endif -#ifdef ENOSPC - else if (e == ENOSPC) { return MA_NO_SPACE; } -#endif -#ifdef ESPIPE - else if (e == ESPIPE) { return MA_BAD_SEEK; } -#endif -#ifdef EROFS - else if (e == EROFS) { return MA_ACCESS_DENIED; } -#endif -#ifdef EMLINK - else if (e == EMLINK) { return MA_TOO_MANY_LINKS; } -#endif -#ifdef EPIPE - else if (e == EPIPE) { return MA_BAD_PIPE; } -#endif -#ifdef EDOM - else if (e == EDOM) { return MA_OUT_OF_RANGE; } -#endif -#ifdef ERANGE - else if (e == ERANGE) { return MA_OUT_OF_RANGE; } -#endif -#ifdef EDEADLK - else if (e == EDEADLK) { return MA_DEADLOCK; } -#endif -#ifdef ENAMETOOLONG - else if (e == ENAMETOOLONG) { return MA_PATH_TOO_LONG; } -#endif -#ifdef ENOLCK - else if (e == ENOLCK) { return MA_ERROR; } -#endif -#ifdef ENOSYS - else if (e == ENOSYS) { return MA_NOT_IMPLEMENTED; } -#endif -#ifdef ENOTEMPTY - else if (e == ENOTEMPTY) { return MA_DIRECTORY_NOT_EMPTY; } -#endif -#ifdef ELOOP - else if (e == ELOOP) { return MA_TOO_MANY_LINKS; } -#endif -#ifdef ENOMSG - else if (e == ENOMSG) { return MA_NO_MESSAGE; } -#endif -#ifdef EIDRM - else if (e == EIDRM) { return MA_ERROR; } -#endif -#ifdef ECHRNG - else if (e == ECHRNG) { return MA_ERROR; } -#endif -#ifdef EL2NSYNC - else if (e == EL2NSYNC) { return MA_ERROR; } -#endif -#ifdef EL3HLT - else if (e == EL3HLT) { return MA_ERROR; } -#endif -#ifdef EL3RST - else if (e == EL3RST) { return MA_ERROR; } -#endif -#ifdef ELNRNG - else if (e == ELNRNG) { return MA_OUT_OF_RANGE; } -#endif -#ifdef EUNATCH - else if (e == EUNATCH) { return MA_ERROR; } -#endif -#ifdef ENOCSI - else if (e == ENOCSI) { return MA_ERROR; } -#endif -#ifdef EL2HLT - else if (e == EL2HLT) { return MA_ERROR; } -#endif -#ifdef EBADE - else if (e == EBADE) { return MA_ERROR; } -#endif -#ifdef EBADR - else if (e == EBADR) { return MA_ERROR; } -#endif -#ifdef EXFULL - else if (e == EXFULL) { return MA_ERROR; } -#endif -#ifdef ENOANO - else if (e == ENOANO) { return MA_ERROR; } -#endif -#ifdef EBADRQC - else if (e == EBADRQC) { return MA_ERROR; } -#endif -#ifdef EBADSLT - else if (e == EBADSLT) { return MA_ERROR; } -#endif -#ifdef EBFONT - else if (e == EBFONT) { return MA_INVALID_FILE; } -#endif -#ifdef ENOSTR - else if (e == ENOSTR) { return MA_ERROR; } -#endif -#ifdef ENODATA - else if (e == ENODATA) { return MA_NO_DATA_AVAILABLE; } -#endif -#ifdef ETIME - else if (e == ETIME) { return MA_TIMEOUT; } -#endif -#ifdef ENOSR - else if (e == ENOSR) { return MA_NO_DATA_AVAILABLE; } -#endif -#ifdef ENONET - else if (e == ENONET) { return MA_NO_NETWORK; } -#endif -#ifdef ENOPKG - else if (e == ENOPKG) { return MA_ERROR; } -#endif -#ifdef EREMOTE - else if (e == EREMOTE) { return MA_ERROR; } -#endif -#ifdef ENOLINK - else if (e == ENOLINK) { return MA_ERROR; } -#endif -#ifdef EADV - else if (e == EADV) { return MA_ERROR; } -#endif -#ifdef ESRMNT - else if (e == ESRMNT) { return MA_ERROR; } -#endif -#ifdef ECOMM - else if (e == ECOMM) { return MA_ERROR; } -#endif -#ifdef EPROTO - else if (e == EPROTO) { return MA_ERROR; } -#endif -#ifdef EMULTIHOP - else if (e == EMULTIHOP) { return MA_ERROR; } -#endif -#ifdef EDOTDOT - else if (e == EDOTDOT) { return MA_ERROR; } -#endif -#ifdef EBADMSG - else if (e == EBADMSG) { return MA_BAD_MESSAGE; } -#endif -#ifdef EOVERFLOW - else if (e == EOVERFLOW) { return MA_TOO_BIG; } -#endif -#ifdef ENOTUNIQ - else if (e == ENOTUNIQ) { return MA_NOT_UNIQUE; } -#endif -#ifdef EBADFD - else if (e == EBADFD) { return MA_ERROR; } -#endif -#ifdef EREMCHG - else if (e == EREMCHG) { return MA_ERROR; } -#endif -#ifdef ELIBACC - else if (e == ELIBACC) { return MA_ACCESS_DENIED; } -#endif -#ifdef ELIBBAD - else if (e == ELIBBAD) { return MA_INVALID_FILE; } -#endif -#ifdef ELIBSCN - else if (e == ELIBSCN) { return MA_INVALID_FILE; } -#endif -#ifdef ELIBMAX - else if (e == ELIBMAX) { return MA_ERROR; } -#endif -#ifdef ELIBEXEC - else if (e == ELIBEXEC) { return MA_ERROR; } -#endif -#ifdef EILSEQ - else if (e == EILSEQ) { return MA_INVALID_DATA; } -#endif -#ifdef ERESTART - else if (e == ERESTART) { return MA_ERROR; } -#endif -#ifdef ESTRPIPE - else if (e == ESTRPIPE) { return MA_ERROR; } -#endif -#ifdef EUSERS - else if (e == EUSERS) { return MA_ERROR; } -#endif -#ifdef ENOTSOCK - else if (e == ENOTSOCK) { return MA_NOT_SOCKET; } -#endif -#ifdef EDESTADDRREQ - else if (e == EDESTADDRREQ) { return MA_NO_ADDRESS; } -#endif -#ifdef EMSGSIZE - else if (e == EMSGSIZE) { return MA_TOO_BIG; } -#endif -#ifdef EPROTOTYPE - else if (e == EPROTOTYPE) { return MA_BAD_PROTOCOL; } -#endif -#ifdef ENOPROTOOPT - else if (e == ENOPROTOOPT) { return MA_PROTOCOL_UNAVAILABLE; } -#endif -#ifdef EPROTONOSUPPORT - else if (e == EPROTONOSUPPORT) { return MA_PROTOCOL_NOT_SUPPORTED; } -#endif -#ifdef ESOCKTNOSUPPORT - else if (e == ESOCKTNOSUPPORT) { return MA_SOCKET_NOT_SUPPORTED; } -#endif -#ifdef EOPNOTSUPP - else if (e == EOPNOTSUPP) { return MA_INVALID_OPERATION; } -#endif -#ifdef EPFNOSUPPORT - else if (e == EPFNOSUPPORT) { return MA_PROTOCOL_FAMILY_NOT_SUPPORTED; } -#endif -#ifdef EAFNOSUPPORT - else if (e == EAFNOSUPPORT) { return MA_ADDRESS_FAMILY_NOT_SUPPORTED; } -#endif -#ifdef EADDRINUSE - else if (e == EADDRINUSE) { return MA_ALREADY_IN_USE; } -#endif -#ifdef EADDRNOTAVAIL - else if (e == EADDRNOTAVAIL) { return MA_ERROR; } -#endif -#ifdef ENETDOWN - else if (e == ENETDOWN) { return MA_NO_NETWORK; } -#endif -#ifdef ENETUNREACH - else if (e == ENETUNREACH) { return MA_NO_NETWORK; } -#endif -#ifdef ENETRESET - else if (e == ENETRESET) { return MA_NO_NETWORK; } -#endif -#ifdef ECONNABORTED - else if (e == ECONNABORTED) { return MA_NO_NETWORK; } -#endif -#ifdef ECONNRESET - else if (e == ECONNRESET) { return MA_CONNECTION_RESET; } -#endif -#ifdef ENOBUFS - else if (e == ENOBUFS) { return MA_NO_SPACE; } -#endif -#ifdef EISCONN - else if (e == EISCONN) { return MA_ALREADY_CONNECTED; } -#endif -#ifdef ENOTCONN - else if (e == ENOTCONN) { return MA_NOT_CONNECTED; } -#endif -#ifdef ESHUTDOWN - else if (e == ESHUTDOWN) { return MA_ERROR; } -#endif -#ifdef ETOOMANYREFS - else if (e == ETOOMANYREFS) { return MA_ERROR; } -#endif -#ifdef ETIMEDOUT - else if (e == ETIMEDOUT) { return MA_TIMEOUT; } -#endif -#ifdef ECONNREFUSED - else if (e == ECONNREFUSED) { return MA_CONNECTION_REFUSED; } -#endif -#ifdef EHOSTDOWN - else if (e == EHOSTDOWN) { return MA_NO_HOST; } -#endif -#ifdef EHOSTUNREACH - else if (e == EHOSTUNREACH) { return MA_NO_HOST; } -#endif -#ifdef EALREADY - else if (e == EALREADY) { return MA_IN_PROGRESS; } -#endif -#ifdef EINPROGRESS - else if (e == EINPROGRESS) { return MA_IN_PROGRESS; } -#endif -#ifdef ESTALE - else if (e == ESTALE) { return MA_INVALID_FILE; } -#endif -#ifdef EUCLEAN - else if (e == EUCLEAN) { return MA_ERROR; } -#endif -#ifdef ENOTNAM - else if (e == ENOTNAM) { return MA_ERROR; } -#endif -#ifdef ENAVAIL - else if (e == ENAVAIL) { return MA_ERROR; } -#endif -#ifdef EISNAM - else if (e == EISNAM) { return MA_ERROR; } -#endif -#ifdef EREMOTEIO - else if (e == EREMOTEIO) { return MA_IO_ERROR; } -#endif -#ifdef EDQUOT - else if (e == EDQUOT) { return MA_NO_SPACE; } -#endif -#ifdef ENOMEDIUM - else if (e == ENOMEDIUM) { return MA_DOES_NOT_EXIST; } -#endif -#ifdef EMEDIUMTYPE - else if (e == EMEDIUMTYPE) { return MA_ERROR; } -#endif -#ifdef ECANCELED - else if (e == ECANCELED) { return MA_CANCELLED; } -#endif -#ifdef ENOKEY - else if (e == ENOKEY) { return MA_ERROR; } -#endif -#ifdef EKEYEXPIRED - else if (e == EKEYEXPIRED) { return MA_ERROR; } -#endif -#ifdef EKEYREVOKED - else if (e == EKEYREVOKED) { return MA_ERROR; } -#endif -#ifdef EKEYREJECTED - else if (e == EKEYREJECTED) { return MA_ERROR; } -#endif -#ifdef EOWNERDEAD - else if (e == EOWNERDEAD) { return MA_ERROR; } -#endif -#ifdef ENOTRECOVERABLE - else if (e == ENOTRECOVERABLE) { return MA_ERROR; } -#endif -#ifdef ERFKILL - else if (e == ERFKILL) { return MA_ERROR; } -#endif -#ifdef EHWPOISON - else if (e == EHWPOISON) { return MA_ERROR; } -#endif - else { - return MA_ERROR; - } -} - -MA_API ma_result ma_fopen(FILE** ppFile, const char* pFilePath, const char* pOpenMode) -{ -#if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err; -#endif - - if (ppFile != NULL) { - *ppFile = NULL; /* Safety. */ - } - - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(_MSC_VER) && _MSC_VER >= 1400 - err = fopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return ma_result_from_errno(err); - } -#else -#if defined(_WIN32) || defined(__APPLE__) - *ppFile = fopen(pFilePath, pOpenMode); -#else - #if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64 && defined(_LARGEFILE64_SOURCE) - *ppFile = fopen64(pFilePath, pOpenMode); - #else - *ppFile = fopen(pFilePath, pOpenMode); - #endif -#endif - if (*ppFile == NULL) { - ma_result result = ma_result_from_errno(errno); - if (result == MA_SUCCESS) { - result = MA_ERROR; /* Just a safety check to make sure we never ever return success when pFile == NULL. */ - } - - return result; - } -#endif - - return MA_SUCCESS; -} - - - -/* -_wfopen() isn't always available in all compilation environments. - - * Windows only. - * MSVC seems to support it universally as far back as VC6 from what I can tell (haven't checked further back). - * MinGW-64 (both 32- and 64-bit) seems to support it. - * MinGW wraps it in !defined(__STRICT_ANSI__). - * OpenWatcom wraps it in !defined(_NO_EXT_KEYS). - -This can be reviewed as compatibility issues arise. The preference is to use _wfopen_s() and _wfopen() as opposed to the wcsrtombs() -fallback, so if you notice your compiler not detecting this properly I'm happy to look at adding support. -*/ -#if defined(_WIN32) - #if defined(_MSC_VER) || defined(__MINGW64__) || (!defined(__STRICT_ANSI__) && !defined(_NO_EXT_KEYS)) - #define MA_HAS_WFOPEN - #endif -#endif - -MA_API ma_result ma_wfopen(FILE** ppFile, const wchar_t* pFilePath, const wchar_t* pOpenMode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (ppFile != NULL) { - *ppFile = NULL; /* Safety. */ - } - - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_HAS_WFOPEN) - { - /* Use _wfopen() on Windows. */ - #if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err = _wfopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return ma_result_from_errno(err); - } - #else - *ppFile = _wfopen(pFilePath, pOpenMode); - if (*ppFile == NULL) { - return ma_result_from_errno(errno); - } - #endif - (void)pAllocationCallbacks; - } -#else - /* - Use fopen() on anything other than Windows. Requires a conversion. This is annoying because fopen() is locale specific. The only real way I can - think of to do this is with wcsrtombs(). Note that wcstombs() is apparently not thread-safe because it uses a static global mbstate_t object for - maintaining state. I've checked this with -std=c89 and it works, but if somebody get's a compiler error I'll look into improving compatibility. - */ - { - mbstate_t mbs; - size_t lenMB; - const wchar_t* pFilePathTemp = pFilePath; - char* pFilePathMB = NULL; - char pOpenModeMB[32] = {0}; - - /* Get the length first. */ - MA_ZERO_OBJECT(&mbs); - lenMB = wcsrtombs(NULL, &pFilePathTemp, 0, &mbs); - if (lenMB == (size_t)-1) { - return ma_result_from_errno(errno); - } - - pFilePathMB = (char*)ma_malloc(lenMB + 1, pAllocationCallbacks); - if (pFilePathMB == NULL) { - return MA_OUT_OF_MEMORY; - } - - pFilePathTemp = pFilePath; - MA_ZERO_OBJECT(&mbs); - wcsrtombs(pFilePathMB, &pFilePathTemp, lenMB + 1, &mbs); - - /* The open mode should always consist of ASCII characters so we should be able to do a trivial conversion. */ - { - size_t i = 0; - for (;;) { - if (pOpenMode[i] == 0) { - pOpenModeMB[i] = '\0'; - break; - } - - pOpenModeMB[i] = (char)pOpenMode[i]; - i += 1; - } - } - - *ppFile = fopen(pFilePathMB, pOpenModeMB); - - ma_free(pFilePathMB, pAllocationCallbacks); - } - - if (*ppFile == NULL) { - return MA_ERROR; - } -#endif - - return MA_SUCCESS; -} - - - -static MA_INLINE void ma_copy_memory_64(void* dst, const void* src, ma_uint64 sizeInBytes) -{ -#if 0xFFFFFFFFFFFFFFFF <= MA_SIZE_MAX - MA_COPY_MEMORY(dst, src, (size_t)sizeInBytes); -#else - while (sizeInBytes > 0) { - ma_uint64 bytesToCopyNow = sizeInBytes; - if (bytesToCopyNow > MA_SIZE_MAX) { - bytesToCopyNow = MA_SIZE_MAX; - } - - MA_COPY_MEMORY(dst, src, (size_t)bytesToCopyNow); /* Safe cast to size_t. */ - - sizeInBytes -= bytesToCopyNow; - dst = ( void*)(( ma_uint8*)dst + bytesToCopyNow); - src = (const void*)((const ma_uint8*)src + bytesToCopyNow); - } -#endif -} - -static MA_INLINE void ma_zero_memory_64(void* dst, ma_uint64 sizeInBytes) -{ -#if 0xFFFFFFFFFFFFFFFF <= MA_SIZE_MAX - MA_ZERO_MEMORY(dst, (size_t)sizeInBytes); -#else - while (sizeInBytes > 0) { - ma_uint64 bytesToZeroNow = sizeInBytes; - if (bytesToZeroNow > MA_SIZE_MAX) { - bytesToZeroNow = MA_SIZE_MAX; - } - - MA_ZERO_MEMORY(dst, (size_t)bytesToZeroNow); /* Safe cast to size_t. */ - - sizeInBytes -= bytesToZeroNow; - dst = (void*)((ma_uint8*)dst + bytesToZeroNow); - } -#endif -} - - -/* Thanks to good old Bit Twiddling Hacks for this one: http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 */ -static MA_INLINE unsigned int ma_next_power_of_2(unsigned int x) -{ - x--; - x |= x >> 1; - x |= x >> 2; - x |= x >> 4; - x |= x >> 8; - x |= x >> 16; - x++; - - return x; -} - -static MA_INLINE unsigned int ma_prev_power_of_2(unsigned int x) -{ - return ma_next_power_of_2(x) >> 1; -} - -static MA_INLINE unsigned int ma_round_to_power_of_2(unsigned int x) -{ - unsigned int prev = ma_prev_power_of_2(x); - unsigned int next = ma_next_power_of_2(x); - if ((next - x) > (x - prev)) { - return prev; - } else { - return next; - } -} - -static MA_INLINE unsigned int ma_count_set_bits(unsigned int x) -{ - unsigned int count = 0; - while (x != 0) { - if (x & 1) { - count += 1; - } - - x = x >> 1; - } - - return count; -} - - - -/************************************************************************************************************************************************************** - -Allocation Callbacks - -**************************************************************************************************************************************************************/ -static void* ma__malloc_default(size_t sz, void* pUserData) -{ - (void)pUserData; - return MA_MALLOC(sz); -} - -static void* ma__realloc_default(void* p, size_t sz, void* pUserData) -{ - (void)pUserData; - return MA_REALLOC(p, sz); -} - -static void ma__free_default(void* p, void* pUserData) -{ - (void)pUserData; - MA_FREE(p); -} - -static ma_allocation_callbacks ma_allocation_callbacks_init_default(void) -{ - ma_allocation_callbacks callbacks; - callbacks.pUserData = NULL; - callbacks.onMalloc = ma__malloc_default; - callbacks.onRealloc = ma__realloc_default; - callbacks.onFree = ma__free_default; - - return callbacks; -} - -static ma_result ma_allocation_callbacks_init_copy(ma_allocation_callbacks* pDst, const ma_allocation_callbacks* pSrc) -{ - if (pDst == NULL) { - return MA_INVALID_ARGS; - } - - if (pSrc == NULL) { - *pDst = ma_allocation_callbacks_init_default(); - } else { - if (pSrc->pUserData == NULL && pSrc->onFree == NULL && pSrc->onMalloc == NULL && pSrc->onRealloc == NULL) { - *pDst = ma_allocation_callbacks_init_default(); - } else { - if (pSrc->onFree == NULL || (pSrc->onMalloc == NULL && pSrc->onRealloc == NULL)) { - return MA_INVALID_ARGS; /* Invalid allocation callbacks. */ - } else { - *pDst = *pSrc; - } - } - } - - return MA_SUCCESS; -} - - - - -/************************************************************************************************************************************************************** - -Logging - -**************************************************************************************************************************************************************/ -MA_API const char* ma_log_level_to_string(ma_uint32 logLevel) -{ - switch (logLevel) - { - case MA_LOG_LEVEL_DEBUG: return "DEBUG"; - case MA_LOG_LEVEL_INFO: return "INFO"; - case MA_LOG_LEVEL_WARNING: return "WARNING"; - case MA_LOG_LEVEL_ERROR: return "ERROR"; - default: return "ERROR"; - } -} - -#if defined(MA_DEBUG_OUTPUT) -#if defined(MA_ANDROID) - #include -#endif - -/* Customize this to use a specific tag in __android_log_print() for debug output messages. */ -#ifndef MA_ANDROID_LOG_TAG -#define MA_ANDROID_LOG_TAG "miniaudio" -#endif - -void ma_log_callback_debug(void* pUserData, ma_uint32 level, const char* pMessage) -{ - (void)pUserData; - - /* Special handling for some platforms. */ - #if defined(MA_ANDROID) - { - /* Android. */ - __android_log_print(ANDROID_LOG_DEBUG, MA_ANDROID_LOG_TAG, "%s: %s", ma_log_level_to_string(level), pMessage); - } - #else - { - /* Everything else. */ - printf("%s: %s", ma_log_level_to_string(level), pMessage); - } - #endif -} -#endif - -MA_API ma_log_callback ma_log_callback_init(ma_log_callback_proc onLog, void* pUserData) -{ - ma_log_callback callback; - - MA_ZERO_OBJECT(&callback); - callback.onLog = onLog; - callback.pUserData = pUserData; - - return callback; -} - - -MA_API ma_result ma_log_init(const ma_allocation_callbacks* pAllocationCallbacks, ma_log* pLog) -{ - if (pLog == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pLog); - ma_allocation_callbacks_init_copy(&pLog->allocationCallbacks, pAllocationCallbacks); - - /* We need a mutex for thread safety. */ - #ifndef MA_NO_THREADING - { - ma_result result = ma_mutex_init(&pLog->lock); - if (result != MA_SUCCESS) { - return result; - } - } - #endif - - /* If we're using debug output, enable it. */ - #if defined(MA_DEBUG_OUTPUT) - { - ma_log_register_callback(pLog, ma_log_callback_init(ma_log_callback_debug, NULL)); /* Doesn't really matter if this fails. */ - } - #endif - - return MA_SUCCESS; -} - -MA_API void ma_log_uninit(ma_log* pLog) -{ - if (pLog == NULL) { - return; - } - -#ifndef MA_NO_THREADING - ma_mutex_uninit(&pLog->lock); -#endif -} - -static void ma_log_lock(ma_log* pLog) -{ -#ifndef MA_NO_THREADING - ma_mutex_lock(&pLog->lock); -#else - (void)pLog; -#endif -} - -static void ma_log_unlock(ma_log* pLog) -{ -#ifndef MA_NO_THREADING - ma_mutex_unlock(&pLog->lock); -#else - (void)pLog; -#endif -} - -MA_API ma_result ma_log_register_callback(ma_log* pLog, ma_log_callback callback) -{ - ma_result result = MA_SUCCESS; - - if (pLog == NULL || callback.onLog == NULL) { - return MA_INVALID_ARGS; - } - - ma_log_lock(pLog); - { - if (pLog->callbackCount == ma_countof(pLog->callbacks)) { - result = MA_OUT_OF_MEMORY; /* Reached the maximum allowed log callbacks. */ - } else { - pLog->callbacks[pLog->callbackCount] = callback; - pLog->callbackCount += 1; - } - } - ma_log_unlock(pLog); - - return result; -} - -MA_API ma_result ma_log_unregister_callback(ma_log* pLog, ma_log_callback callback) -{ - if (pLog == NULL) { - return MA_INVALID_ARGS; - } - - ma_log_lock(pLog); - { - ma_uint32 iLog; - for (iLog = 0; iLog < pLog->callbackCount; ) { - if (pLog->callbacks[iLog].onLog == callback.onLog) { - /* Found. Move everything down a slot. */ - ma_uint32 jLog; - for (jLog = iLog; jLog < pLog->callbackCount-1; jLog += 1) { - pLog->callbacks[jLog] = pLog->callbacks[jLog + 1]; - } - - pLog->callbackCount -= 1; - } else { - /* Not found. */ - iLog += 1; - } - } - } - ma_log_unlock(pLog); - - return MA_SUCCESS; -} - -MA_API ma_result ma_log_post(ma_log* pLog, ma_uint32 level, const char* pMessage) -{ - if (pLog == NULL || pMessage == NULL) { - return MA_INVALID_ARGS; - } - - ma_log_lock(pLog); - { - ma_uint32 iLog; - for (iLog = 0; iLog < pLog->callbackCount; iLog += 1) { - if (pLog->callbacks[iLog].onLog) { - pLog->callbacks[iLog].onLog(pLog->callbacks[iLog].pUserData, level, pMessage); - } - } - } - ma_log_unlock(pLog); - - return MA_SUCCESS; -} - - -/* -We need to emulate _vscprintf() for the VC6 build. This can be more efficient, but since it's only VC6, and it's just a -logging function, I'm happy to keep this simple. In the VC6 build we can implement this in terms of _vsnprintf(). -*/ -#if defined(_MSC_VER) && _MSC_VER < 1900 -static int ma_vscprintf(const ma_allocation_callbacks* pAllocationCallbacks, const char* format, va_list args) -{ -#if _MSC_VER > 1200 - return _vscprintf(format, args); -#else - int result; - char* pTempBuffer = NULL; - size_t tempBufferCap = 1024; - - if (format == NULL) { - errno = EINVAL; - return -1; - } - - for (;;) { - char* pNewTempBuffer = (char*)ma_realloc(pTempBuffer, tempBufferCap, pAllocationCallbacks); - if (pNewTempBuffer == NULL) { - ma_free(pTempBuffer, pAllocationCallbacks); - errno = ENOMEM; - return -1; /* Out of memory. */ - } - - pTempBuffer = pNewTempBuffer; - - result = _vsnprintf(pTempBuffer, tempBufferCap, format, args); - ma_free(pTempBuffer, NULL); - - if (result != -1) { - break; /* Got it. */ - } - - /* Buffer wasn't big enough. Ideally it'd be nice to use an error code to know the reason for sure, but this is reliable enough. */ - tempBufferCap *= 2; - } - - return result; -#endif -} -#endif - -MA_API ma_result ma_log_postv(ma_log* pLog, ma_uint32 level, const char* pFormat, va_list args) -{ - if (pLog == NULL || pFormat == NULL) { - return MA_INVALID_ARGS; - } - - #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || ((!defined(_MSC_VER) || _MSC_VER >= 1900) && !defined(__STRICT_ANSI__) && !defined(_NO_EXT_KEYS)) || (defined(__cplusplus) && __cplusplus >= 201103L) - { - ma_result result; - int length; - char pFormattedMessageStack[1024]; - char* pFormattedMessageHeap = NULL; - - /* First try formatting into our fixed sized stack allocated buffer. If this is too small we'll fallback to a heap allocation. */ - length = vsnprintf(pFormattedMessageStack, sizeof(pFormattedMessageStack), pFormat, args); - if (length < 0) { - return MA_INVALID_OPERATION; /* An error occured when trying to convert the buffer. */ - } - - if ((size_t)length < sizeof(pFormattedMessageStack)) { - /* The string was written to the stack. */ - result = ma_log_post(pLog, level, pFormattedMessageStack); - } else { - /* The stack buffer was too small, try the heap. */ - pFormattedMessageHeap = (char*)ma_malloc(length + 1, &pLog->allocationCallbacks); - if (pFormattedMessageHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - - length = vsnprintf(pFormattedMessageHeap, length + 1, pFormat, args); - if (length < 0) { - ma_free(pFormattedMessageHeap, &pLog->allocationCallbacks); - return MA_INVALID_OPERATION; - } - - result = ma_log_post(pLog, level, pFormattedMessageHeap); - ma_free(pFormattedMessageHeap, &pLog->allocationCallbacks); - } - - return result; - } - #else - { - /* - Without snprintf() we need to first measure the string and then heap allocate it. I'm only aware of Visual Studio having support for this without snprintf(), so we'll - need to restrict this branch to Visual Studio. For other compilers we need to just not support formatted logging because I don't want the security risk of overflowing - a fixed sized stack allocated buffer. - */ - #if defined(_MSC_VER) && _MSC_VER >= 1200 /* 1200 = VC6 */ - { - ma_result result; - int formattedLen; - char* pFormattedMessage = NULL; - va_list args2; - - #if _MSC_VER >= 1800 - { - va_copy(args2, args); - } - #else - { - args2 = args; - } - #endif - - formattedLen = ma_vscprintf(&pLog->allocationCallbacks, pFormat, args2); - va_end(args2); - - if (formattedLen <= 0) { - return MA_INVALID_OPERATION; - } - - pFormattedMessage = (char*)ma_malloc(formattedLen + 1, &pLog->allocationCallbacks); - if (pFormattedMessage == NULL) { - return MA_OUT_OF_MEMORY; - } - - /* We'll get errors on newer versions of Visual Studio if we try to use vsprintf(). */ - #if _MSC_VER >= 1400 /* 1400 = Visual Studio 2005 */ - { - vsprintf_s(pFormattedMessage, formattedLen + 1, pFormat, args); - } - #else - { - vsprintf(pFormattedMessage, pFormat, args); - } - #endif - - result = ma_log_post(pLog, level, pFormattedMessage); - ma_free(pFormattedMessage, &pLog->allocationCallbacks); - - return result; - } - #else - { - /* Can't do anything because we don't have a safe way of to emulate vsnprintf() without a manual solution. */ - (void)level; - (void)args; - - return MA_INVALID_OPERATION; - } - #endif - } - #endif -} - -MA_API ma_result ma_log_postf(ma_log* pLog, ma_uint32 level, const char* pFormat, ...) -{ - ma_result result; - va_list args; - - if (pLog == NULL || pFormat == NULL) { - return MA_INVALID_ARGS; - } - - va_start(args, pFormat); - { - result = ma_log_postv(pLog, level, pFormat, args); - } - va_end(args); - - return result; -} - - - -static MA_INLINE ma_uint8 ma_clip_u8(ma_int32 x) -{ - return (ma_uint8)(ma_clamp(x, -128, 127) + 128); -} - -static MA_INLINE ma_int16 ma_clip_s16(ma_int32 x) -{ - return (ma_int16)ma_clamp(x, -32768, 32767); -} - -static MA_INLINE ma_int64 ma_clip_s24(ma_int64 x) -{ - return (ma_int64)ma_clamp(x, -8388608, 8388607); -} - -static MA_INLINE ma_int32 ma_clip_s32(ma_int64 x) -{ - /* This dance is to silence warnings with -std=c89. A good compiler should be able to optimize this away. */ - ma_int64 clipMin; - ma_int64 clipMax; - clipMin = -((ma_int64)2147483647 + 1); - clipMax = (ma_int64)2147483647; - - return (ma_int32)ma_clamp(x, clipMin, clipMax); -} - -static MA_INLINE float ma_clip_f32(float x) -{ - if (x < -1) return -1; - if (x > +1) return +1; - return x; -} - - -static MA_INLINE float ma_mix_f32(float x, float y, float a) -{ - return x*(1-a) + y*a; -} -static MA_INLINE float ma_mix_f32_fast(float x, float y, float a) -{ - float r0 = (y - x); - float r1 = r0*a; - return x + r1; - /*return x + (y - x)*a;*/ -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE __m128 ma_mix_f32_fast__sse2(__m128 x, __m128 y, __m128 a) -{ - return _mm_add_ps(x, _mm_mul_ps(_mm_sub_ps(y, x), a)); -} -#endif -#if defined(MA_SUPPORT_AVX2) -static MA_INLINE __m256 ma_mix_f32_fast__avx2(__m256 x, __m256 y, __m256 a) -{ - return _mm256_add_ps(x, _mm256_mul_ps(_mm256_sub_ps(y, x), a)); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE float32x4_t ma_mix_f32_fast__neon(float32x4_t x, float32x4_t y, float32x4_t a) -{ - return vaddq_f32(x, vmulq_f32(vsubq_f32(y, x), a)); -} -#endif - - -static MA_INLINE double ma_mix_f64(double x, double y, double a) -{ - return x*(1-a) + y*a; -} -static MA_INLINE double ma_mix_f64_fast(double x, double y, double a) -{ - return x + (y - x)*a; -} - -static MA_INLINE float ma_scale_to_range_f32(float x, float lo, float hi) -{ - return lo + x*(hi-lo); -} - - -/* -Greatest common factor using Euclid's algorithm iteratively. -*/ -static MA_INLINE ma_uint32 ma_gcf_u32(ma_uint32 a, ma_uint32 b) -{ - for (;;) { - if (b == 0) { - break; - } else { - ma_uint32 t = a; - a = b; - b = t % a; - } - } - - return a; -} - - -static ma_uint32 ma_ffs_32(ma_uint32 x) -{ - ma_uint32 i; - - /* Just a naive implementation just to get things working for now. Will optimize this later. */ - for (i = 0; i < 32; i += 1) { - if ((x & (1 << i)) != 0) { - return i; - } - } - - return i; -} - -static MA_INLINE ma_int16 ma_float_to_fixed_16(float x) -{ - return (ma_int16)(x * (1 << 8)); -} - - - -/* -Random Number Generation - -miniaudio uses the LCG random number generation algorithm. This is good enough for audio. - -Note that miniaudio's global LCG implementation uses global state which is _not_ thread-local. When this is called across -multiple threads, results will be unpredictable. However, it won't crash and results will still be random enough for -miniaudio's purposes. -*/ -#ifndef MA_DEFAULT_LCG_SEED -#define MA_DEFAULT_LCG_SEED 4321 -#endif - -#define MA_LCG_M 2147483647 -#define MA_LCG_A 48271 -#define MA_LCG_C 0 - -static ma_lcg g_maLCG = {MA_DEFAULT_LCG_SEED}; /* Non-zero initial seed. Use ma_seed() to use an explicit seed. */ - -static MA_INLINE void ma_lcg_seed(ma_lcg* pLCG, ma_int32 seed) -{ - MA_ASSERT(pLCG != NULL); - pLCG->state = seed; -} - -static MA_INLINE ma_int32 ma_lcg_rand_s32(ma_lcg* pLCG) -{ - pLCG->state = (MA_LCG_A * pLCG->state + MA_LCG_C) % MA_LCG_M; - return pLCG->state; -} - -static MA_INLINE ma_uint32 ma_lcg_rand_u32(ma_lcg* pLCG) -{ - return (ma_uint32)ma_lcg_rand_s32(pLCG); -} - -static MA_INLINE ma_int16 ma_lcg_rand_s16(ma_lcg* pLCG) -{ - return (ma_int16)(ma_lcg_rand_s32(pLCG) & 0xFFFF); -} - -static MA_INLINE double ma_lcg_rand_f64(ma_lcg* pLCG) -{ - return ma_lcg_rand_s32(pLCG) / (double)0x7FFFFFFF; -} - -static MA_INLINE float ma_lcg_rand_f32(ma_lcg* pLCG) -{ - return (float)ma_lcg_rand_f64(pLCG); -} - -static MA_INLINE float ma_lcg_rand_range_f32(ma_lcg* pLCG, float lo, float hi) -{ - return ma_scale_to_range_f32(ma_lcg_rand_f32(pLCG), lo, hi); -} - -static MA_INLINE ma_int32 ma_lcg_rand_range_s32(ma_lcg* pLCG, ma_int32 lo, ma_int32 hi) -{ - if (lo == hi) { - return lo; - } - - return lo + ma_lcg_rand_u32(pLCG) / (0xFFFFFFFF / (hi - lo + 1) + 1); -} - - - -static MA_INLINE void ma_seed(ma_int32 seed) -{ - ma_lcg_seed(&g_maLCG, seed); -} - -static MA_INLINE ma_int32 ma_rand_s32(void) -{ - return ma_lcg_rand_s32(&g_maLCG); -} - -static MA_INLINE ma_uint32 ma_rand_u32(void) -{ - return ma_lcg_rand_u32(&g_maLCG); -} - -static MA_INLINE double ma_rand_f64(void) -{ - return ma_lcg_rand_f64(&g_maLCG); -} - -static MA_INLINE float ma_rand_f32(void) -{ - return ma_lcg_rand_f32(&g_maLCG); -} - -static MA_INLINE float ma_rand_range_f32(float lo, float hi) -{ - return ma_lcg_rand_range_f32(&g_maLCG, lo, hi); -} - -static MA_INLINE ma_int32 ma_rand_range_s32(ma_int32 lo, ma_int32 hi) -{ - return ma_lcg_rand_range_s32(&g_maLCG, lo, hi); -} - - -static MA_INLINE float ma_dither_f32_rectangle(float ditherMin, float ditherMax) -{ - return ma_rand_range_f32(ditherMin, ditherMax); -} - -static MA_INLINE float ma_dither_f32_triangle(float ditherMin, float ditherMax) -{ - float a = ma_rand_range_f32(ditherMin, 0); - float b = ma_rand_range_f32(0, ditherMax); - return a + b; -} - -static MA_INLINE float ma_dither_f32(ma_dither_mode ditherMode, float ditherMin, float ditherMax) -{ - if (ditherMode == ma_dither_mode_rectangle) { - return ma_dither_f32_rectangle(ditherMin, ditherMax); - } - if (ditherMode == ma_dither_mode_triangle) { - return ma_dither_f32_triangle(ditherMin, ditherMax); - } - - return 0; -} - -static MA_INLINE ma_int32 ma_dither_s32(ma_dither_mode ditherMode, ma_int32 ditherMin, ma_int32 ditherMax) -{ - if (ditherMode == ma_dither_mode_rectangle) { - ma_int32 a = ma_rand_range_s32(ditherMin, ditherMax); - return a; - } - if (ditherMode == ma_dither_mode_triangle) { - ma_int32 a = ma_rand_range_s32(ditherMin, 0); - ma_int32 b = ma_rand_range_s32(0, ditherMax); - return a + b; - } - - return 0; -} - - -/************************************************************************************************************************************************************** - -Atomics - -**************************************************************************************************************************************************************/ -/* c89atomic.h begin */ -#ifndef c89atomic_h -#define c89atomic_h -#if defined(__cplusplus) -extern "C" { -#endif -typedef signed char c89atomic_int8; -typedef unsigned char c89atomic_uint8; -typedef signed short c89atomic_int16; -typedef unsigned short c89atomic_uint16; -typedef signed int c89atomic_int32; -typedef unsigned int c89atomic_uint32; -#if defined(_MSC_VER) && !defined(__clang__) - typedef signed __int64 c89atomic_int64; - typedef unsigned __int64 c89atomic_uint64; -#else - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wlong-long" - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc++11-long-long" - #endif - #endif - typedef signed long long c89atomic_int64; - typedef unsigned long long c89atomic_uint64; - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop - #endif -#endif -typedef int c89atomic_memory_order; -typedef unsigned char c89atomic_bool; -#if !defined(C89ATOMIC_64BIT) && !defined(C89ATOMIC_32BIT) -#ifdef _WIN32 -#ifdef _WIN64 -#define C89ATOMIC_64BIT -#else -#define C89ATOMIC_32BIT -#endif -#endif -#endif -#if !defined(C89ATOMIC_64BIT) && !defined(C89ATOMIC_32BIT) -#ifdef __GNUC__ -#ifdef __LP64__ -#define C89ATOMIC_64BIT -#else -#define C89ATOMIC_32BIT -#endif -#endif -#endif -#if !defined(C89ATOMIC_64BIT) && !defined(C89ATOMIC_32BIT) -#include -#if INTPTR_MAX == INT64_MAX -#define C89ATOMIC_64BIT -#else -#define C89ATOMIC_32BIT -#endif -#endif -#if defined(__arm__) || defined(_M_ARM) -#define C89ATOMIC_ARM32 -#endif -#if defined(__arm64) || defined(__arm64__) || defined(__aarch64__) || defined(_M_ARM64) -#define C89ATOMIC_ARM64 -#endif -#if defined(__x86_64__) || defined(_M_X64) -#define C89ATOMIC_X64 -#elif defined(__i386) || defined(_M_IX86) -#define C89ATOMIC_X86 -#elif defined(C89ATOMIC_ARM32) || defined(C89ATOMIC_ARM64) -#define C89ATOMIC_ARM -#endif -#if defined(_MSC_VER) - #define C89ATOMIC_INLINE __forceinline -#elif defined(__GNUC__) - #if defined(__STRICT_ANSI__) - #define C89ATOMIC_INLINE __inline__ __attribute__((always_inline)) - #else - #define C89ATOMIC_INLINE inline __attribute__((always_inline)) - #endif -#elif defined(__WATCOMC__) || defined(__DMC__) - #define C89ATOMIC_INLINE __inline -#else - #define C89ATOMIC_INLINE -#endif -#define C89ATOMIC_HAS_8 -#define C89ATOMIC_HAS_16 -#define C89ATOMIC_HAS_32 -#define C89ATOMIC_HAS_64 -#if (defined(_MSC_VER) ) || defined(__WATCOMC__) || defined(__DMC__) - #define C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, intrin, c89atomicType, msvcType) \ - c89atomicType result; \ - switch (order) \ - { \ - case c89atomic_memory_order_relaxed: \ - { \ - result = (c89atomicType)intrin##_nf((volatile msvcType*)dst, (msvcType)src); \ - } break; \ - case c89atomic_memory_order_consume: \ - case c89atomic_memory_order_acquire: \ - { \ - result = (c89atomicType)intrin##_acq((volatile msvcType*)dst, (msvcType)src); \ - } break; \ - case c89atomic_memory_order_release: \ - { \ - result = (c89atomicType)intrin##_rel((volatile msvcType*)dst, (msvcType)src); \ - } break; \ - case c89atomic_memory_order_acq_rel: \ - case c89atomic_memory_order_seq_cst: \ - default: \ - { \ - result = (c89atomicType)intrin((volatile msvcType*)dst, (msvcType)src); \ - } break; \ - } \ - return result; - #define C89ATOMIC_MSVC_ARM_INTRINSIC_COMPARE_EXCHANGE(ptr, expected, desired, order, intrin, c89atomicType, msvcType) \ - c89atomicType result; \ - switch (order) \ - { \ - case c89atomic_memory_order_relaxed: \ - { \ - result = (c89atomicType)intrin##_nf((volatile msvcType*)ptr, (msvcType)expected, (msvcType)desired); \ - } break; \ - case c89atomic_memory_order_consume: \ - case c89atomic_memory_order_acquire: \ - { \ - result = (c89atomicType)intrin##_acq((volatile msvcType*)ptr, (msvcType)expected, (msvcType)desired); \ - } break; \ - case c89atomic_memory_order_release: \ - { \ - result = (c89atomicType)intrin##_rel((volatile msvcType*)ptr, (msvcType)expected, (msvcType)desired); \ - } break; \ - case c89atomic_memory_order_acq_rel: \ - case c89atomic_memory_order_seq_cst: \ - default: \ - { \ - result = (c89atomicType)intrin((volatile msvcType*)ptr, (msvcType)expected, (msvcType)desired); \ - } break; \ - } \ - return result; - #define c89atomic_memory_order_relaxed 0 - #define c89atomic_memory_order_consume 1 - #define c89atomic_memory_order_acquire 2 - #define c89atomic_memory_order_release 3 - #define c89atomic_memory_order_acq_rel 4 - #define c89atomic_memory_order_seq_cst 5 - #if _MSC_VER < 1600 && defined(C89ATOMIC_X86) - #define C89ATOMIC_MSVC_USE_INLINED_ASSEMBLY - #endif - #if _MSC_VER < 1600 - #undef C89ATOMIC_HAS_8 - #undef C89ATOMIC_HAS_16 - #endif - #if !defined(C89ATOMIC_MSVC_USE_INLINED_ASSEMBLY) - #include - #endif - #if defined(C89ATOMIC_MSVC_USE_INLINED_ASSEMBLY) - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_compare_and_swap_8(volatile c89atomic_uint8* dst, c89atomic_uint8 expected, c89atomic_uint8 desired) - { - c89atomic_uint8 result = 0; - __asm { - mov ecx, dst - mov al, expected - mov dl, desired - lock cmpxchg [ecx], dl - mov result, al - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_compare_and_swap_16(volatile c89atomic_uint16* dst, c89atomic_uint16 expected, c89atomic_uint16 desired) - { - c89atomic_uint16 result = 0; - __asm { - mov ecx, dst - mov ax, expected - mov dx, desired - lock cmpxchg [ecx], dx - mov result, ax - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_compare_and_swap_32(volatile c89atomic_uint32* dst, c89atomic_uint32 expected, c89atomic_uint32 desired) - { - c89atomic_uint32 result = 0; - __asm { - mov ecx, dst - mov eax, expected - mov edx, desired - lock cmpxchg [ecx], edx - mov result, eax - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_64) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_compare_and_swap_64(volatile c89atomic_uint64* dst, c89atomic_uint64 expected, c89atomic_uint64 desired) - { - c89atomic_uint32 resultEAX = 0; - c89atomic_uint32 resultEDX = 0; - __asm { - mov esi, dst - mov eax, dword ptr expected - mov edx, dword ptr expected + 4 - mov ebx, dword ptr desired - mov ecx, dword ptr desired + 4 - lock cmpxchg8b qword ptr [esi] - mov resultEAX, eax - mov resultEDX, edx - } - return ((c89atomic_uint64)resultEDX << 32) | resultEAX; - } - #endif - #else - #if defined(C89ATOMIC_HAS_8) - #define c89atomic_compare_and_swap_8( dst, expected, desired) (c89atomic_uint8 )_InterlockedCompareExchange8((volatile char*)dst, (char)desired, (char)expected) - #endif - #if defined(C89ATOMIC_HAS_16) - #define c89atomic_compare_and_swap_16(dst, expected, desired) (c89atomic_uint16)_InterlockedCompareExchange16((volatile short*)dst, (short)desired, (short)expected) - #endif - #if defined(C89ATOMIC_HAS_32) - #define c89atomic_compare_and_swap_32(dst, expected, desired) (c89atomic_uint32)_InterlockedCompareExchange((volatile long*)dst, (long)desired, (long)expected) - #endif - #if defined(C89ATOMIC_HAS_64) - #define c89atomic_compare_and_swap_64(dst, expected, desired) (c89atomic_uint64)_InterlockedCompareExchange64((volatile c89atomic_int64*)dst, (c89atomic_int64)desired, (c89atomic_int64)expected) - #endif - #endif - #if defined(C89ATOMIC_MSVC_USE_INLINED_ASSEMBLY) - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_exchange_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 result = 0; - (void)order; - __asm { - mov ecx, dst - mov al, src - lock xchg [ecx], al - mov result, al - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_exchange_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 result = 0; - (void)order; - __asm { - mov ecx, dst - mov ax, src - lock xchg [ecx], ax - mov result, ax - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_exchange_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 result = 0; - (void)order; - __asm { - mov ecx, dst - mov eax, src - lock xchg [ecx], eax - mov result, eax - } - return result; - } - #endif - #else - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_exchange_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchange8, c89atomic_uint8, char); - #else - (void)order; - return (c89atomic_uint8)_InterlockedExchange8((volatile char*)dst, (char)src); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_exchange_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchange16, c89atomic_uint16, short); - #else - (void)order; - return (c89atomic_uint16)_InterlockedExchange16((volatile short*)dst, (short)src); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_exchange_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchange, c89atomic_uint32, long); - #else - (void)order; - return (c89atomic_uint32)_InterlockedExchange((volatile long*)dst, (long)src); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_64) && defined(C89ATOMIC_64BIT) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_exchange_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchange64, c89atomic_uint64, long long); - #else - (void)order; - return (c89atomic_uint64)_InterlockedExchange64((volatile long long*)dst, (long long)src); - #endif - } - #else - #endif - #endif - #if defined(C89ATOMIC_HAS_64) && !defined(C89ATOMIC_64BIT) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_exchange_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - do { - oldValue = *dst; - } while (c89atomic_compare_and_swap_64(dst, oldValue, src) != oldValue); - (void)order; - return oldValue; - } - #endif - #if defined(C89ATOMIC_MSVC_USE_INLINED_ASSEMBLY) - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_fetch_add_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 result = 0; - (void)order; - __asm { - mov ecx, dst - mov al, src - lock xadd [ecx], al - mov result, al - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_fetch_add_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 result = 0; - (void)order; - __asm { - mov ecx, dst - mov ax, src - lock xadd [ecx], ax - mov result, ax - } - return result; - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_fetch_add_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 result = 0; - (void)order; - __asm { - mov ecx, dst - mov eax, src - lock xadd [ecx], eax - mov result, eax - } - return result; - } - #endif - #else - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_fetch_add_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchangeAdd8, c89atomic_uint8, char); - #else - (void)order; - return (c89atomic_uint8)_InterlockedExchangeAdd8((volatile char*)dst, (char)src); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_fetch_add_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchangeAdd16, c89atomic_uint16, short); - #else - (void)order; - return (c89atomic_uint16)_InterlockedExchangeAdd16((volatile short*)dst, (short)src); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_fetch_add_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchangeAdd, c89atomic_uint32, long); - #else - (void)order; - return (c89atomic_uint32)_InterlockedExchangeAdd((volatile long*)dst, (long)src); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_64) && defined(C89ATOMIC_64BIT) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_fetch_add_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedExchangeAdd64, c89atomic_uint64, long long); - #else - (void)order; - return (c89atomic_uint64)_InterlockedExchangeAdd64((volatile long long*)dst, (long long)src); - #endif - } - #else - #endif - #endif - #if defined(C89ATOMIC_HAS_64) && !defined(C89ATOMIC_64BIT) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_fetch_add_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue + src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - #endif - #if defined(C89ATOMIC_MSVC_USE_INLINED_ASSEMBLY) - static C89ATOMIC_INLINE void __stdcall c89atomic_thread_fence(c89atomic_memory_order order) - { - (void)order; - __asm { - lock add [esp], 0 - } - } - #else - #if defined(C89ATOMIC_X64) - #define c89atomic_thread_fence(order) __faststorefence(), (void)order - #elif defined(C89ATOMIC_ARM64) - #define c89atomic_thread_fence(order) __dmb(_ARM64_BARRIER_ISH), (void)order - #else - static C89ATOMIC_INLINE void c89atomic_thread_fence(c89atomic_memory_order order) - { - volatile c89atomic_uint32 barrier = 0; - c89atomic_fetch_add_explicit_32(&barrier, 0, order); - } - #endif - #endif - #define c89atomic_compiler_fence() c89atomic_thread_fence(c89atomic_memory_order_seq_cst) - #define c89atomic_signal_fence(order) c89atomic_thread_fence(order) - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_load_explicit_8(volatile const c89atomic_uint8* ptr, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC_COMPARE_EXCHANGE(ptr, 0, 0, order, _InterlockedCompareExchange8, c89atomic_uint8, char); - #else - (void)order; - return c89atomic_compare_and_swap_8((volatile c89atomic_uint8*)ptr, 0, 0); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_load_explicit_16(volatile const c89atomic_uint16* ptr, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC_COMPARE_EXCHANGE(ptr, 0, 0, order, _InterlockedCompareExchange16, c89atomic_uint16, short); - #else - (void)order; - return c89atomic_compare_and_swap_16((volatile c89atomic_uint16*)ptr, 0, 0); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_load_explicit_32(volatile const c89atomic_uint32* ptr, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC_COMPARE_EXCHANGE(ptr, 0, 0, order, _InterlockedCompareExchange, c89atomic_uint32, long); - #else - (void)order; - return c89atomic_compare_and_swap_32((volatile c89atomic_uint32*)ptr, 0, 0); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_64) - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_load_explicit_64(volatile const c89atomic_uint64* ptr, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC_COMPARE_EXCHANGE(ptr, 0, 0, order, _InterlockedCompareExchange64, c89atomic_uint64, long long); - #else - (void)order; - return c89atomic_compare_and_swap_64((volatile c89atomic_uint64*)ptr, 0, 0); - #endif - } - #endif - #if defined(C89ATOMIC_HAS_8) - #define c89atomic_store_explicit_8( dst, src, order) (void)c89atomic_exchange_explicit_8 (dst, src, order) - #endif - #if defined(C89ATOMIC_HAS_16) - #define c89atomic_store_explicit_16(dst, src, order) (void)c89atomic_exchange_explicit_16(dst, src, order) - #endif - #if defined(C89ATOMIC_HAS_32) - #define c89atomic_store_explicit_32(dst, src, order) (void)c89atomic_exchange_explicit_32(dst, src, order) - #endif - #if defined(C89ATOMIC_HAS_64) - #define c89atomic_store_explicit_64(dst, src, order) (void)c89atomic_exchange_explicit_64(dst, src, order) - #endif - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_fetch_sub_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue - src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_fetch_sub_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue - src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_fetch_sub_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue - src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - #endif - #if defined(C89ATOMIC_HAS_64) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_fetch_sub_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue - src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - #endif - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_fetch_and_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedAnd8, c89atomic_uint8, char); - #else - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue & src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_fetch_and_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedAnd16, c89atomic_uint16, short); - #else - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue & src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_fetch_and_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedAnd, c89atomic_uint32, long); - #else - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue & src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_64) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_fetch_and_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedAnd64, c89atomic_uint64, long long); - #else - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue & src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_fetch_xor_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedXor8, c89atomic_uint8, char); - #else - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue ^ src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_fetch_xor_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedXor16, c89atomic_uint16, short); - #else - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue ^ src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_fetch_xor_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedXor, c89atomic_uint32, long); - #else - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue ^ src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_64) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_fetch_xor_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedXor64, c89atomic_uint64, long long); - #else - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue ^ src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_8) - static C89ATOMIC_INLINE c89atomic_uint8 __stdcall c89atomic_fetch_or_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedOr8, c89atomic_uint8, char); - #else - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue | src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_16) - static C89ATOMIC_INLINE c89atomic_uint16 __stdcall c89atomic_fetch_or_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedOr16, c89atomic_uint16, short); - #else - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue | src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_32) - static C89ATOMIC_INLINE c89atomic_uint32 __stdcall c89atomic_fetch_or_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedOr, c89atomic_uint32, long); - #else - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue | src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_64) - static C89ATOMIC_INLINE c89atomic_uint64 __stdcall c89atomic_fetch_or_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_ARM) - C89ATOMIC_MSVC_ARM_INTRINSIC(dst, src, order, _InterlockedOr64, c89atomic_uint64, long long); - #else - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue | src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - #endif - } - #endif - #if defined(C89ATOMIC_HAS_8) - #define c89atomic_test_and_set_explicit_8( dst, order) c89atomic_exchange_explicit_8 (dst, 1, order) - #endif - #if defined(C89ATOMIC_HAS_16) - #define c89atomic_test_and_set_explicit_16(dst, order) c89atomic_exchange_explicit_16(dst, 1, order) - #endif - #if defined(C89ATOMIC_HAS_32) - #define c89atomic_test_and_set_explicit_32(dst, order) c89atomic_exchange_explicit_32(dst, 1, order) - #endif - #if defined(C89ATOMIC_HAS_64) - #define c89atomic_test_and_set_explicit_64(dst, order) c89atomic_exchange_explicit_64(dst, 1, order) - #endif - #if defined(C89ATOMIC_HAS_8) - #define c89atomic_clear_explicit_8( dst, order) c89atomic_store_explicit_8 (dst, 0, order) - #endif - #if defined(C89ATOMIC_HAS_16) - #define c89atomic_clear_explicit_16(dst, order) c89atomic_store_explicit_16(dst, 0, order) - #endif - #if defined(C89ATOMIC_HAS_32) - #define c89atomic_clear_explicit_32(dst, order) c89atomic_store_explicit_32(dst, 0, order) - #endif - #if defined(C89ATOMIC_HAS_64) - #define c89atomic_clear_explicit_64(dst, order) c89atomic_store_explicit_64(dst, 0, order) - #endif - #if defined(C89ATOMIC_HAS_8) - typedef c89atomic_uint8 c89atomic_flag; - #define c89atomic_flag_test_and_set_explicit(ptr, order) (c89atomic_bool)c89atomic_test_and_set_explicit_8(ptr, order) - #define c89atomic_flag_clear_explicit(ptr, order) c89atomic_clear_explicit_8(ptr, order) - #define c89atoimc_flag_load_explicit(ptr, order) c89atomic_load_explicit_8(ptr, order) - #else - typedef c89atomic_uint32 c89atomic_flag; - #define c89atomic_flag_test_and_set_explicit(ptr, order) (c89atomic_bool)c89atomic_test_and_set_explicit_32(ptr, order) - #define c89atomic_flag_clear_explicit(ptr, order) c89atomic_clear_explicit_32(ptr, order) - #define c89atoimc_flag_load_explicit(ptr, order) c89atomic_load_explicit_32(ptr, order) - #endif -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7))) - #define C89ATOMIC_HAS_NATIVE_COMPARE_EXCHANGE - #define C89ATOMIC_HAS_NATIVE_IS_LOCK_FREE - #define c89atomic_memory_order_relaxed __ATOMIC_RELAXED - #define c89atomic_memory_order_consume __ATOMIC_CONSUME - #define c89atomic_memory_order_acquire __ATOMIC_ACQUIRE - #define c89atomic_memory_order_release __ATOMIC_RELEASE - #define c89atomic_memory_order_acq_rel __ATOMIC_ACQ_REL - #define c89atomic_memory_order_seq_cst __ATOMIC_SEQ_CST - #define c89atomic_compiler_fence() __asm__ __volatile__("":::"memory") - #define c89atomic_thread_fence(order) __atomic_thread_fence(order) - #define c89atomic_signal_fence(order) __atomic_signal_fence(order) - #define c89atomic_is_lock_free_8(ptr) __atomic_is_lock_free(1, ptr) - #define c89atomic_is_lock_free_16(ptr) __atomic_is_lock_free(2, ptr) - #define c89atomic_is_lock_free_32(ptr) __atomic_is_lock_free(4, ptr) - #define c89atomic_is_lock_free_64(ptr) __atomic_is_lock_free(8, ptr) - #define c89atomic_test_and_set_explicit_8( dst, order) __atomic_exchange_n(dst, 1, order) - #define c89atomic_test_and_set_explicit_16(dst, order) __atomic_exchange_n(dst, 1, order) - #define c89atomic_test_and_set_explicit_32(dst, order) __atomic_exchange_n(dst, 1, order) - #define c89atomic_test_and_set_explicit_64(dst, order) __atomic_exchange_n(dst, 1, order) - #define c89atomic_clear_explicit_8( dst, order) __atomic_store_n(dst, 0, order) - #define c89atomic_clear_explicit_16(dst, order) __atomic_store_n(dst, 0, order) - #define c89atomic_clear_explicit_32(dst, order) __atomic_store_n(dst, 0, order) - #define c89atomic_clear_explicit_64(dst, order) __atomic_store_n(dst, 0, order) - #define c89atomic_store_explicit_8( dst, src, order) __atomic_store_n(dst, src, order) - #define c89atomic_store_explicit_16(dst, src, order) __atomic_store_n(dst, src, order) - #define c89atomic_store_explicit_32(dst, src, order) __atomic_store_n(dst, src, order) - #define c89atomic_store_explicit_64(dst, src, order) __atomic_store_n(dst, src, order) - #define c89atomic_load_explicit_8( dst, order) __atomic_load_n(dst, order) - #define c89atomic_load_explicit_16(dst, order) __atomic_load_n(dst, order) - #define c89atomic_load_explicit_32(dst, order) __atomic_load_n(dst, order) - #define c89atomic_load_explicit_64(dst, order) __atomic_load_n(dst, order) - #define c89atomic_exchange_explicit_8( dst, src, order) __atomic_exchange_n(dst, src, order) - #define c89atomic_exchange_explicit_16(dst, src, order) __atomic_exchange_n(dst, src, order) - #define c89atomic_exchange_explicit_32(dst, src, order) __atomic_exchange_n(dst, src, order) - #define c89atomic_exchange_explicit_64(dst, src, order) __atomic_exchange_n(dst, src, order) - #define c89atomic_compare_exchange_strong_explicit_8( dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 0, successOrder, failureOrder) - #define c89atomic_compare_exchange_strong_explicit_16(dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 0, successOrder, failureOrder) - #define c89atomic_compare_exchange_strong_explicit_32(dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 0, successOrder, failureOrder) - #define c89atomic_compare_exchange_strong_explicit_64(dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 0, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_8( dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 1, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_16(dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 1, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_32(dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 1, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_64(dst, expected, desired, successOrder, failureOrder) __atomic_compare_exchange_n(dst, expected, desired, 1, successOrder, failureOrder) - #define c89atomic_fetch_add_explicit_8( dst, src, order) __atomic_fetch_add(dst, src, order) - #define c89atomic_fetch_add_explicit_16(dst, src, order) __atomic_fetch_add(dst, src, order) - #define c89atomic_fetch_add_explicit_32(dst, src, order) __atomic_fetch_add(dst, src, order) - #define c89atomic_fetch_add_explicit_64(dst, src, order) __atomic_fetch_add(dst, src, order) - #define c89atomic_fetch_sub_explicit_8( dst, src, order) __atomic_fetch_sub(dst, src, order) - #define c89atomic_fetch_sub_explicit_16(dst, src, order) __atomic_fetch_sub(dst, src, order) - #define c89atomic_fetch_sub_explicit_32(dst, src, order) __atomic_fetch_sub(dst, src, order) - #define c89atomic_fetch_sub_explicit_64(dst, src, order) __atomic_fetch_sub(dst, src, order) - #define c89atomic_fetch_or_explicit_8( dst, src, order) __atomic_fetch_or(dst, src, order) - #define c89atomic_fetch_or_explicit_16(dst, src, order) __atomic_fetch_or(dst, src, order) - #define c89atomic_fetch_or_explicit_32(dst, src, order) __atomic_fetch_or(dst, src, order) - #define c89atomic_fetch_or_explicit_64(dst, src, order) __atomic_fetch_or(dst, src, order) - #define c89atomic_fetch_xor_explicit_8( dst, src, order) __atomic_fetch_xor(dst, src, order) - #define c89atomic_fetch_xor_explicit_16(dst, src, order) __atomic_fetch_xor(dst, src, order) - #define c89atomic_fetch_xor_explicit_32(dst, src, order) __atomic_fetch_xor(dst, src, order) - #define c89atomic_fetch_xor_explicit_64(dst, src, order) __atomic_fetch_xor(dst, src, order) - #define c89atomic_fetch_and_explicit_8( dst, src, order) __atomic_fetch_and(dst, src, order) - #define c89atomic_fetch_and_explicit_16(dst, src, order) __atomic_fetch_and(dst, src, order) - #define c89atomic_fetch_and_explicit_32(dst, src, order) __atomic_fetch_and(dst, src, order) - #define c89atomic_fetch_and_explicit_64(dst, src, order) __atomic_fetch_and(dst, src, order) - #define c89atomic_compare_and_swap_8 (dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #define c89atomic_compare_and_swap_16(dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #define c89atomic_compare_and_swap_32(dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #define c89atomic_compare_and_swap_64(dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - typedef c89atomic_uint8 c89atomic_flag; - #define c89atomic_flag_test_and_set_explicit(dst, order) (c89atomic_bool)__atomic_test_and_set(dst, order) - #define c89atomic_flag_clear_explicit(dst, order) __atomic_clear(dst, order) - #define c89atoimc_flag_load_explicit(ptr, order) c89atomic_load_explicit_8(ptr, order) -#else - #define c89atomic_memory_order_relaxed 1 - #define c89atomic_memory_order_consume 2 - #define c89atomic_memory_order_acquire 3 - #define c89atomic_memory_order_release 4 - #define c89atomic_memory_order_acq_rel 5 - #define c89atomic_memory_order_seq_cst 6 - #define c89atomic_compiler_fence() __asm__ __volatile__("":::"memory") - #if defined(__GNUC__) - #define c89atomic_thread_fence(order) __sync_synchronize(), (void)order - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_exchange_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - if (order > c89atomic_memory_order_acquire) { - __sync_synchronize(); - } - return __sync_lock_test_and_set(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_exchange_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 oldValue; - do { - oldValue = *dst; - } while (__sync_val_compare_and_swap(dst, oldValue, src) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_exchange_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 oldValue; - do { - oldValue = *dst; - } while (__sync_val_compare_and_swap(dst, oldValue, src) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_exchange_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - do { - oldValue = *dst; - } while (__sync_val_compare_and_swap(dst, oldValue, src) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_add_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_add(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_add_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_add(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_add_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_add(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_add_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_add(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_sub_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_sub(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_sub_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_sub(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_sub_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_sub(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_sub_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_sub(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_or_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_or(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_or_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_or(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_or_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_or(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_or_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_or(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_xor_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_xor(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_xor_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_xor(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_xor_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_xor(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_xor_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_xor(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_and_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_and(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_and_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_and(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_and_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_and(dst, src); - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_and_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - (void)order; - return __sync_fetch_and_and(dst, src); - } - #define c89atomic_compare_and_swap_8( dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #define c89atomic_compare_and_swap_16(dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #define c89atomic_compare_and_swap_32(dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #define c89atomic_compare_and_swap_64(dst, expected, desired) __sync_val_compare_and_swap(dst, expected, desired) - #else - #if defined(C89ATOMIC_X86) - #define c89atomic_thread_fence(order) __asm__ __volatile__("lock; addl $0, (%%esp)" ::: "memory", "cc") - #elif defined(C89ATOMIC_X64) - #define c89atomic_thread_fence(order) __asm__ __volatile__("lock; addq $0, (%%rsp)" ::: "memory", "cc") - #else - #error Unsupported architecture. Please submit a feature request. - #endif - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_compare_and_swap_8(volatile c89atomic_uint8* dst, c89atomic_uint8 expected, c89atomic_uint8 desired) - { - c89atomic_uint8 result; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; cmpxchg %3, %0" : "+m"(*dst), "=a"(result) : "a"(expected), "d"(desired) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_compare_and_swap_16(volatile c89atomic_uint16* dst, c89atomic_uint16 expected, c89atomic_uint16 desired) - { - c89atomic_uint16 result; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; cmpxchg %3, %0" : "+m"(*dst), "=a"(result) : "a"(expected), "d"(desired) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_compare_and_swap_32(volatile c89atomic_uint32* dst, c89atomic_uint32 expected, c89atomic_uint32 desired) - { - c89atomic_uint32 result; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; cmpxchg %3, %0" : "+m"(*dst), "=a"(result) : "a"(expected), "d"(desired) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_compare_and_swap_64(volatile c89atomic_uint64* dst, c89atomic_uint64 expected, c89atomic_uint64 desired) - { - volatile c89atomic_uint64 result; - #if defined(C89ATOMIC_X86) - c89atomic_uint32 resultEAX; - c89atomic_uint32 resultEDX; - __asm__ __volatile__("push %%ebx; xchg %5, %%ebx; lock; cmpxchg8b %0; pop %%ebx" : "+m"(*dst), "=a"(resultEAX), "=d"(resultEDX) : "a"(expected & 0xFFFFFFFF), "d"(expected >> 32), "r"(desired & 0xFFFFFFFF), "c"(desired >> 32) : "cc"); - result = ((c89atomic_uint64)resultEDX << 32) | resultEAX; - #elif defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; cmpxchg %3, %0" : "+m"(*dst), "=a"(result) : "a"(expected), "d"(desired) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_exchange_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 result = 0; - (void)order; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xchg %1, %0" : "+m"(*dst), "=a"(result) : "a"(src)); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_exchange_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 result = 0; - (void)order; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xchg %1, %0" : "+m"(*dst), "=a"(result) : "a"(src)); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_exchange_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 result; - (void)order; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xchg %1, %0" : "+m"(*dst), "=a"(result) : "a"(src)); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_exchange_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 result; - (void)order; - #if defined(C89ATOMIC_X86) - do { - result = *dst; - } while (c89atomic_compare_and_swap_64(dst, result, src) != result); - #elif defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xchg %1, %0" : "+m"(*dst), "=a"(result) : "a"(src)); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_add_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 result; - (void)order; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xadd %1, %0" : "+m"(*dst), "=a"(result) : "a"(src) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_add_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 result; - (void)order; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xadd %1, %0" : "+m"(*dst), "=a"(result) : "a"(src) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_add_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 result; - (void)order; - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - __asm__ __volatile__("lock; xadd %1, %0" : "+m"(*dst), "=a"(result) : "a"(src) : "cc"); - #else - #error Unsupported architecture. Please submit a feature request. - #endif - return result; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_add_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - #if defined(C89ATOMIC_X86) - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - (void)order; - do { - oldValue = *dst; - newValue = oldValue + src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - return oldValue; - #elif defined(C89ATOMIC_X64) - c89atomic_uint64 result; - (void)order; - __asm__ __volatile__("lock; xadd %1, %0" : "+m"(*dst), "=a"(result) : "a"(src) : "cc"); - return result; - #endif - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_sub_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue - src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_sub_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue - src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_sub_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue - src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_sub_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue - src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_and_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue & src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_and_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue & src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_and_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue & src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_and_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue & src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_xor_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue ^ src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_xor_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue ^ src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_xor_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue ^ src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_xor_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue ^ src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_fetch_or_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8 src, c89atomic_memory_order order) - { - c89atomic_uint8 oldValue; - c89atomic_uint8 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint8)(oldValue | src); - } while (c89atomic_compare_and_swap_8(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_fetch_or_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16 src, c89atomic_memory_order order) - { - c89atomic_uint16 oldValue; - c89atomic_uint16 newValue; - do { - oldValue = *dst; - newValue = (c89atomic_uint16)(oldValue | src); - } while (c89atomic_compare_and_swap_16(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_fetch_or_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32 src, c89atomic_memory_order order) - { - c89atomic_uint32 oldValue; - c89atomic_uint32 newValue; - do { - oldValue = *dst; - newValue = oldValue | src; - } while (c89atomic_compare_and_swap_32(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_fetch_or_explicit_64(volatile c89atomic_uint64* dst, c89atomic_uint64 src, c89atomic_memory_order order) - { - c89atomic_uint64 oldValue; - c89atomic_uint64 newValue; - do { - oldValue = *dst; - newValue = oldValue | src; - } while (c89atomic_compare_and_swap_64(dst, oldValue, newValue) != oldValue); - (void)order; - return oldValue; - } - #endif - #define c89atomic_signal_fence(order) c89atomic_thread_fence(order) - static C89ATOMIC_INLINE c89atomic_uint8 c89atomic_load_explicit_8(volatile const c89atomic_uint8* ptr, c89atomic_memory_order order) - { - (void)order; - return c89atomic_compare_and_swap_8((c89atomic_uint8*)ptr, 0, 0); - } - static C89ATOMIC_INLINE c89atomic_uint16 c89atomic_load_explicit_16(volatile const c89atomic_uint16* ptr, c89atomic_memory_order order) - { - (void)order; - return c89atomic_compare_and_swap_16((c89atomic_uint16*)ptr, 0, 0); - } - static C89ATOMIC_INLINE c89atomic_uint32 c89atomic_load_explicit_32(volatile const c89atomic_uint32* ptr, c89atomic_memory_order order) - { - (void)order; - return c89atomic_compare_and_swap_32((c89atomic_uint32*)ptr, 0, 0); - } - static C89ATOMIC_INLINE c89atomic_uint64 c89atomic_load_explicit_64(volatile const c89atomic_uint64* ptr, c89atomic_memory_order order) - { - (void)order; - return c89atomic_compare_and_swap_64((c89atomic_uint64*)ptr, 0, 0); - } - #define c89atomic_store_explicit_8( dst, src, order) (void)c89atomic_exchange_explicit_8 (dst, src, order) - #define c89atomic_store_explicit_16(dst, src, order) (void)c89atomic_exchange_explicit_16(dst, src, order) - #define c89atomic_store_explicit_32(dst, src, order) (void)c89atomic_exchange_explicit_32(dst, src, order) - #define c89atomic_store_explicit_64(dst, src, order) (void)c89atomic_exchange_explicit_64(dst, src, order) - #define c89atomic_test_and_set_explicit_8( dst, order) c89atomic_exchange_explicit_8 (dst, 1, order) - #define c89atomic_test_and_set_explicit_16(dst, order) c89atomic_exchange_explicit_16(dst, 1, order) - #define c89atomic_test_and_set_explicit_32(dst, order) c89atomic_exchange_explicit_32(dst, 1, order) - #define c89atomic_test_and_set_explicit_64(dst, order) c89atomic_exchange_explicit_64(dst, 1, order) - #define c89atomic_clear_explicit_8( dst, order) c89atomic_store_explicit_8 (dst, 0, order) - #define c89atomic_clear_explicit_16(dst, order) c89atomic_store_explicit_16(dst, 0, order) - #define c89atomic_clear_explicit_32(dst, order) c89atomic_store_explicit_32(dst, 0, order) - #define c89atomic_clear_explicit_64(dst, order) c89atomic_store_explicit_64(dst, 0, order) - typedef c89atomic_uint8 c89atomic_flag; - #define c89atomic_flag_test_and_set_explicit(ptr, order) (c89atomic_bool)c89atomic_test_and_set_explicit_8(ptr, order) - #define c89atomic_flag_clear_explicit(ptr, order) c89atomic_clear_explicit_8(ptr, order) - #define c89atoimc_flag_load_explicit(ptr, order) c89atomic_load_explicit_8(ptr, order) -#endif -#if !defined(C89ATOMIC_HAS_NATIVE_COMPARE_EXCHANGE) - #if defined(C89ATOMIC_HAS_8) - c89atomic_bool c89atomic_compare_exchange_strong_explicit_8(volatile c89atomic_uint8* dst, c89atomic_uint8* expected, c89atomic_uint8 desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - c89atomic_uint8 expectedValue; - c89atomic_uint8 result; - (void)successOrder; - (void)failureOrder; - expectedValue = c89atomic_load_explicit_8(expected, c89atomic_memory_order_seq_cst); - result = c89atomic_compare_and_swap_8(dst, expectedValue, desired); - if (result == expectedValue) { - return 1; - } else { - c89atomic_store_explicit_8(expected, result, failureOrder); - return 0; - } - } - #endif - #if defined(C89ATOMIC_HAS_16) - c89atomic_bool c89atomic_compare_exchange_strong_explicit_16(volatile c89atomic_uint16* dst, c89atomic_uint16* expected, c89atomic_uint16 desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - c89atomic_uint16 expectedValue; - c89atomic_uint16 result; - (void)successOrder; - (void)failureOrder; - expectedValue = c89atomic_load_explicit_16(expected, c89atomic_memory_order_seq_cst); - result = c89atomic_compare_and_swap_16(dst, expectedValue, desired); - if (result == expectedValue) { - return 1; - } else { - c89atomic_store_explicit_16(expected, result, failureOrder); - return 0; - } - } - #endif - #if defined(C89ATOMIC_HAS_32) - c89atomic_bool c89atomic_compare_exchange_strong_explicit_32(volatile c89atomic_uint32* dst, c89atomic_uint32* expected, c89atomic_uint32 desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - c89atomic_uint32 expectedValue; - c89atomic_uint32 result; - (void)successOrder; - (void)failureOrder; - expectedValue = c89atomic_load_explicit_32(expected, c89atomic_memory_order_seq_cst); - result = c89atomic_compare_and_swap_32(dst, expectedValue, desired); - if (result == expectedValue) { - return 1; - } else { - c89atomic_store_explicit_32(expected, result, failureOrder); - return 0; - } - } - #endif - #if defined(C89ATOMIC_HAS_64) - c89atomic_bool c89atomic_compare_exchange_strong_explicit_64(volatile c89atomic_uint64* dst, volatile c89atomic_uint64* expected, c89atomic_uint64 desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - c89atomic_uint64 expectedValue; - c89atomic_uint64 result; - (void)successOrder; - (void)failureOrder; - expectedValue = c89atomic_load_explicit_64(expected, c89atomic_memory_order_seq_cst); - result = c89atomic_compare_and_swap_64(dst, expectedValue, desired); - if (result == expectedValue) { - return 1; - } else { - c89atomic_store_explicit_64(expected, result, failureOrder); - return 0; - } - } - #endif - #define c89atomic_compare_exchange_weak_explicit_8( dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_8 (dst, expected, desired, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_16(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_16(dst, expected, desired, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_32(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_32(dst, expected, desired, successOrder, failureOrder) - #define c89atomic_compare_exchange_weak_explicit_64(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_64(dst, expected, desired, successOrder, failureOrder) -#endif -#if !defined(C89ATOMIC_HAS_NATIVE_IS_LOCK_FREE) - static C89ATOMIC_INLINE c89atomic_bool c89atomic_is_lock_free_8(volatile void* ptr) - { - (void)ptr; - return 1; - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_is_lock_free_16(volatile void* ptr) - { - (void)ptr; - return 1; - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_is_lock_free_32(volatile void* ptr) - { - (void)ptr; - return 1; - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_is_lock_free_64(volatile void* ptr) - { - (void)ptr; - #if defined(C89ATOMIC_64BIT) - return 1; - #else - #if defined(C89ATOMIC_X86) || defined(C89ATOMIC_X64) - return 1; - #else - return 0; - #endif - #endif - } -#endif -#if defined(C89ATOMIC_64BIT) - static C89ATOMIC_INLINE c89atomic_bool c89atomic_is_lock_free_ptr(volatile void** ptr) - { - return c89atomic_is_lock_free_64((volatile c89atomic_uint64*)ptr); - } - static C89ATOMIC_INLINE void* c89atomic_load_explicit_ptr(volatile void** ptr, c89atomic_memory_order order) - { - return (void*)c89atomic_load_explicit_64((volatile c89atomic_uint64*)ptr, order); - } - static C89ATOMIC_INLINE void c89atomic_store_explicit_ptr(volatile void** dst, void* src, c89atomic_memory_order order) - { - c89atomic_store_explicit_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64)src, order); - } - static C89ATOMIC_INLINE void* c89atomic_exchange_explicit_ptr(volatile void** dst, void* src, c89atomic_memory_order order) - { - return (void*)c89atomic_exchange_explicit_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64)src, order); - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_strong_explicit_ptr(volatile void** dst, void** expected, void* desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - return c89atomic_compare_exchange_strong_explicit_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64*)expected, (c89atomic_uint64)desired, successOrder, failureOrder); - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_weak_explicit_ptr(volatile void** dst, void** expected, void* desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - return c89atomic_compare_exchange_weak_explicit_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64*)expected, (c89atomic_uint64)desired, successOrder, failureOrder); - } - static C89ATOMIC_INLINE void* c89atomic_compare_and_swap_ptr(volatile void** dst, void* expected, void* desired) - { - return (void*)c89atomic_compare_and_swap_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64)expected, (c89atomic_uint64)desired); - } -#elif defined(C89ATOMIC_32BIT) - static C89ATOMIC_INLINE c89atomic_bool c89atomic_is_lock_free_ptr(volatile void** ptr) - { - return c89atomic_is_lock_free_32((volatile c89atomic_uint32*)ptr); - } - static C89ATOMIC_INLINE void* c89atomic_load_explicit_ptr(volatile void** ptr, c89atomic_memory_order order) - { - return (void*)c89atomic_load_explicit_32((volatile c89atomic_uint32*)ptr, order); - } - static C89ATOMIC_INLINE void c89atomic_store_explicit_ptr(volatile void** dst, void* src, c89atomic_memory_order order) - { - c89atomic_store_explicit_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32)src, order); - } - static C89ATOMIC_INLINE void* c89atomic_exchange_explicit_ptr(volatile void** dst, void* src, c89atomic_memory_order order) - { - return (void*)c89atomic_exchange_explicit_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32)src, order); - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_strong_explicit_ptr(volatile void** dst, void** expected, void* desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - return c89atomic_compare_exchange_strong_explicit_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32*)expected, (c89atomic_uint32)desired, successOrder, failureOrder); - } - static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_weak_explicit_ptr(volatile void** dst, void** expected, void* desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) - { - return c89atomic_compare_exchange_weak_explicit_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32*)expected, (c89atomic_uint32)desired, successOrder, failureOrder); - } - static C89ATOMIC_INLINE void* c89atomic_compare_and_swap_ptr(volatile void** dst, void* expected, void* desired) - { - return (void*)c89atomic_compare_and_swap_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32)expected, (c89atomic_uint32)desired); - } -#else - #error Unsupported architecture. -#endif -#define c89atomic_flag_test_and_set(ptr) c89atomic_flag_test_and_set_explicit(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_flag_clear(ptr) c89atomic_flag_clear_explicit(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_store_ptr(dst, src) c89atomic_store_explicit_ptr((volatile void**)dst, (void*)src, c89atomic_memory_order_seq_cst) -#define c89atomic_load_ptr(ptr) c89atomic_load_explicit_ptr((volatile void**)ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_ptr(dst, src) c89atomic_exchange_explicit_ptr((volatile void**)dst, (void*)src, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_ptr(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_ptr((volatile void**)dst, (void**)expected, (void*)desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_ptr(dst, expected, desired) c89atomic_compare_exchange_weak_explicit_ptr((volatile void**)dst, (void**)expected, (void*)desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_8( ptr) c89atomic_test_and_set_explicit_8( ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_16(ptr) c89atomic_test_and_set_explicit_16(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_32(ptr) c89atomic_test_and_set_explicit_32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_64(ptr) c89atomic_test_and_set_explicit_64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_8( ptr) c89atomic_clear_explicit_8( ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_16(ptr) c89atomic_clear_explicit_16(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_32(ptr) c89atomic_clear_explicit_32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_64(ptr) c89atomic_clear_explicit_64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_store_8( dst, src) c89atomic_store_explicit_8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_16(dst, src) c89atomic_store_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_32(dst, src) c89atomic_store_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_64(dst, src) c89atomic_store_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_load_8( ptr) c89atomic_load_explicit_8( ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_16(ptr) c89atomic_load_explicit_16(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_32(ptr) c89atomic_load_explicit_32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_64(ptr) c89atomic_load_explicit_64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_8( dst, src) c89atomic_exchange_explicit_8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_16(dst, src) c89atomic_exchange_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_32(dst, src) c89atomic_exchange_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_64(dst, src) c89atomic_exchange_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_8( dst, expected, desired) c89atomic_compare_exchange_strong_explicit_8( dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_16(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_16(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_32(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_32(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_64(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_64(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_8( dst, expected, desired) c89atomic_compare_exchange_weak_explicit_8( dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_16( dst, expected, desired) c89atomic_compare_exchange_weak_explicit_16(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_32( dst, expected, desired) c89atomic_compare_exchange_weak_explicit_32(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_64( dst, expected, desired) c89atomic_compare_exchange_weak_explicit_64(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_8( dst, src) c89atomic_fetch_add_explicit_8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_16(dst, src) c89atomic_fetch_add_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_32(dst, src) c89atomic_fetch_add_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_64(dst, src) c89atomic_fetch_add_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_8( dst, src) c89atomic_fetch_sub_explicit_8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_16(dst, src) c89atomic_fetch_sub_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_32(dst, src) c89atomic_fetch_sub_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_64(dst, src) c89atomic_fetch_sub_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_8( dst, src) c89atomic_fetch_or_explicit_8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_16(dst, src) c89atomic_fetch_or_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_32(dst, src) c89atomic_fetch_or_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_64(dst, src) c89atomic_fetch_or_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_8( dst, src) c89atomic_fetch_xor_explicit_8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_16(dst, src) c89atomic_fetch_xor_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_32(dst, src) c89atomic_fetch_xor_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_64(dst, src) c89atomic_fetch_xor_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_8( dst, src) c89atomic_fetch_and_explicit_8 (dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_16(dst, src) c89atomic_fetch_and_explicit_16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_32(dst, src) c89atomic_fetch_and_explicit_32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_64(dst, src) c89atomic_fetch_and_explicit_64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_explicit_i8( ptr, order) (c89atomic_int8 )c89atomic_test_and_set_explicit_8( (c89atomic_uint8* )ptr, order) -#define c89atomic_test_and_set_explicit_i16(ptr, order) (c89atomic_int16)c89atomic_test_and_set_explicit_16((c89atomic_uint16*)ptr, order) -#define c89atomic_test_and_set_explicit_i32(ptr, order) (c89atomic_int32)c89atomic_test_and_set_explicit_32((c89atomic_uint32*)ptr, order) -#define c89atomic_test_and_set_explicit_i64(ptr, order) (c89atomic_int64)c89atomic_test_and_set_explicit_64((c89atomic_uint64*)ptr, order) -#define c89atomic_clear_explicit_i8( ptr, order) c89atomic_clear_explicit_8( (c89atomic_uint8* )ptr, order) -#define c89atomic_clear_explicit_i16(ptr, order) c89atomic_clear_explicit_16((c89atomic_uint16*)ptr, order) -#define c89atomic_clear_explicit_i32(ptr, order) c89atomic_clear_explicit_32((c89atomic_uint32*)ptr, order) -#define c89atomic_clear_explicit_i64(ptr, order) c89atomic_clear_explicit_64((c89atomic_uint64*)ptr, order) -#define c89atomic_store_explicit_i8( dst, src, order) c89atomic_store_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_store_explicit_i16(dst, src, order) c89atomic_store_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_store_explicit_i32(dst, src, order) c89atomic_store_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_store_explicit_i64(dst, src, order) c89atomic_store_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_load_explicit_i8( ptr, order) (c89atomic_int8 )c89atomic_load_explicit_8( (c89atomic_uint8* )ptr, order) -#define c89atomic_load_explicit_i16(ptr, order) (c89atomic_int16)c89atomic_load_explicit_16((c89atomic_uint16*)ptr, order) -#define c89atomic_load_explicit_i32(ptr, order) (c89atomic_int32)c89atomic_load_explicit_32((c89atomic_uint32*)ptr, order) -#define c89atomic_load_explicit_i64(ptr, order) (c89atomic_int64)c89atomic_load_explicit_64((c89atomic_uint64*)ptr, order) -#define c89atomic_exchange_explicit_i8( dst, src, order) (c89atomic_int8 )c89atomic_exchange_explicit_8 ((c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_exchange_explicit_i16(dst, src, order) (c89atomic_int16)c89atomic_exchange_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_exchange_explicit_i32(dst, src, order) (c89atomic_int32)c89atomic_exchange_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_exchange_explicit_i64(dst, src, order) (c89atomic_int64)c89atomic_exchange_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_compare_exchange_strong_explicit_i8( dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8* )expected, (c89atomic_uint8 )desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_strong_explicit_i16(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16*)expected, (c89atomic_uint16)desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_strong_explicit_i32(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32*)expected, (c89atomic_uint32)desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_strong_explicit_i64(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_strong_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64*)expected, (c89atomic_uint64)desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_weak_explicit_i8( dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_weak_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8* )expected, (c89atomic_uint8 )desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_weak_explicit_i16(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_weak_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16*)expected, (c89atomic_uint16)desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_weak_explicit_i32(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_weak_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32*)expected, (c89atomic_uint32)desired, successOrder, failureOrder) -#define c89atomic_compare_exchange_weak_explicit_i64(dst, expected, desired, successOrder, failureOrder) c89atomic_compare_exchange_weak_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64*)expected, (c89atomic_uint64)desired, successOrder, failureOrder) -#define c89atomic_fetch_add_explicit_i8( dst, src, order) (c89atomic_int8 )c89atomic_fetch_add_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_fetch_add_explicit_i16(dst, src, order) (c89atomic_int16)c89atomic_fetch_add_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_fetch_add_explicit_i32(dst, src, order) (c89atomic_int32)c89atomic_fetch_add_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_fetch_add_explicit_i64(dst, src, order) (c89atomic_int64)c89atomic_fetch_add_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_fetch_sub_explicit_i8( dst, src, order) (c89atomic_int8 )c89atomic_fetch_sub_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_fetch_sub_explicit_i16(dst, src, order) (c89atomic_int16)c89atomic_fetch_sub_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_fetch_sub_explicit_i32(dst, src, order) (c89atomic_int32)c89atomic_fetch_sub_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_fetch_sub_explicit_i64(dst, src, order) (c89atomic_int64)c89atomic_fetch_sub_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_fetch_or_explicit_i8( dst, src, order) (c89atomic_int8 )c89atomic_fetch_or_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_fetch_or_explicit_i16(dst, src, order) (c89atomic_int16)c89atomic_fetch_or_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_fetch_or_explicit_i32(dst, src, order) (c89atomic_int32)c89atomic_fetch_or_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_fetch_or_explicit_i64(dst, src, order) (c89atomic_int64)c89atomic_fetch_or_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_fetch_xor_explicit_i8( dst, src, order) (c89atomic_int8 )c89atomic_fetch_xor_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_fetch_xor_explicit_i16(dst, src, order) (c89atomic_int16)c89atomic_fetch_xor_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_fetch_xor_explicit_i32(dst, src, order) (c89atomic_int32)c89atomic_fetch_xor_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_fetch_xor_explicit_i64(dst, src, order) (c89atomic_int64)c89atomic_fetch_xor_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_fetch_and_explicit_i8( dst, src, order) (c89atomic_int8 )c89atomic_fetch_and_explicit_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )src, order) -#define c89atomic_fetch_and_explicit_i16(dst, src, order) (c89atomic_int16)c89atomic_fetch_and_explicit_16((c89atomic_uint16*)dst, (c89atomic_uint16)src, order) -#define c89atomic_fetch_and_explicit_i32(dst, src, order) (c89atomic_int32)c89atomic_fetch_and_explicit_32((c89atomic_uint32*)dst, (c89atomic_uint32)src, order) -#define c89atomic_fetch_and_explicit_i64(dst, src, order) (c89atomic_int64)c89atomic_fetch_and_explicit_64((c89atomic_uint64*)dst, (c89atomic_uint64)src, order) -#define c89atomic_test_and_set_i8( ptr) c89atomic_test_and_set_explicit_i8( ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_i16(ptr) c89atomic_test_and_set_explicit_i16(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_i32(ptr) c89atomic_test_and_set_explicit_i32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_test_and_set_i64(ptr) c89atomic_test_and_set_explicit_i64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_i8( ptr) c89atomic_clear_explicit_i8( ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_i16(ptr) c89atomic_clear_explicit_i16(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_i32(ptr) c89atomic_clear_explicit_i32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_i64(ptr) c89atomic_clear_explicit_i64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_store_i8( dst, src) c89atomic_store_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_i16(dst, src) c89atomic_store_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_i32(dst, src) c89atomic_store_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_i64(dst, src) c89atomic_store_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_load_i8( ptr) c89atomic_load_explicit_i8( ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_i16(ptr) c89atomic_load_explicit_i16(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_i32(ptr) c89atomic_load_explicit_i32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_i64(ptr) c89atomic_load_explicit_i64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_i8( dst, src) c89atomic_exchange_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_i16(dst, src) c89atomic_exchange_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_i32(dst, src) c89atomic_exchange_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_i64(dst, src) c89atomic_exchange_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_i8( dst, expected, desired) c89atomic_compare_exchange_strong_explicit_i8( dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_i16(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_i16(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_i32(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_i32(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_i64(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_i64(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_i8( dst, expected, desired) c89atomic_compare_exchange_weak_explicit_i8( dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_i16(dst, expected, desired) c89atomic_compare_exchange_weak_explicit_i16(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_i32(dst, expected, desired) c89atomic_compare_exchange_weak_explicit_i32(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_i64(dst, expected, desired) c89atomic_compare_exchange_weak_explicit_i64(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_i8( dst, src) c89atomic_fetch_add_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_i16(dst, src) c89atomic_fetch_add_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_i32(dst, src) c89atomic_fetch_add_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_i64(dst, src) c89atomic_fetch_add_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_i8( dst, src) c89atomic_fetch_sub_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_i16(dst, src) c89atomic_fetch_sub_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_i32(dst, src) c89atomic_fetch_sub_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_i64(dst, src) c89atomic_fetch_sub_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_i8( dst, src) c89atomic_fetch_or_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_i16(dst, src) c89atomic_fetch_or_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_i32(dst, src) c89atomic_fetch_or_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_i64(dst, src) c89atomic_fetch_or_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_i8( dst, src) c89atomic_fetch_xor_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_i16(dst, src) c89atomic_fetch_xor_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_i32(dst, src) c89atomic_fetch_xor_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_i64(dst, src) c89atomic_fetch_xor_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_i8( dst, src) c89atomic_fetch_and_explicit_i8( dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_i16(dst, src) c89atomic_fetch_and_explicit_i16(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_i32(dst, src) c89atomic_fetch_and_explicit_i32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_i64(dst, src) c89atomic_fetch_and_explicit_i64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_and_swap_i8( dst, expected, dedsired) (c89atomic_int8 )c89atomic_compare_and_swap_8( (c89atomic_uint8* )dst, (c89atomic_uint8 )expected, (c89atomic_uint8 )dedsired) -#define c89atomic_compare_and_swap_i16(dst, expected, dedsired) (c89atomic_int16)c89atomic_compare_and_swap_16((c89atomic_uint16*)dst, (c89atomic_uint16)expected, (c89atomic_uint16)dedsired) -#define c89atomic_compare_and_swap_i32(dst, expected, dedsired) (c89atomic_int32)c89atomic_compare_and_swap_32((c89atomic_uint32*)dst, (c89atomic_uint32)expected, (c89atomic_uint32)dedsired) -#define c89atomic_compare_and_swap_i64(dst, expected, dedsired) (c89atomic_int64)c89atomic_compare_and_swap_64((c89atomic_uint64*)dst, (c89atomic_uint64)expected, (c89atomic_uint64)dedsired) -typedef union -{ - c89atomic_uint32 i; - float f; -} c89atomic_if32; -typedef union -{ - c89atomic_uint64 i; - double f; -} c89atomic_if64; -#define c89atomic_clear_explicit_f32(ptr, order) c89atomic_clear_explicit_32((c89atomic_uint32*)ptr, order) -#define c89atomic_clear_explicit_f64(ptr, order) c89atomic_clear_explicit_64((c89atomic_uint64*)ptr, order) -static C89ATOMIC_INLINE void c89atomic_store_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 x; - x.f = src; - c89atomic_store_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); -} -static C89ATOMIC_INLINE void c89atomic_store_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 x; - x.f = src; - c89atomic_store_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); -} -static C89ATOMIC_INLINE float c89atomic_load_explicit_f32(volatile const float* ptr, c89atomic_memory_order order) -{ - c89atomic_if32 r; - r.i = c89atomic_load_explicit_32((volatile const c89atomic_uint32*)ptr, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_load_explicit_f64(volatile const double* ptr, c89atomic_memory_order order) -{ - c89atomic_if64 r; - r.i = c89atomic_load_explicit_64((volatile const c89atomic_uint64*)ptr, order); - return r.f; -} -static C89ATOMIC_INLINE float c89atomic_exchange_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 r; - c89atomic_if32 x; - x.f = src; - r.i = c89atomic_exchange_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_exchange_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 r; - c89atomic_if64 x; - x.f = src; - r.i = c89atomic_exchange_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_strong_explicit_f32(volatile float* dst, float* expected, float desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) -{ - c89atomic_if32 d; - d.f = desired; - return c89atomic_compare_exchange_strong_explicit_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32*)expected, d.i, successOrder, failureOrder); -} -static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_strong_explicit_f64(volatile double* dst, double* expected, double desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) -{ - c89atomic_if64 d; - d.f = desired; - return c89atomic_compare_exchange_strong_explicit_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64*)expected, d.i, successOrder, failureOrder); -} -static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_weak_explicit_f32(volatile float* dst, float* expected, float desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) -{ - c89atomic_if32 d; - d.f = desired; - return c89atomic_compare_exchange_weak_explicit_32((volatile c89atomic_uint32*)dst, (c89atomic_uint32*)expected, d.i, successOrder, failureOrder); -} -static C89ATOMIC_INLINE c89atomic_bool c89atomic_compare_exchange_weak_explicit_f64(volatile double* dst, double* expected, double desired, c89atomic_memory_order successOrder, c89atomic_memory_order failureOrder) -{ - c89atomic_if64 d; - d.f = desired; - return c89atomic_compare_exchange_weak_explicit_64((volatile c89atomic_uint64*)dst, (c89atomic_uint64*)expected, d.i, successOrder, failureOrder); -} -static C89ATOMIC_INLINE float c89atomic_fetch_add_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 r; - c89atomic_if32 x; - x.f = src; - r.i = c89atomic_fetch_add_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_fetch_add_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 r; - c89atomic_if64 x; - x.f = src; - r.i = c89atomic_fetch_add_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE float c89atomic_fetch_sub_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 r; - c89atomic_if32 x; - x.f = src; - r.i = c89atomic_fetch_sub_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_fetch_sub_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 r; - c89atomic_if64 x; - x.f = src; - r.i = c89atomic_fetch_sub_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE float c89atomic_fetch_or_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 r; - c89atomic_if32 x; - x.f = src; - r.i = c89atomic_fetch_or_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_fetch_or_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 r; - c89atomic_if64 x; - x.f = src; - r.i = c89atomic_fetch_or_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE float c89atomic_fetch_xor_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 r; - c89atomic_if32 x; - x.f = src; - r.i = c89atomic_fetch_xor_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_fetch_xor_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 r; - c89atomic_if64 x; - x.f = src; - r.i = c89atomic_fetch_xor_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE float c89atomic_fetch_and_explicit_f32(volatile float* dst, float src, c89atomic_memory_order order) -{ - c89atomic_if32 r; - c89atomic_if32 x; - x.f = src; - r.i = c89atomic_fetch_and_explicit_32((volatile c89atomic_uint32*)dst, x.i, order); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_fetch_and_explicit_f64(volatile double* dst, double src, c89atomic_memory_order order) -{ - c89atomic_if64 r; - c89atomic_if64 x; - x.f = src; - r.i = c89atomic_fetch_and_explicit_64((volatile c89atomic_uint64*)dst, x.i, order); - return r.f; -} -#define c89atomic_clear_f32(ptr) (float )c89atomic_clear_explicit_f32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_clear_f64(ptr) (double)c89atomic_clear_explicit_f64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_store_f32(dst, src) c89atomic_store_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_store_f64(dst, src) c89atomic_store_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_load_f32(ptr) (float )c89atomic_load_explicit_f32(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_load_f64(ptr) (double)c89atomic_load_explicit_f64(ptr, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_f32(dst, src) (float )c89atomic_exchange_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_exchange_f64(dst, src) (double)c89atomic_exchange_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_f32(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_f32(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_strong_f64(dst, expected, desired) c89atomic_compare_exchange_strong_explicit_f64(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_f32(dst, expected, desired) c89atomic_compare_exchange_weak_explicit_f32(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_compare_exchange_weak_f64(dst, expected, desired) c89atomic_compare_exchange_weak_explicit_f64(dst, expected, desired, c89atomic_memory_order_seq_cst, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_f32(dst, src) c89atomic_fetch_add_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_add_f64(dst, src) c89atomic_fetch_add_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_f32(dst, src) c89atomic_fetch_sub_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_sub_f64(dst, src) c89atomic_fetch_sub_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_f32(dst, src) c89atomic_fetch_or_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_or_f64(dst, src) c89atomic_fetch_or_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_f32(dst, src) c89atomic_fetch_xor_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_xor_f64(dst, src) c89atomic_fetch_xor_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_f32(dst, src) c89atomic_fetch_and_explicit_f32(dst, src, c89atomic_memory_order_seq_cst) -#define c89atomic_fetch_and_f64(dst, src) c89atomic_fetch_and_explicit_f64(dst, src, c89atomic_memory_order_seq_cst) -static C89ATOMIC_INLINE float c89atomic_compare_and_swap_f32(volatile float* dst, float expected, float desired) -{ - c89atomic_if32 r; - c89atomic_if32 e, d; - e.f = expected; - d.f = desired; - r.i = c89atomic_compare_and_swap_32((volatile c89atomic_uint32*)dst, e.i, d.i); - return r.f; -} -static C89ATOMIC_INLINE double c89atomic_compare_and_swap_f64(volatile double* dst, double expected, double desired) -{ - c89atomic_if64 r; - c89atomic_if64 e, d; - e.f = expected; - d.f = desired; - r.i = c89atomic_compare_and_swap_64((volatile c89atomic_uint64*)dst, e.i, d.i); - return r.f; -} -typedef c89atomic_flag c89atomic_spinlock; -static C89ATOMIC_INLINE void c89atomic_spinlock_lock(volatile c89atomic_spinlock* pSpinlock) -{ - for (;;) { - if (c89atomic_flag_test_and_set_explicit(pSpinlock, c89atomic_memory_order_acquire) == 0) { - break; - } - while (c89atoimc_flag_load_explicit(pSpinlock, c89atomic_memory_order_relaxed) == 1) { - } - } -} -static C89ATOMIC_INLINE void c89atomic_spinlock_unlock(volatile c89atomic_spinlock* pSpinlock) -{ - c89atomic_flag_clear_explicit(pSpinlock, c89atomic_memory_order_release); -} -#if defined(__cplusplus) -} -#endif -#endif -/* c89atomic.h end */ - -#define MA_ATOMIC_SAFE_TYPE_IMPL(c89TypeExtension, type) \ - static MA_INLINE ma_##type ma_atomic_##type##_get(ma_atomic_##type* x) \ - { \ - return (ma_##type)c89atomic_load_##c89TypeExtension(&x->value); \ - } \ - static MA_INLINE void ma_atomic_##type##_set(ma_atomic_##type* x, ma_##type value) \ - { \ - c89atomic_store_##c89TypeExtension(&x->value, value); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_exchange(ma_atomic_##type* x, ma_##type value) \ - { \ - return (ma_##type)c89atomic_exchange_##c89TypeExtension(&x->value, value); \ - } \ - static MA_INLINE ma_bool32 ma_atomic_##type##_compare_exchange(ma_atomic_##type* x, ma_##type* expected, ma_##type desired) \ - { \ - return c89atomic_compare_exchange_weak_##c89TypeExtension(&x->value, expected, desired); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_fetch_add(ma_atomic_##type* x, ma_##type y) \ - { \ - return (ma_##type)c89atomic_fetch_add_##c89TypeExtension(&x->value, y); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_fetch_sub(ma_atomic_##type* x, ma_##type y) \ - { \ - return (ma_##type)c89atomic_fetch_sub_##c89TypeExtension(&x->value, y); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_fetch_or(ma_atomic_##type* x, ma_##type y) \ - { \ - return (ma_##type)c89atomic_fetch_or_##c89TypeExtension(&x->value, y); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_fetch_xor(ma_atomic_##type* x, ma_##type y) \ - { \ - return (ma_##type)c89atomic_fetch_xor_##c89TypeExtension(&x->value, y); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_fetch_and(ma_atomic_##type* x, ma_##type y) \ - { \ - return (ma_##type)c89atomic_fetch_and_##c89TypeExtension(&x->value, y); \ - } \ - static MA_INLINE ma_##type ma_atomic_##type##_compare_and_swap(ma_atomic_##type* x, ma_##type expected, ma_##type desired) \ - { \ - return (ma_##type)c89atomic_compare_and_swap_##c89TypeExtension(&x->value, expected, desired); \ - } \ - -#define MA_ATOMIC_SAFE_TYPE_IMPL_PTR(type) \ - static MA_INLINE ma_##type* ma_atomic_ptr_##type##_get(ma_atomic_ptr_##type* x) \ - { \ - return c89atomic_load_ptr((void**)&x->value); \ - } \ - static MA_INLINE void ma_atomic_ptr_##type##_set(ma_atomic_ptr_##type* x, ma_##type* value) \ - { \ - c89atomic_store_ptr((void**)&x->value, (void*)value); \ - } \ - static MA_INLINE ma_##type* ma_atomic_ptr_##type##_exchange(ma_atomic_ptr_##type* x, ma_##type* value) \ - { \ - return c89atomic_exchange_ptr((void**)&x->value, (void*)value); \ - } \ - static MA_INLINE ma_bool32 ma_atomic_ptr_##type##_compare_exchange(ma_atomic_ptr_##type* x, ma_##type** expected, ma_##type* desired) \ - { \ - return c89atomic_compare_exchange_weak_ptr((void**)&x->value, (void*)expected, (void*)desired); \ - } \ - static MA_INLINE ma_##type* ma_atomic_ptr_##type##_compare_and_swap(ma_atomic_ptr_##type* x, ma_##type* expected, ma_##type* desired) \ - { \ - return (ma_##type*)c89atomic_compare_and_swap_ptr((void**)&x->value, (void*)expected, (void*)desired); \ - } \ - -MA_ATOMIC_SAFE_TYPE_IMPL(32, uint32) -MA_ATOMIC_SAFE_TYPE_IMPL(i32, int32) -MA_ATOMIC_SAFE_TYPE_IMPL(64, uint64) -MA_ATOMIC_SAFE_TYPE_IMPL(f32, float) -MA_ATOMIC_SAFE_TYPE_IMPL(32, bool32) -MA_ATOMIC_SAFE_TYPE_IMPL(i32, device_state) - - -MA_API ma_uint64 ma_calculate_frame_count_after_resampling(ma_uint32 sampleRateOut, ma_uint32 sampleRateIn, ma_uint64 frameCountIn) -{ - /* This is based on the calculation in ma_linear_resampler_get_expected_output_frame_count(). */ - ma_uint64 outputFrameCount; - ma_uint64 preliminaryInputFrameCountFromFrac; - ma_uint64 preliminaryInputFrameCount; - - if (sampleRateIn == 0 || sampleRateOut == 0 || frameCountIn == 0) { - return 0; - } - - if (sampleRateOut == sampleRateIn) { - return frameCountIn; - } - - outputFrameCount = (frameCountIn * sampleRateOut) / sampleRateIn; - - preliminaryInputFrameCountFromFrac = (outputFrameCount * (sampleRateIn / sampleRateOut)) / sampleRateOut; - preliminaryInputFrameCount = (outputFrameCount * (sampleRateIn % sampleRateOut)) + preliminaryInputFrameCountFromFrac; - - if (preliminaryInputFrameCount <= frameCountIn) { - outputFrameCount += 1; - } - - return outputFrameCount; -} - -#ifndef MA_DATA_CONVERTER_STACK_BUFFER_SIZE -#define MA_DATA_CONVERTER_STACK_BUFFER_SIZE 4096 -#endif - - - -#if defined(MA_WIN32) -static ma_result ma_result_from_GetLastError(DWORD error) -{ - switch (error) - { - case ERROR_SUCCESS: return MA_SUCCESS; - case ERROR_PATH_NOT_FOUND: return MA_DOES_NOT_EXIST; - case ERROR_TOO_MANY_OPEN_FILES: return MA_TOO_MANY_OPEN_FILES; - case ERROR_NOT_ENOUGH_MEMORY: return MA_OUT_OF_MEMORY; - case ERROR_DISK_FULL: return MA_NO_SPACE; - case ERROR_HANDLE_EOF: return MA_AT_END; - case ERROR_NEGATIVE_SEEK: return MA_BAD_SEEK; - case ERROR_INVALID_PARAMETER: return MA_INVALID_ARGS; - case ERROR_ACCESS_DENIED: return MA_ACCESS_DENIED; - case ERROR_SEM_TIMEOUT: return MA_TIMEOUT; - case ERROR_FILE_NOT_FOUND: return MA_DOES_NOT_EXIST; - default: break; - } - - return MA_ERROR; -} -#endif /* MA_WIN32 */ - - -/******************************************************************************* - -Threading - -*******************************************************************************/ -static MA_INLINE ma_result ma_spinlock_lock_ex(volatile ma_spinlock* pSpinlock, ma_bool32 yield) -{ - if (pSpinlock == NULL) { - return MA_INVALID_ARGS; - } - - for (;;) { - if (c89atomic_exchange_explicit_32(pSpinlock, 1, c89atomic_memory_order_acquire) == 0) { - break; - } - - while (c89atomic_load_explicit_32(pSpinlock, c89atomic_memory_order_relaxed) == 1) { - if (yield) { - ma_yield(); - } - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_spinlock_lock(volatile ma_spinlock* pSpinlock) -{ - return ma_spinlock_lock_ex(pSpinlock, MA_TRUE); -} - -MA_API ma_result ma_spinlock_lock_noyield(volatile ma_spinlock* pSpinlock) -{ - return ma_spinlock_lock_ex(pSpinlock, MA_FALSE); -} - -MA_API ma_result ma_spinlock_unlock(volatile ma_spinlock* pSpinlock) -{ - if (pSpinlock == NULL) { - return MA_INVALID_ARGS; - } - - c89atomic_store_explicit_32(pSpinlock, 0, c89atomic_memory_order_release); - return MA_SUCCESS; -} - - -#ifndef MA_NO_THREADING -#if defined(MA_POSIX) - #define MA_THREADCALL - typedef void* ma_thread_result; -#elif defined(MA_WIN32) - #define MA_THREADCALL WINAPI - typedef unsigned long ma_thread_result; -#endif - -typedef ma_thread_result (MA_THREADCALL * ma_thread_entry_proc)(void* pData); - -#ifdef MA_POSIX -static ma_result ma_thread_create__posix(ma_thread* pThread, ma_thread_priority priority, size_t stackSize, ma_thread_entry_proc entryProc, void* pData) -{ - int result; - pthread_attr_t* pAttr = NULL; - -#if !defined(__EMSCRIPTEN__) - /* Try setting the thread priority. It's not critical if anything fails here. */ - pthread_attr_t attr; - if (pthread_attr_init(&attr) == 0) { - int scheduler = -1; - - /* We successfully initialized our attributes object so we can assign the pointer so it's passed into pthread_create(). */ - pAttr = &attr; - - if (priority == ma_thread_priority_idle) { -#ifdef SCHED_IDLE - if (pthread_attr_setschedpolicy(&attr, SCHED_IDLE) == 0) { - scheduler = SCHED_IDLE; - } -#endif - } else if (priority == ma_thread_priority_realtime) { -#ifdef SCHED_FIFO - if (pthread_attr_setschedpolicy(&attr, SCHED_FIFO) == 0) { - scheduler = SCHED_FIFO; - } -#endif -#ifdef MA_LINUX - } else { - scheduler = sched_getscheduler(0); -#endif - } - - if (stackSize > 0) { - pthread_attr_setstacksize(&attr, stackSize); - } - - if (scheduler != -1) { - int priorityMin = sched_get_priority_min(scheduler); - int priorityMax = sched_get_priority_max(scheduler); - int priorityStep = (priorityMax - priorityMin) / 7; /* 7 = number of priorities supported by miniaudio. */ - - struct sched_param sched; - if (pthread_attr_getschedparam(&attr, &sched) == 0) { - if (priority == ma_thread_priority_idle) { - sched.sched_priority = priorityMin; - } else if (priority == ma_thread_priority_realtime) { - sched.sched_priority = priorityMax; - } else { - sched.sched_priority += ((int)priority + 5) * priorityStep; /* +5 because the lowest priority is -5. */ - if (sched.sched_priority < priorityMin) { - sched.sched_priority = priorityMin; - } - if (sched.sched_priority > priorityMax) { - sched.sched_priority = priorityMax; - } - } - - /* I'm not treating a failure of setting the priority as a critical error so not checking the return value here. */ - pthread_attr_setschedparam(&attr, &sched); - } - } - } -#else - /* It's the emscripten build. We'll have a few unused parameters. */ - (void)priority; - (void)stackSize; -#endif - - result = pthread_create((pthread_t*)pThread, pAttr, entryProc, pData); - - /* The thread attributes object is no longer required. */ - if (pAttr != NULL) { - pthread_attr_destroy(pAttr); - } - - if (result != 0) { - return ma_result_from_errno(result); - } - - return MA_SUCCESS; -} - -static void ma_thread_wait__posix(ma_thread* pThread) -{ - pthread_join((pthread_t)*pThread, NULL); -} - - -static ma_result ma_mutex_init__posix(ma_mutex* pMutex) -{ - int result = pthread_mutex_init((pthread_mutex_t*)pMutex, NULL); - if (result != 0) { - return ma_result_from_errno(result); - } - - return MA_SUCCESS; -} - -static void ma_mutex_uninit__posix(ma_mutex* pMutex) -{ - pthread_mutex_destroy((pthread_mutex_t*)pMutex); -} - -static void ma_mutex_lock__posix(ma_mutex* pMutex) -{ - pthread_mutex_lock((pthread_mutex_t*)pMutex); -} - -static void ma_mutex_unlock__posix(ma_mutex* pMutex) -{ - pthread_mutex_unlock((pthread_mutex_t*)pMutex); -} - - -static ma_result ma_event_init__posix(ma_event* pEvent) -{ - int result; - - result = pthread_mutex_init((pthread_mutex_t*)&pEvent->lock, NULL); - if (result != 0) { - return ma_result_from_errno(result); - } - - result = pthread_cond_init((pthread_cond_t*)&pEvent->cond, NULL); - if (result != 0) { - pthread_mutex_destroy((pthread_mutex_t*)&pEvent->lock); - return ma_result_from_errno(result); - } - - pEvent->value = 0; - return MA_SUCCESS; -} - -static void ma_event_uninit__posix(ma_event* pEvent) -{ - pthread_cond_destroy((pthread_cond_t*)&pEvent->cond); - pthread_mutex_destroy((pthread_mutex_t*)&pEvent->lock); -} - -static ma_result ma_event_wait__posix(ma_event* pEvent) -{ - pthread_mutex_lock((pthread_mutex_t*)&pEvent->lock); - { - while (pEvent->value == 0) { - pthread_cond_wait((pthread_cond_t*)&pEvent->cond, (pthread_mutex_t*)&pEvent->lock); - } - pEvent->value = 0; /* Auto-reset. */ - } - pthread_mutex_unlock((pthread_mutex_t*)&pEvent->lock); - - return MA_SUCCESS; -} - -static ma_result ma_event_signal__posix(ma_event* pEvent) -{ - pthread_mutex_lock((pthread_mutex_t*)&pEvent->lock); - { - pEvent->value = 1; - pthread_cond_signal((pthread_cond_t*)&pEvent->cond); - } - pthread_mutex_unlock((pthread_mutex_t*)&pEvent->lock); - - return MA_SUCCESS; -} - - -static ma_result ma_semaphore_init__posix(int initialValue, ma_semaphore* pSemaphore) -{ - int result; - - if (pSemaphore == NULL) { - return MA_INVALID_ARGS; - } - - pSemaphore->value = initialValue; - - result = pthread_mutex_init((pthread_mutex_t*)&pSemaphore->lock, NULL); - if (result != 0) { - return ma_result_from_errno(result); /* Failed to create mutex. */ - } - - result = pthread_cond_init((pthread_cond_t*)&pSemaphore->cond, NULL); - if (result != 0) { - pthread_mutex_destroy((pthread_mutex_t*)&pSemaphore->lock); - return ma_result_from_errno(result); /* Failed to create condition variable. */ - } - - return MA_SUCCESS; -} - -static void ma_semaphore_uninit__posix(ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - return; - } - - pthread_cond_destroy((pthread_cond_t*)&pSemaphore->cond); - pthread_mutex_destroy((pthread_mutex_t*)&pSemaphore->lock); -} - -static ma_result ma_semaphore_wait__posix(ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - return MA_INVALID_ARGS; - } - - pthread_mutex_lock((pthread_mutex_t*)&pSemaphore->lock); - { - /* We need to wait on a condition variable before escaping. We can't return from this function until the semaphore has been signaled. */ - while (pSemaphore->value == 0) { - pthread_cond_wait((pthread_cond_t*)&pSemaphore->cond, (pthread_mutex_t*)&pSemaphore->lock); - } - - pSemaphore->value -= 1; - } - pthread_mutex_unlock((pthread_mutex_t*)&pSemaphore->lock); - - return MA_SUCCESS; -} - -static ma_result ma_semaphore_release__posix(ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - return MA_INVALID_ARGS; - } - - pthread_mutex_lock((pthread_mutex_t*)&pSemaphore->lock); - { - pSemaphore->value += 1; - pthread_cond_signal((pthread_cond_t*)&pSemaphore->cond); - } - pthread_mutex_unlock((pthread_mutex_t*)&pSemaphore->lock); - - return MA_SUCCESS; -} -#elif defined(MA_WIN32) -static int ma_thread_priority_to_win32(ma_thread_priority priority) -{ - switch (priority) { - case ma_thread_priority_idle: return THREAD_PRIORITY_IDLE; - case ma_thread_priority_lowest: return THREAD_PRIORITY_LOWEST; - case ma_thread_priority_low: return THREAD_PRIORITY_BELOW_NORMAL; - case ma_thread_priority_normal: return THREAD_PRIORITY_NORMAL; - case ma_thread_priority_high: return THREAD_PRIORITY_ABOVE_NORMAL; - case ma_thread_priority_highest: return THREAD_PRIORITY_HIGHEST; - case ma_thread_priority_realtime: return THREAD_PRIORITY_TIME_CRITICAL; - default: return THREAD_PRIORITY_NORMAL; - } -} - -static ma_result ma_thread_create__win32(ma_thread* pThread, ma_thread_priority priority, size_t stackSize, ma_thread_entry_proc entryProc, void* pData) -{ - DWORD threadID; /* Not used. Only used for passing into CreateThread() so it doesn't fail on Windows 98. */ - - *pThread = CreateThread(NULL, stackSize, entryProc, pData, 0, &threadID); - if (*pThread == NULL) { - return ma_result_from_GetLastError(GetLastError()); - } - - SetThreadPriority((HANDLE)*pThread, ma_thread_priority_to_win32(priority)); - - return MA_SUCCESS; -} - -static void ma_thread_wait__win32(ma_thread* pThread) -{ - WaitForSingleObject((HANDLE)*pThread, INFINITE); - CloseHandle((HANDLE)*pThread); -} - - -static ma_result ma_mutex_init__win32(ma_mutex* pMutex) -{ - *pMutex = CreateEventA(NULL, FALSE, TRUE, NULL); - if (*pMutex == NULL) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - -static void ma_mutex_uninit__win32(ma_mutex* pMutex) -{ - CloseHandle((HANDLE)*pMutex); -} - -static void ma_mutex_lock__win32(ma_mutex* pMutex) -{ - WaitForSingleObject((HANDLE)*pMutex, INFINITE); -} - -static void ma_mutex_unlock__win32(ma_mutex* pMutex) -{ - SetEvent((HANDLE)*pMutex); -} - - -static ma_result ma_event_init__win32(ma_event* pEvent) -{ - *pEvent = CreateEventA(NULL, FALSE, FALSE, NULL); - if (*pEvent == NULL) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - -static void ma_event_uninit__win32(ma_event* pEvent) -{ - CloseHandle((HANDLE)*pEvent); -} - -static ma_result ma_event_wait__win32(ma_event* pEvent) -{ - DWORD result = WaitForSingleObject((HANDLE)*pEvent, INFINITE); - if (result == WAIT_OBJECT_0) { - return MA_SUCCESS; - } - - if (result == WAIT_TIMEOUT) { - return MA_TIMEOUT; - } - - return ma_result_from_GetLastError(GetLastError()); -} - -static ma_result ma_event_signal__win32(ma_event* pEvent) -{ - BOOL result = SetEvent((HANDLE)*pEvent); - if (result == 0) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - - -static ma_result ma_semaphore_init__win32(int initialValue, ma_semaphore* pSemaphore) -{ - *pSemaphore = CreateSemaphoreW(NULL, (LONG)initialValue, LONG_MAX, NULL); - if (*pSemaphore == NULL) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - -static void ma_semaphore_uninit__win32(ma_semaphore* pSemaphore) -{ - CloseHandle((HANDLE)*pSemaphore); -} - -static ma_result ma_semaphore_wait__win32(ma_semaphore* pSemaphore) -{ - DWORD result = WaitForSingleObject((HANDLE)*pSemaphore, INFINITE); - if (result == WAIT_OBJECT_0) { - return MA_SUCCESS; - } - - if (result == WAIT_TIMEOUT) { - return MA_TIMEOUT; - } - - return ma_result_from_GetLastError(GetLastError()); -} - -static ma_result ma_semaphore_release__win32(ma_semaphore* pSemaphore) -{ - BOOL result = ReleaseSemaphore((HANDLE)*pSemaphore, 1, NULL); - if (result == 0) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} -#endif - -typedef struct -{ - ma_thread_entry_proc entryProc; - void* pData; - ma_allocation_callbacks allocationCallbacks; -} ma_thread_proxy_data; - -static ma_thread_result MA_THREADCALL ma_thread_entry_proxy(void* pData) -{ - ma_thread_proxy_data* pProxyData = (ma_thread_proxy_data*)pData; - ma_thread_entry_proc entryProc; - void* pEntryProcData; - ma_thread_result result; - - #if defined(MA_ON_THREAD_ENTRY) - MA_ON_THREAD_ENTRY - #endif - - entryProc = pProxyData->entryProc; - pEntryProcData = pProxyData->pData; - - /* Free the proxy data before getting into the real thread entry proc. */ - ma_free(pProxyData, &pProxyData->allocationCallbacks); - - result = entryProc(pEntryProcData); - - #if defined(MA_ON_THREAD_EXIT) - MA_ON_THREAD_EXIT - #endif - - return result; -} - -static ma_result ma_thread_create(ma_thread* pThread, ma_thread_priority priority, size_t stackSize, ma_thread_entry_proc entryProc, void* pData, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_result result; - ma_thread_proxy_data* pProxyData; - - if (pThread == NULL || entryProc == NULL) { - return MA_INVALID_ARGS; - } - - pProxyData = (ma_thread_proxy_data*)ma_malloc(sizeof(*pProxyData), pAllocationCallbacks); /* Will be freed by the proxy entry proc. */ - if (pProxyData == NULL) { - return MA_OUT_OF_MEMORY; - } - - pProxyData->entryProc = entryProc; - pProxyData->pData = pData; - ma_allocation_callbacks_init_copy(&pProxyData->allocationCallbacks, pAllocationCallbacks); - -#if defined(MA_POSIX) - result = ma_thread_create__posix(pThread, priority, stackSize, ma_thread_entry_proxy, pProxyData); -#elif defined(MA_WIN32) - result = ma_thread_create__win32(pThread, priority, stackSize, ma_thread_entry_proxy, pProxyData); -#endif - - if (result != MA_SUCCESS) { - ma_free(pProxyData, pAllocationCallbacks); - return result; - } - - return MA_SUCCESS; -} - -static void ma_thread_wait(ma_thread* pThread) -{ - if (pThread == NULL) { - return; - } - -#if defined(MA_POSIX) - ma_thread_wait__posix(pThread); -#elif defined(MA_WIN32) - ma_thread_wait__win32(pThread); -#endif -} - - -MA_API ma_result ma_mutex_init(ma_mutex* pMutex) -{ - if (pMutex == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_mutex_init__posix(pMutex); -#elif defined(MA_WIN32) - return ma_mutex_init__win32(pMutex); -#endif -} - -MA_API void ma_mutex_uninit(ma_mutex* pMutex) -{ - if (pMutex == NULL) { - return; - } - -#if defined(MA_POSIX) - ma_mutex_uninit__posix(pMutex); -#elif defined(MA_WIN32) - ma_mutex_uninit__win32(pMutex); -#endif -} - -MA_API void ma_mutex_lock(ma_mutex* pMutex) -{ - if (pMutex == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return; - } - -#if defined(MA_POSIX) - ma_mutex_lock__posix(pMutex); -#elif defined(MA_WIN32) - ma_mutex_lock__win32(pMutex); -#endif -} - -MA_API void ma_mutex_unlock(ma_mutex* pMutex) -{ - if (pMutex == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return; - } - -#if defined(MA_POSIX) - ma_mutex_unlock__posix(pMutex); -#elif defined(MA_WIN32) - ma_mutex_unlock__win32(pMutex); -#endif -} - - -MA_API ma_result ma_event_init(ma_event* pEvent) -{ - if (pEvent == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_event_init__posix(pEvent); -#elif defined(MA_WIN32) - return ma_event_init__win32(pEvent); -#endif -} - -#if 0 -static ma_result ma_event_alloc_and_init(ma_event** ppEvent, ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_result result; - ma_event* pEvent; - - if (ppEvent == NULL) { - return MA_INVALID_ARGS; - } - - *ppEvent = NULL; - - pEvent = ma_malloc(sizeof(*pEvent), pAllocationCallbacks); - if (pEvent == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_event_init(pEvent); - if (result != MA_SUCCESS) { - ma_free(pEvent, pAllocationCallbacks); - return result; - } - - *ppEvent = pEvent; - return result; -} -#endif - -MA_API void ma_event_uninit(ma_event* pEvent) -{ - if (pEvent == NULL) { - return; - } - -#if defined(MA_POSIX) - ma_event_uninit__posix(pEvent); -#elif defined(MA_WIN32) - ma_event_uninit__win32(pEvent); -#endif -} - -#if 0 -static void ma_event_uninit_and_free(ma_event* pEvent, ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pEvent == NULL) { - return; - } - - ma_event_uninit(pEvent); - ma_free(pEvent, pAllocationCallbacks); -} -#endif - -MA_API ma_result ma_event_wait(ma_event* pEvent) -{ - if (pEvent == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert to the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_event_wait__posix(pEvent); -#elif defined(MA_WIN32) - return ma_event_wait__win32(pEvent); -#endif -} - -MA_API ma_result ma_event_signal(ma_event* pEvent) -{ - if (pEvent == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert to the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_event_signal__posix(pEvent); -#elif defined(MA_WIN32) - return ma_event_signal__win32(pEvent); -#endif -} - - -MA_API ma_result ma_semaphore_init(int initialValue, ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_semaphore_init__posix(initialValue, pSemaphore); -#elif defined(MA_WIN32) - return ma_semaphore_init__win32(initialValue, pSemaphore); -#endif -} - -MA_API void ma_semaphore_uninit(ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return; - } - -#if defined(MA_POSIX) - ma_semaphore_uninit__posix(pSemaphore); -#elif defined(MA_WIN32) - ma_semaphore_uninit__win32(pSemaphore); -#endif -} - -MA_API ma_result ma_semaphore_wait(ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_semaphore_wait__posix(pSemaphore); -#elif defined(MA_WIN32) - return ma_semaphore_wait__win32(pSemaphore); -#endif -} - -MA_API ma_result ma_semaphore_release(ma_semaphore* pSemaphore) -{ - if (pSemaphore == NULL) { - MA_ASSERT(MA_FALSE); /* Fire an assert so the caller is aware of this bug. */ - return MA_INVALID_ARGS; - } - -#if defined(MA_POSIX) - return ma_semaphore_release__posix(pSemaphore); -#elif defined(MA_WIN32) - return ma_semaphore_release__win32(pSemaphore); -#endif -} -#else -/* MA_NO_THREADING is set which means threading is disabled. Threading is required by some API families. If any of these are enabled we need to throw an error. */ -#ifndef MA_NO_DEVICE_IO -#error "MA_NO_THREADING cannot be used without MA_NO_DEVICE_IO"; -#endif -#endif /* MA_NO_THREADING */ - - - -#define MA_FENCE_COUNTER_MAX 0x7FFFFFFF - -MA_API ma_result ma_fence_init(ma_fence* pFence) -{ - if (pFence == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFence); - pFence->counter = 0; - - #ifndef MA_NO_THREADING - { - ma_result result; - - result = ma_event_init(&pFence->e); - if (result != MA_SUCCESS) { - return result; - } - } - #endif - - return MA_SUCCESS; -} - -MA_API void ma_fence_uninit(ma_fence* pFence) -{ - if (pFence == NULL) { - return; - } - - #ifndef MA_NO_THREADING - { - ma_event_uninit(&pFence->e); - } - #endif - - MA_ZERO_OBJECT(pFence); -} - -MA_API ma_result ma_fence_acquire(ma_fence* pFence) -{ - if (pFence == NULL) { - return MA_INVALID_ARGS; - } - - for (;;) { - ma_uint32 oldCounter = c89atomic_load_32(&pFence->counter); - ma_uint32 newCounter = oldCounter + 1; - - /* Make sure we're not about to exceed our maximum value. */ - if (newCounter > MA_FENCE_COUNTER_MAX) { - MA_ASSERT(MA_FALSE); - return MA_OUT_OF_RANGE; - } - - if (c89atomic_compare_exchange_weak_32(&pFence->counter, &oldCounter, newCounter)) { - return MA_SUCCESS; - } else { - if (oldCounter == MA_FENCE_COUNTER_MAX) { - MA_ASSERT(MA_FALSE); - return MA_OUT_OF_RANGE; /* The other thread took the last available slot. Abort. */ - } - } - } - - /* Should never get here. */ - /*return MA_SUCCESS;*/ -} - -MA_API ma_result ma_fence_release(ma_fence* pFence) -{ - if (pFence == NULL) { - return MA_INVALID_ARGS; - } - - for (;;) { - ma_uint32 oldCounter = c89atomic_load_32(&pFence->counter); - ma_uint32 newCounter = oldCounter - 1; - - if (oldCounter == 0) { - MA_ASSERT(MA_FALSE); - return MA_INVALID_OPERATION; /* Acquire/release mismatch. */ - } - - if (c89atomic_compare_exchange_weak_32(&pFence->counter, &oldCounter, newCounter)) { - #ifndef MA_NO_THREADING - { - if (newCounter == 0) { - ma_event_signal(&pFence->e); /* <-- ma_fence_wait() will be waiting on this. */ - } - } - #endif - - return MA_SUCCESS; - } else { - if (oldCounter == 0) { - MA_ASSERT(MA_FALSE); - return MA_INVALID_OPERATION; /* Another thread has taken the 0 slot. Acquire/release mismatch. */ - } - } - } - - /* Should never get here. */ - /*return MA_SUCCESS;*/ -} - -MA_API ma_result ma_fence_wait(ma_fence* pFence) -{ - if (pFence == NULL) { - return MA_INVALID_ARGS; - } - - for (;;) { - ma_uint32 counter; - - counter = c89atomic_load_32(&pFence->counter); - if (counter == 0) { - /* - Counter has hit zero. By the time we get here some other thread may have acquired the - fence again, but that is where the caller needs to take care with how they se the fence. - */ - return MA_SUCCESS; - } - - /* Getting here means the counter is > 0. We'll need to wait for something to happen. */ - #ifndef MA_NO_THREADING - { - ma_result result; - - result = ma_event_wait(&pFence->e); - if (result != MA_SUCCESS) { - return result; - } - } - #endif - } - - /* Should never get here. */ - /*return MA_INVALID_OPERATION;*/ -} - - -MA_API ma_result ma_async_notification_signal(ma_async_notification* pNotification) -{ - ma_async_notification_callbacks* pNotificationCallbacks = (ma_async_notification_callbacks*)pNotification; - - if (pNotification == NULL) { - return MA_INVALID_ARGS; - } - - if (pNotificationCallbacks->onSignal == NULL) { - return MA_NOT_IMPLEMENTED; - } - - pNotificationCallbacks->onSignal(pNotification); - return MA_INVALID_ARGS; -} - - -static void ma_async_notification_poll__on_signal(ma_async_notification* pNotification) -{ - ((ma_async_notification_poll*)pNotification)->signalled = MA_TRUE; -} - -MA_API ma_result ma_async_notification_poll_init(ma_async_notification_poll* pNotificationPoll) -{ - if (pNotificationPoll == NULL) { - return MA_INVALID_ARGS; - } - - pNotificationPoll->cb.onSignal = ma_async_notification_poll__on_signal; - pNotificationPoll->signalled = MA_FALSE; - - return MA_SUCCESS; -} - -MA_API ma_bool32 ma_async_notification_poll_is_signalled(const ma_async_notification_poll* pNotificationPoll) -{ - if (pNotificationPoll == NULL) { - return MA_FALSE; - } - - return pNotificationPoll->signalled; -} - - -static void ma_async_notification_event__on_signal(ma_async_notification* pNotification) -{ - ma_async_notification_event_signal((ma_async_notification_event*)pNotification); -} - -MA_API ma_result ma_async_notification_event_init(ma_async_notification_event* pNotificationEvent) -{ - if (pNotificationEvent == NULL) { - return MA_INVALID_ARGS; - } - - pNotificationEvent->cb.onSignal = ma_async_notification_event__on_signal; - - #ifndef MA_NO_THREADING - { - ma_result result; - - result = ma_event_init(&pNotificationEvent->e); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; - } - #else - { - return MA_NOT_IMPLEMENTED; /* Threading is disabled. */ - } - #endif -} - -MA_API ma_result ma_async_notification_event_uninit(ma_async_notification_event* pNotificationEvent) -{ - if (pNotificationEvent == NULL) { - return MA_INVALID_ARGS; - } - - #ifndef MA_NO_THREADING - { - ma_event_uninit(&pNotificationEvent->e); - return MA_SUCCESS; - } - #else - { - return MA_NOT_IMPLEMENTED; /* Threading is disabled. */ - } - #endif -} - -MA_API ma_result ma_async_notification_event_wait(ma_async_notification_event* pNotificationEvent) -{ - if (pNotificationEvent == NULL) { - return MA_INVALID_ARGS; - } - - #ifndef MA_NO_THREADING - { - return ma_event_wait(&pNotificationEvent->e); - } - #else - { - return MA_NOT_IMPLEMENTED; /* Threading is disabled. */ - } - #endif -} - -MA_API ma_result ma_async_notification_event_signal(ma_async_notification_event* pNotificationEvent) -{ - if (pNotificationEvent == NULL) { - return MA_INVALID_ARGS; - } - - #ifndef MA_NO_THREADING - { - return ma_event_signal(&pNotificationEvent->e); - } - #else - { - return MA_NOT_IMPLEMENTED; /* Threading is disabled. */ - } - #endif -} - - - -/************************************************************************************************************************************************************ - -Job Queue - -************************************************************************************************************************************************************/ -MA_API ma_slot_allocator_config ma_slot_allocator_config_init(ma_uint32 capacity) -{ - ma_slot_allocator_config config; - - MA_ZERO_OBJECT(&config); - config.capacity = capacity; - - return config; -} - - -static MA_INLINE ma_uint32 ma_slot_allocator_calculate_group_capacity(ma_uint32 slotCapacity) -{ - ma_uint32 cap = slotCapacity / 32; - if ((slotCapacity % 32) != 0) { - cap += 1; - } - - return cap; -} - -static MA_INLINE ma_uint32 ma_slot_allocator_group_capacity(const ma_slot_allocator* pAllocator) -{ - return ma_slot_allocator_calculate_group_capacity(pAllocator->capacity); -} - - -typedef struct -{ - size_t sizeInBytes; - size_t groupsOffset; - size_t slotsOffset; -} ma_slot_allocator_heap_layout; - -static ma_result ma_slot_allocator_get_heap_layout(const ma_slot_allocator_config* pConfig, ma_slot_allocator_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->capacity == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Groups. */ - pHeapLayout->groupsOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(ma_slot_allocator_calculate_group_capacity(pConfig->capacity) * sizeof(ma_slot_allocator_group)); - - /* Slots. */ - pHeapLayout->slotsOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(pConfig->capacity * sizeof(ma_uint32)); - - return MA_SUCCESS; -} - -MA_API ma_result ma_slot_allocator_get_heap_size(const ma_slot_allocator_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_slot_allocator_heap_layout layout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_slot_allocator_get_heap_layout(pConfig, &layout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = layout.sizeInBytes; - - return result; -} - -MA_API ma_result ma_slot_allocator_init_preallocated(const ma_slot_allocator_config* pConfig, void* pHeap, ma_slot_allocator* pAllocator) -{ - ma_result result; - ma_slot_allocator_heap_layout heapLayout; - - if (pAllocator == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pAllocator); - - if (pHeap == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_slot_allocator_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pAllocator->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pAllocator->pGroups = (ma_slot_allocator_group*)ma_offset_ptr(pHeap, heapLayout.groupsOffset); - pAllocator->pSlots = (ma_uint32*)ma_offset_ptr(pHeap, heapLayout.slotsOffset); - pAllocator->capacity = pConfig->capacity; - - return MA_SUCCESS; -} - -MA_API ma_result ma_slot_allocator_init(const ma_slot_allocator_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_slot_allocator* pAllocator) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_slot_allocator_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the size of the heap allocation. */ - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_slot_allocator_init_preallocated(pConfig, pHeap, pAllocator); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pAllocator->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_slot_allocator_uninit(ma_slot_allocator* pAllocator, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocator == NULL) { - return; - } - - if (pAllocator->_ownsHeap) { - ma_free(pAllocator->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_slot_allocator_alloc(ma_slot_allocator* pAllocator, ma_uint64* pSlot) -{ - ma_uint32 iAttempt; - const ma_uint32 maxAttempts = 2; /* The number of iterations to perform until returning MA_OUT_OF_MEMORY if no slots can be found. */ - - if (pAllocator == NULL || pSlot == NULL) { - return MA_INVALID_ARGS; - } - - for (iAttempt = 0; iAttempt < maxAttempts; iAttempt += 1) { - /* We need to acquire a suitable bitfield first. This is a bitfield that's got an available slot within it. */ - ma_uint32 iGroup; - for (iGroup = 0; iGroup < ma_slot_allocator_group_capacity(pAllocator); iGroup += 1) { - /* CAS */ - for (;;) { - ma_uint32 oldBitfield; - ma_uint32 newBitfield; - ma_uint32 bitOffset; - - oldBitfield = c89atomic_load_32(&pAllocator->pGroups[iGroup].bitfield); /* <-- This copy must happen. The compiler must not optimize this away. */ - - /* Fast check to see if anything is available. */ - if (oldBitfield == 0xFFFFFFFF) { - break; /* No available bits in this bitfield. */ - } - - bitOffset = ma_ffs_32(~oldBitfield); - MA_ASSERT(bitOffset < 32); - - newBitfield = oldBitfield | (1 << bitOffset); - - if (c89atomic_compare_and_swap_32(&pAllocator->pGroups[iGroup].bitfield, oldBitfield, newBitfield) == oldBitfield) { - ma_uint32 slotIndex; - - /* Increment the counter as soon as possible to have other threads report out-of-memory sooner than later. */ - c89atomic_fetch_add_32(&pAllocator->count, 1); - - /* The slot index is required for constructing the output value. */ - slotIndex = (iGroup << 5) + bitOffset; /* iGroup << 5 = iGroup * 32 */ - if (slotIndex >= pAllocator->capacity) { - return MA_OUT_OF_MEMORY; - } - - /* Increment the reference count before constructing the output value. */ - pAllocator->pSlots[slotIndex] += 1; - - /* Construct the output value. */ - *pSlot = (((ma_uint64)pAllocator->pSlots[slotIndex] << 32) | slotIndex); - - return MA_SUCCESS; - } - } - } - - /* We weren't able to find a slot. If it's because we've reached our capacity we need to return MA_OUT_OF_MEMORY. Otherwise we need to do another iteration and try again. */ - if (pAllocator->count < pAllocator->capacity) { - ma_yield(); - } else { - return MA_OUT_OF_MEMORY; - } - } - - /* We couldn't find a slot within the maximum number of attempts. */ - return MA_OUT_OF_MEMORY; -} - -MA_API ma_result ma_slot_allocator_free(ma_slot_allocator* pAllocator, ma_uint64 slot) -{ - ma_uint32 iGroup; - ma_uint32 iBit; - - if (pAllocator == NULL) { - return MA_INVALID_ARGS; - } - - iGroup = (ma_uint32)((slot & 0xFFFFFFFF) >> 5); /* slot / 32 */ - iBit = (ma_uint32)((slot & 0xFFFFFFFF) & 31); /* slot % 32 */ - - if (iGroup >= ma_slot_allocator_group_capacity(pAllocator)) { - return MA_INVALID_ARGS; - } - - MA_ASSERT(iBit < 32); /* This must be true due to the logic we used to actually calculate it. */ - - while (c89atomic_load_32(&pAllocator->count) > 0) { - /* CAS */ - ma_uint32 oldBitfield; - ma_uint32 newBitfield; - - oldBitfield = c89atomic_load_32(&pAllocator->pGroups[iGroup].bitfield); /* <-- This copy must happen. The compiler must not optimize this away. */ - newBitfield = oldBitfield & ~(1 << iBit); - - /* Debugging for checking for double-frees. */ - #if defined(MA_DEBUG_OUTPUT) - { - if ((oldBitfield & (1 << iBit)) == 0) { - MA_ASSERT(MA_FALSE); /* Double free detected.*/ - } - } - #endif - - if (c89atomic_compare_and_swap_32(&pAllocator->pGroups[iGroup].bitfield, oldBitfield, newBitfield) == oldBitfield) { - c89atomic_fetch_sub_32(&pAllocator->count, 1); - return MA_SUCCESS; - } - } - - /* Getting here means there are no allocations available for freeing. */ - return MA_INVALID_OPERATION; -} - - -#define MA_JOB_ID_NONE ~((ma_uint64)0) -#define MA_JOB_SLOT_NONE (ma_uint16)(~0) - -static MA_INLINE ma_uint32 ma_job_extract_refcount(ma_uint64 toc) -{ - return (ma_uint32)(toc >> 32); -} - -static MA_INLINE ma_uint16 ma_job_extract_slot(ma_uint64 toc) -{ - return (ma_uint16)(toc & 0x0000FFFF); -} - -static MA_INLINE ma_uint16 ma_job_extract_code(ma_uint64 toc) -{ - return (ma_uint16)((toc & 0xFFFF0000) >> 16); -} - -static MA_INLINE ma_uint64 ma_job_toc_to_allocation(ma_uint64 toc) -{ - return ((ma_uint64)ma_job_extract_refcount(toc) << 32) | (ma_uint64)ma_job_extract_slot(toc); -} - -static MA_INLINE ma_uint64 ma_job_set_refcount(ma_uint64 toc, ma_uint32 refcount) -{ - /* Clear the reference count first. */ - toc = toc & ~((ma_uint64)0xFFFFFFFF << 32); - toc = toc | ((ma_uint64)refcount << 32); - - return toc; -} - - -MA_API ma_job ma_job_init(ma_uint16 code) -{ - ma_job job; - - MA_ZERO_OBJECT(&job); - job.toc.breakup.code = code; - job.toc.breakup.slot = MA_JOB_SLOT_NONE; /* Temp value. Will be allocated when posted to a queue. */ - job.next = MA_JOB_ID_NONE; - - return job; -} - - -static ma_result ma_job_process__noop(ma_job* pJob); -static ma_result ma_job_process__quit(ma_job* pJob); -static ma_result ma_job_process__custom(ma_job* pJob); -static ma_result ma_job_process__resource_manager__load_data_buffer_node(ma_job* pJob); -static ma_result ma_job_process__resource_manager__free_data_buffer_node(ma_job* pJob); -static ma_result ma_job_process__resource_manager__page_data_buffer_node(ma_job* pJob); -static ma_result ma_job_process__resource_manager__load_data_buffer(ma_job* pJob); -static ma_result ma_job_process__resource_manager__free_data_buffer(ma_job* pJob); -static ma_result ma_job_process__resource_manager__load_data_stream(ma_job* pJob); -static ma_result ma_job_process__resource_manager__free_data_stream(ma_job* pJob); -static ma_result ma_job_process__resource_manager__page_data_stream(ma_job* pJob); -static ma_result ma_job_process__resource_manager__seek_data_stream(ma_job* pJob); - -#if !defined(MA_NO_DEVICE_IO) -static ma_result ma_job_process__device__aaudio_reroute(ma_job* pJob); -#endif - -static ma_job_proc g_jobVTable[MA_JOB_TYPE_COUNT] = -{ - /* Miscellaneous. */ - ma_job_process__quit, /* MA_JOB_TYPE_QUIT */ - ma_job_process__custom, /* MA_JOB_TYPE_CUSTOM */ - - /* Resource Manager. */ - ma_job_process__resource_manager__load_data_buffer_node, /* MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER_NODE */ - ma_job_process__resource_manager__free_data_buffer_node, /* MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER_NODE */ - ma_job_process__resource_manager__page_data_buffer_node, /* MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE */ - ma_job_process__resource_manager__load_data_buffer, /* MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER */ - ma_job_process__resource_manager__free_data_buffer, /* MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER */ - ma_job_process__resource_manager__load_data_stream, /* MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_STREAM */ - ma_job_process__resource_manager__free_data_stream, /* MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_STREAM */ - ma_job_process__resource_manager__page_data_stream, /* MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_STREAM */ - ma_job_process__resource_manager__seek_data_stream, /* MA_JOB_TYPE_RESOURCE_MANAGER_SEEK_DATA_STREAM */ - - /* Device. */ -#if !defined(MA_NO_DEVICE_IO) - ma_job_process__device__aaudio_reroute /*MA_JOB_TYPE_DEVICE_AAUDIO_REROUTE*/ -#endif -}; - -MA_API ma_result ma_job_process(ma_job* pJob) -{ - if (pJob == NULL) { - return MA_INVALID_ARGS; - } - - if (pJob->toc.breakup.code >= MA_JOB_TYPE_COUNT) { - return MA_INVALID_OPERATION; - } - - return g_jobVTable[pJob->toc.breakup.code](pJob); -} - -static ma_result ma_job_process__noop(ma_job* pJob) -{ - MA_ASSERT(pJob != NULL); - - /* No-op. */ - (void)pJob; - - return MA_SUCCESS; -} - -static ma_result ma_job_process__quit(ma_job* pJob) -{ - return ma_job_process__noop(pJob); -} - -static ma_result ma_job_process__custom(ma_job* pJob) -{ - MA_ASSERT(pJob != NULL); - - /* No-op if there's no callback. */ - if (pJob->data.custom.proc == NULL) { - return MA_SUCCESS; - } - - return pJob->data.custom.proc(pJob); -} - - - -MA_API ma_job_queue_config ma_job_queue_config_init(ma_uint32 flags, ma_uint32 capacity) -{ - ma_job_queue_config config; - - config.flags = flags; - config.capacity = capacity; - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t allocatorOffset; - size_t jobsOffset; -} ma_job_queue_heap_layout; - -static ma_result ma_job_queue_get_heap_layout(const ma_job_queue_config* pConfig, ma_job_queue_heap_layout* pHeapLayout) -{ - ma_result result; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->capacity == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Allocator. */ - { - ma_slot_allocator_config allocatorConfig; - size_t allocatorHeapSizeInBytes; - - allocatorConfig = ma_slot_allocator_config_init(pConfig->capacity); - result = ma_slot_allocator_get_heap_size(&allocatorConfig, &allocatorHeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->allocatorOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += allocatorHeapSizeInBytes; - } - - /* Jobs. */ - pHeapLayout->jobsOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(pConfig->capacity * sizeof(ma_job)); - - return MA_SUCCESS; -} - -MA_API ma_result ma_job_queue_get_heap_size(const ma_job_queue_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_job_queue_heap_layout layout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_job_queue_get_heap_layout(pConfig, &layout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = layout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_job_queue_init_preallocated(const ma_job_queue_config* pConfig, void* pHeap, ma_job_queue* pQueue) -{ - ma_result result; - ma_job_queue_heap_layout heapLayout; - ma_slot_allocator_config allocatorConfig; - - if (pQueue == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pQueue); - - result = ma_job_queue_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pQueue->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pQueue->flags = pConfig->flags; - pQueue->capacity = pConfig->capacity; - pQueue->pJobs = (ma_job*)ma_offset_ptr(pHeap, heapLayout.jobsOffset); - - allocatorConfig = ma_slot_allocator_config_init(pConfig->capacity); - result = ma_slot_allocator_init_preallocated(&allocatorConfig, ma_offset_ptr(pHeap, heapLayout.allocatorOffset), &pQueue->allocator); - if (result != MA_SUCCESS) { - return result; - } - - /* We need a semaphore if we're running in non-blocking mode. If threading is disabled we need to return an error. */ - if ((pQueue->flags & MA_JOB_QUEUE_FLAG_NON_BLOCKING) == 0) { - #ifndef MA_NO_THREADING - { - ma_semaphore_init(0, &pQueue->sem); - } - #else - { - /* Threading is disabled and we've requested non-blocking mode. */ - return MA_INVALID_OPERATION; - } - #endif - } - - /* - Our queue needs to be initialized with a free standing node. This should always be slot 0. Required for the lock free algorithm. The first job in the queue is - just a dummy item for giving us the first item in the list which is stored in the "next" member. - */ - ma_slot_allocator_alloc(&pQueue->allocator, &pQueue->head); /* Will never fail. */ - pQueue->pJobs[ma_job_extract_slot(pQueue->head)].next = MA_JOB_ID_NONE; - pQueue->tail = pQueue->head; - - return MA_SUCCESS; -} - -MA_API ma_result ma_job_queue_init(const ma_job_queue_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_job_queue* pQueue) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_job_queue_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_job_queue_init_preallocated(pConfig, pHeap, pQueue); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pQueue->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_job_queue_uninit(ma_job_queue* pQueue, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pQueue == NULL) { - return; - } - - /* All we need to do is uninitialize the semaphore. */ - if ((pQueue->flags & MA_JOB_QUEUE_FLAG_NON_BLOCKING) == 0) { - #ifndef MA_NO_THREADING - { - ma_semaphore_uninit(&pQueue->sem); - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never get here. Should have been checked at initialization time. */ - } - #endif - } - - ma_slot_allocator_uninit(&pQueue->allocator, pAllocationCallbacks); - - if (pQueue->_ownsHeap) { - ma_free(pQueue->_pHeap, pAllocationCallbacks); - } -} - -static ma_bool32 ma_job_queue_cas(volatile ma_uint64* dst, ma_uint64 expected, ma_uint64 desired) -{ - /* The new counter is taken from the expected value. */ - return c89atomic_compare_and_swap_64(dst, expected, ma_job_set_refcount(desired, ma_job_extract_refcount(expected) + 1)) == expected; -} - -MA_API ma_result ma_job_queue_post(ma_job_queue* pQueue, const ma_job* pJob) -{ - /* - Lock free queue implementation based on the paper by Michael and Scott: Nonblocking Algorithms and Preemption-Safe Locking on Multiprogrammed Shared Memory Multiprocessors - */ - ma_result result; - ma_uint64 slot; - ma_uint64 tail; - ma_uint64 next; - - if (pQueue == NULL || pJob == NULL) { - return MA_INVALID_ARGS; - } - - /* We need a new slot. */ - result = ma_slot_allocator_alloc(&pQueue->allocator, &slot); - if (result != MA_SUCCESS) { - return result; /* Probably ran out of slots. If so, MA_OUT_OF_MEMORY will be returned. */ - } - - /* At this point we should have a slot to place the job. */ - MA_ASSERT(ma_job_extract_slot(slot) < pQueue->capacity); - - /* We need to put the job into memory before we do anything. */ - pQueue->pJobs[ma_job_extract_slot(slot)] = *pJob; - pQueue->pJobs[ma_job_extract_slot(slot)].toc.allocation = slot; /* This will overwrite the job code. */ - pQueue->pJobs[ma_job_extract_slot(slot)].toc.breakup.code = pJob->toc.breakup.code; /* The job code needs to be applied again because the line above overwrote it. */ - pQueue->pJobs[ma_job_extract_slot(slot)].next = MA_JOB_ID_NONE; /* Reset for safety. */ - - #ifndef MA_USE_EXPERIMENTAL_LOCK_FREE_JOB_QUEUE - ma_spinlock_lock(&pQueue->lock); - #endif - { - /* The job is stored in memory so now we need to add it to our linked list. We only ever add items to the end of the list. */ - for (;;) { - tail = c89atomic_load_64(&pQueue->tail); - next = c89atomic_load_64(&pQueue->pJobs[ma_job_extract_slot(tail)].next); - - if (ma_job_toc_to_allocation(tail) == ma_job_toc_to_allocation(c89atomic_load_64(&pQueue->tail))) { - if (ma_job_extract_slot(next) == 0xFFFF) { - if (ma_job_queue_cas(&pQueue->pJobs[ma_job_extract_slot(tail)].next, next, slot)) { - break; - } - } else { - ma_job_queue_cas(&pQueue->tail, tail, ma_job_extract_slot(next)); - } - } - } - ma_job_queue_cas(&pQueue->tail, tail, slot); - } - #ifndef MA_USE_EXPERIMENTAL_LOCK_FREE_JOB_QUEUE - ma_spinlock_unlock(&pQueue->lock); - #endif - - - /* Signal the semaphore as the last step if we're using synchronous mode. */ - if ((pQueue->flags & MA_JOB_QUEUE_FLAG_NON_BLOCKING) == 0) { - #ifndef MA_NO_THREADING - { - ma_semaphore_release(&pQueue->sem); - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never get here. Should have been checked at initialization time. */ - } - #endif - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_job_queue_next(ma_job_queue* pQueue, ma_job* pJob) -{ - ma_uint64 head; - ma_uint64 tail; - ma_uint64 next; - - if (pQueue == NULL || pJob == NULL) { - return MA_INVALID_ARGS; - } - - /* If we're running in synchronous mode we'll need to wait on a semaphore. */ - if ((pQueue->flags & MA_JOB_QUEUE_FLAG_NON_BLOCKING) == 0) { - #ifndef MA_NO_THREADING - { - ma_semaphore_wait(&pQueue->sem); - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never get here. Should have been checked at initialization time. */ - } - #endif - } - - #ifndef MA_USE_EXPERIMENTAL_LOCK_FREE_JOB_QUEUE - ma_spinlock_lock(&pQueue->lock); - #endif - { - /* - BUG: In lock-free mode, multiple threads can be in this section of code. The "head" variable in the loop below - is stored. One thread can fall through to the freeing of this item while another is still using "head" for the - retrieval of the "next" variable. - - The slot allocator might need to make use of some reference counting to ensure it's only truely freed when - there are no more references to the item. This must be fixed before removing these locks. - */ - - /* Now we need to remove the root item from the list. */ - for (;;) { - head = c89atomic_load_64(&pQueue->head); - tail = c89atomic_load_64(&pQueue->tail); - next = c89atomic_load_64(&pQueue->pJobs[ma_job_extract_slot(head)].next); - - if (ma_job_toc_to_allocation(head) == ma_job_toc_to_allocation(c89atomic_load_64(&pQueue->head))) { - if (ma_job_extract_slot(head) == ma_job_extract_slot(tail)) { - if (ma_job_extract_slot(next) == 0xFFFF) { - #ifndef MA_USE_EXPERIMENTAL_LOCK_FREE_JOB_QUEUE - ma_spinlock_unlock(&pQueue->lock); - #endif - return MA_NO_DATA_AVAILABLE; - } - ma_job_queue_cas(&pQueue->tail, tail, ma_job_extract_slot(next)); - } else { - *pJob = pQueue->pJobs[ma_job_extract_slot(next)]; - if (ma_job_queue_cas(&pQueue->head, head, ma_job_extract_slot(next))) { - break; - } - } - } - } - } - #ifndef MA_USE_EXPERIMENTAL_LOCK_FREE_JOB_QUEUE - ma_spinlock_unlock(&pQueue->lock); - #endif - - ma_slot_allocator_free(&pQueue->allocator, head); - - /* - If it's a quit job make sure it's put back on the queue to ensure other threads have an opportunity to detect it and terminate naturally. We - could instead just leave it on the queue, but that would involve fiddling with the lock-free code above and I want to keep that as simple as - possible. - */ - if (pJob->toc.breakup.code == MA_JOB_TYPE_QUIT) { - ma_job_queue_post(pQueue, pJob); - return MA_CANCELLED; /* Return a cancelled status just in case the thread is checking return codes and not properly checking for a quit job. */ - } - - return MA_SUCCESS; -} - - - - -/************************************************************************************************************************************************************ -************************************************************************************************************************************************************* - -DEVICE I/O -========== - -************************************************************************************************************************************************************* -************************************************************************************************************************************************************/ - -/* Disable run-time linking on certain backends and platforms. */ -#ifndef MA_NO_RUNTIME_LINKING - #if defined(MA_EMSCRIPTEN) || defined(MA_ORBIS) || defined(MA_PROSPERO) - #define MA_NO_RUNTIME_LINKING - #endif -#endif - -#ifndef MA_NO_DEVICE_IO - -#if defined(MA_APPLE) && (__MAC_OS_X_VERSION_MIN_REQUIRED < 101200) - #include /* For mach_absolute_time() */ -#endif - -#ifdef MA_POSIX - #include - #include - - /* No need for dlfcn.h if we're not using runtime linking. */ - #ifndef MA_NO_RUNTIME_LINKING - #include - #endif -#endif - - - -MA_API void ma_device_info_add_native_data_format(ma_device_info* pDeviceInfo, ma_format format, ma_uint32 channels, ma_uint32 sampleRate, ma_uint32 flags) -{ - if (pDeviceInfo == NULL) { - return; - } - - if (pDeviceInfo->nativeDataFormatCount < ma_countof(pDeviceInfo->nativeDataFormats)) { - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = format; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = sampleRate; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = flags; - pDeviceInfo->nativeDataFormatCount += 1; - } -} - - -typedef struct -{ - ma_backend backend; - const char* pName; -} ma_backend_info; - -static ma_backend_info gBackendInfo[] = /* Indexed by the backend enum. Must be in the order backends are declared in the ma_backend enum. */ -{ - {ma_backend_wasapi, "WASAPI"}, - {ma_backend_dsound, "DirectSound"}, - {ma_backend_winmm, "WinMM"}, - {ma_backend_coreaudio, "Core Audio"}, - {ma_backend_sndio, "sndio"}, - {ma_backend_audio4, "audio(4)"}, - {ma_backend_oss, "OSS"}, - {ma_backend_pulseaudio, "PulseAudio"}, - {ma_backend_alsa, "ALSA"}, - {ma_backend_jack, "JACK"}, - {ma_backend_aaudio, "AAudio"}, - {ma_backend_opensl, "OpenSL|ES"}, - {ma_backend_webaudio, "Web Audio"}, - {ma_backend_custom, "Custom"}, - {ma_backend_null, "Null"} -}; - -MA_API const char* ma_get_backend_name(ma_backend backend) -{ - if (backend < 0 || backend >= (int)ma_countof(gBackendInfo)) { - return "Unknown"; - } - - return gBackendInfo[backend].pName; -} - -MA_API ma_result ma_get_backend_from_name(const char* pBackendName, ma_backend* pBackend) -{ - size_t iBackend; - - if (pBackendName == NULL) { - return MA_INVALID_ARGS; - } - - for (iBackend = 0; iBackend < ma_countof(gBackendInfo); iBackend += 1) { - if (ma_strcmp(pBackendName, gBackendInfo[iBackend].pName) == 0) { - if (pBackend != NULL) { - *pBackend = gBackendInfo[iBackend].backend; - } - - return MA_SUCCESS; - } - } - - /* Getting here means the backend name is unknown. */ - return MA_INVALID_ARGS; -} - -MA_API ma_bool32 ma_is_backend_enabled(ma_backend backend) -{ - /* - This looks a little bit gross, but we want all backends to be included in the switch to avoid warnings on some compilers - about some enums not being handled by the switch statement. - */ - switch (backend) - { - case ma_backend_wasapi: - #if defined(MA_HAS_WASAPI) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_dsound: - #if defined(MA_HAS_DSOUND) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_winmm: - #if defined(MA_HAS_WINMM) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_coreaudio: - #if defined(MA_HAS_COREAUDIO) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_sndio: - #if defined(MA_HAS_SNDIO) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_audio4: - #if defined(MA_HAS_AUDIO4) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_oss: - #if defined(MA_HAS_OSS) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_pulseaudio: - #if defined(MA_HAS_PULSEAUDIO) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_alsa: - #if defined(MA_HAS_ALSA) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_jack: - #if defined(MA_HAS_JACK) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_aaudio: - #if defined(MA_HAS_AAUDIO) - #if defined(MA_ANDROID) - { - return ma_android_sdk_version() >= 26; - } - #else - return MA_FALSE; - #endif - #else - return MA_FALSE; - #endif - case ma_backend_opensl: - #if defined(MA_HAS_OPENSL) - #if defined(MA_ANDROID) - { - return ma_android_sdk_version() >= 9; - } - #else - return MA_TRUE; - #endif - #else - return MA_FALSE; - #endif - case ma_backend_webaudio: - #if defined(MA_HAS_WEBAUDIO) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_custom: - #if defined(MA_HAS_CUSTOM) - return MA_TRUE; - #else - return MA_FALSE; - #endif - case ma_backend_null: - #if defined(MA_HAS_NULL) - return MA_TRUE; - #else - return MA_FALSE; - #endif - - default: return MA_FALSE; - } -} - -MA_API ma_result ma_get_enabled_backends(ma_backend* pBackends, size_t backendCap, size_t* pBackendCount) -{ - size_t backendCount; - size_t iBackend; - ma_result result = MA_SUCCESS; - - if (pBackendCount == NULL) { - return MA_INVALID_ARGS; - } - - backendCount = 0; - - for (iBackend = 0; iBackend <= ma_backend_null; iBackend += 1) { - ma_backend backend = (ma_backend)iBackend; - - if (ma_is_backend_enabled(backend)) { - /* The backend is enabled. Try adding it to the list. If there's no room, MA_NO_SPACE needs to be returned. */ - if (backendCount == backendCap) { - result = MA_NO_SPACE; - break; - } else { - pBackends[backendCount] = backend; - backendCount += 1; - } - } - } - - if (pBackendCount != NULL) { - *pBackendCount = backendCount; - } - - return result; -} - -MA_API ma_bool32 ma_is_loopback_supported(ma_backend backend) -{ - switch (backend) - { - case ma_backend_wasapi: return MA_TRUE; - case ma_backend_dsound: return MA_FALSE; - case ma_backend_winmm: return MA_FALSE; - case ma_backend_coreaudio: return MA_FALSE; - case ma_backend_sndio: return MA_FALSE; - case ma_backend_audio4: return MA_FALSE; - case ma_backend_oss: return MA_FALSE; - case ma_backend_pulseaudio: return MA_FALSE; - case ma_backend_alsa: return MA_FALSE; - case ma_backend_jack: return MA_FALSE; - case ma_backend_aaudio: return MA_FALSE; - case ma_backend_opensl: return MA_FALSE; - case ma_backend_webaudio: return MA_FALSE; - case ma_backend_custom: return MA_FALSE; /* <-- Will depend on the implementation of the backend. */ - case ma_backend_null: return MA_FALSE; - default: return MA_FALSE; - } -} - - - -#if defined(MA_WIN32) -/* WASAPI error codes. */ -#define MA_AUDCLNT_E_NOT_INITIALIZED ((HRESULT)0x88890001) -#define MA_AUDCLNT_E_ALREADY_INITIALIZED ((HRESULT)0x88890002) -#define MA_AUDCLNT_E_WRONG_ENDPOINT_TYPE ((HRESULT)0x88890003) -#define MA_AUDCLNT_E_DEVICE_INVALIDATED ((HRESULT)0x88890004) -#define MA_AUDCLNT_E_NOT_STOPPED ((HRESULT)0x88890005) -#define MA_AUDCLNT_E_BUFFER_TOO_LARGE ((HRESULT)0x88890006) -#define MA_AUDCLNT_E_OUT_OF_ORDER ((HRESULT)0x88890007) -#define MA_AUDCLNT_E_UNSUPPORTED_FORMAT ((HRESULT)0x88890008) -#define MA_AUDCLNT_E_INVALID_SIZE ((HRESULT)0x88890009) -#define MA_AUDCLNT_E_DEVICE_IN_USE ((HRESULT)0x8889000A) -#define MA_AUDCLNT_E_BUFFER_OPERATION_PENDING ((HRESULT)0x8889000B) -#define MA_AUDCLNT_E_THREAD_NOT_REGISTERED ((HRESULT)0x8889000C) -#define MA_AUDCLNT_E_NO_SINGLE_PROCESS ((HRESULT)0x8889000D) -#define MA_AUDCLNT_E_EXCLUSIVE_MODE_NOT_ALLOWED ((HRESULT)0x8889000E) -#define MA_AUDCLNT_E_ENDPOINT_CREATE_FAILED ((HRESULT)0x8889000F) -#define MA_AUDCLNT_E_SERVICE_NOT_RUNNING ((HRESULT)0x88890010) -#define MA_AUDCLNT_E_EVENTHANDLE_NOT_EXPECTED ((HRESULT)0x88890011) -#define MA_AUDCLNT_E_EXCLUSIVE_MODE_ONLY ((HRESULT)0x88890012) -#define MA_AUDCLNT_E_BUFDURATION_PERIOD_NOT_EQUAL ((HRESULT)0x88890013) -#define MA_AUDCLNT_E_EVENTHANDLE_NOT_SET ((HRESULT)0x88890014) -#define MA_AUDCLNT_E_INCORRECT_BUFFER_SIZE ((HRESULT)0x88890015) -#define MA_AUDCLNT_E_BUFFER_SIZE_ERROR ((HRESULT)0x88890016) -#define MA_AUDCLNT_E_CPUUSAGE_EXCEEDED ((HRESULT)0x88890017) -#define MA_AUDCLNT_E_BUFFER_ERROR ((HRESULT)0x88890018) -#define MA_AUDCLNT_E_BUFFER_SIZE_NOT_ALIGNED ((HRESULT)0x88890019) -#define MA_AUDCLNT_E_INVALID_DEVICE_PERIOD ((HRESULT)0x88890020) -#define MA_AUDCLNT_E_INVALID_STREAM_FLAG ((HRESULT)0x88890021) -#define MA_AUDCLNT_E_ENDPOINT_OFFLOAD_NOT_CAPABLE ((HRESULT)0x88890022) -#define MA_AUDCLNT_E_OUT_OF_OFFLOAD_RESOURCES ((HRESULT)0x88890023) -#define MA_AUDCLNT_E_OFFLOAD_MODE_ONLY ((HRESULT)0x88890024) -#define MA_AUDCLNT_E_NONOFFLOAD_MODE_ONLY ((HRESULT)0x88890025) -#define MA_AUDCLNT_E_RESOURCES_INVALIDATED ((HRESULT)0x88890026) -#define MA_AUDCLNT_E_RAW_MODE_UNSUPPORTED ((HRESULT)0x88890027) -#define MA_AUDCLNT_E_ENGINE_PERIODICITY_LOCKED ((HRESULT)0x88890028) -#define MA_AUDCLNT_E_ENGINE_FORMAT_LOCKED ((HRESULT)0x88890029) -#define MA_AUDCLNT_E_HEADTRACKING_ENABLED ((HRESULT)0x88890030) -#define MA_AUDCLNT_E_HEADTRACKING_UNSUPPORTED ((HRESULT)0x88890040) -#define MA_AUDCLNT_S_BUFFER_EMPTY ((HRESULT)0x08890001) -#define MA_AUDCLNT_S_THREAD_ALREADY_REGISTERED ((HRESULT)0x08890002) -#define MA_AUDCLNT_S_POSITION_STALLED ((HRESULT)0x08890003) - -#define MA_DS_OK ((HRESULT)0) -#define MA_DS_NO_VIRTUALIZATION ((HRESULT)0x0878000A) -#define MA_DSERR_ALLOCATED ((HRESULT)0x8878000A) -#define MA_DSERR_CONTROLUNAVAIL ((HRESULT)0x8878001E) -#define MA_DSERR_INVALIDPARAM ((HRESULT)0x80070057) /*E_INVALIDARG*/ -#define MA_DSERR_INVALIDCALL ((HRESULT)0x88780032) -#define MA_DSERR_GENERIC ((HRESULT)0x80004005) /*E_FAIL*/ -#define MA_DSERR_PRIOLEVELNEEDED ((HRESULT)0x88780046) -#define MA_DSERR_OUTOFMEMORY ((HRESULT)0x8007000E) /*E_OUTOFMEMORY*/ -#define MA_DSERR_BADFORMAT ((HRESULT)0x88780064) -#define MA_DSERR_UNSUPPORTED ((HRESULT)0x80004001) /*E_NOTIMPL*/ -#define MA_DSERR_NODRIVER ((HRESULT)0x88780078) -#define MA_DSERR_ALREADYINITIALIZED ((HRESULT)0x88780082) -#define MA_DSERR_NOAGGREGATION ((HRESULT)0x80040110) /*CLASS_E_NOAGGREGATION*/ -#define MA_DSERR_BUFFERLOST ((HRESULT)0x88780096) -#define MA_DSERR_OTHERAPPHASPRIO ((HRESULT)0x887800A0) -#define MA_DSERR_UNINITIALIZED ((HRESULT)0x887800AA) -#define MA_DSERR_NOINTERFACE ((HRESULT)0x80004002) /*E_NOINTERFACE*/ -#define MA_DSERR_ACCESSDENIED ((HRESULT)0x80070005) /*E_ACCESSDENIED*/ -#define MA_DSERR_BUFFERTOOSMALL ((HRESULT)0x887800B4) -#define MA_DSERR_DS8_REQUIRED ((HRESULT)0x887800BE) -#define MA_DSERR_SENDLOOP ((HRESULT)0x887800C8) -#define MA_DSERR_BADSENDBUFFERGUID ((HRESULT)0x887800D2) -#define MA_DSERR_OBJECTNOTFOUND ((HRESULT)0x88781161) -#define MA_DSERR_FXUNAVAILABLE ((HRESULT)0x887800DC) - -static ma_result ma_result_from_HRESULT(HRESULT hr) -{ - switch (hr) - { - case NOERROR: return MA_SUCCESS; - /*case S_OK: return MA_SUCCESS;*/ - - case E_POINTER: return MA_INVALID_ARGS; - case E_UNEXPECTED: return MA_ERROR; - case E_NOTIMPL: return MA_NOT_IMPLEMENTED; - case E_OUTOFMEMORY: return MA_OUT_OF_MEMORY; - case E_INVALIDARG: return MA_INVALID_ARGS; - case E_NOINTERFACE: return MA_API_NOT_FOUND; - case E_HANDLE: return MA_INVALID_ARGS; - case E_ABORT: return MA_ERROR; - case E_FAIL: return MA_ERROR; - case E_ACCESSDENIED: return MA_ACCESS_DENIED; - - /* WASAPI */ - case MA_AUDCLNT_E_NOT_INITIALIZED: return MA_DEVICE_NOT_INITIALIZED; - case MA_AUDCLNT_E_ALREADY_INITIALIZED: return MA_DEVICE_ALREADY_INITIALIZED; - case MA_AUDCLNT_E_WRONG_ENDPOINT_TYPE: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_DEVICE_INVALIDATED: return MA_UNAVAILABLE; - case MA_AUDCLNT_E_NOT_STOPPED: return MA_DEVICE_NOT_STOPPED; - case MA_AUDCLNT_E_BUFFER_TOO_LARGE: return MA_TOO_BIG; - case MA_AUDCLNT_E_OUT_OF_ORDER: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_UNSUPPORTED_FORMAT: return MA_FORMAT_NOT_SUPPORTED; - case MA_AUDCLNT_E_INVALID_SIZE: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_DEVICE_IN_USE: return MA_BUSY; - case MA_AUDCLNT_E_BUFFER_OPERATION_PENDING: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_THREAD_NOT_REGISTERED: return MA_DOES_NOT_EXIST; - case MA_AUDCLNT_E_NO_SINGLE_PROCESS: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_EXCLUSIVE_MODE_NOT_ALLOWED: return MA_SHARE_MODE_NOT_SUPPORTED; - case MA_AUDCLNT_E_ENDPOINT_CREATE_FAILED: return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - case MA_AUDCLNT_E_SERVICE_NOT_RUNNING: return MA_NOT_CONNECTED; - case MA_AUDCLNT_E_EVENTHANDLE_NOT_EXPECTED: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_EXCLUSIVE_MODE_ONLY: return MA_SHARE_MODE_NOT_SUPPORTED; - case MA_AUDCLNT_E_BUFDURATION_PERIOD_NOT_EQUAL: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_EVENTHANDLE_NOT_SET: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_INCORRECT_BUFFER_SIZE: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_BUFFER_SIZE_ERROR: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_CPUUSAGE_EXCEEDED: return MA_ERROR; - case MA_AUDCLNT_E_BUFFER_ERROR: return MA_ERROR; - case MA_AUDCLNT_E_BUFFER_SIZE_NOT_ALIGNED: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_INVALID_DEVICE_PERIOD: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_INVALID_STREAM_FLAG: return MA_INVALID_ARGS; - case MA_AUDCLNT_E_ENDPOINT_OFFLOAD_NOT_CAPABLE: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_OUT_OF_OFFLOAD_RESOURCES: return MA_OUT_OF_MEMORY; - case MA_AUDCLNT_E_OFFLOAD_MODE_ONLY: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_NONOFFLOAD_MODE_ONLY: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_RESOURCES_INVALIDATED: return MA_INVALID_DATA; - case MA_AUDCLNT_E_RAW_MODE_UNSUPPORTED: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_ENGINE_PERIODICITY_LOCKED: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_ENGINE_FORMAT_LOCKED: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_HEADTRACKING_ENABLED: return MA_INVALID_OPERATION; - case MA_AUDCLNT_E_HEADTRACKING_UNSUPPORTED: return MA_INVALID_OPERATION; - case MA_AUDCLNT_S_BUFFER_EMPTY: return MA_NO_SPACE; - case MA_AUDCLNT_S_THREAD_ALREADY_REGISTERED: return MA_ALREADY_EXISTS; - case MA_AUDCLNT_S_POSITION_STALLED: return MA_ERROR; - - /* DirectSound */ - /*case MA_DS_OK: return MA_SUCCESS;*/ /* S_OK */ - case MA_DS_NO_VIRTUALIZATION: return MA_SUCCESS; - case MA_DSERR_ALLOCATED: return MA_ALREADY_IN_USE; - case MA_DSERR_CONTROLUNAVAIL: return MA_INVALID_OPERATION; - /*case MA_DSERR_INVALIDPARAM: return MA_INVALID_ARGS;*/ /* E_INVALIDARG */ - case MA_DSERR_INVALIDCALL: return MA_INVALID_OPERATION; - /*case MA_DSERR_GENERIC: return MA_ERROR;*/ /* E_FAIL */ - case MA_DSERR_PRIOLEVELNEEDED: return MA_INVALID_OPERATION; - /*case MA_DSERR_OUTOFMEMORY: return MA_OUT_OF_MEMORY;*/ /* E_OUTOFMEMORY */ - case MA_DSERR_BADFORMAT: return MA_FORMAT_NOT_SUPPORTED; - /*case MA_DSERR_UNSUPPORTED: return MA_NOT_IMPLEMENTED;*/ /* E_NOTIMPL */ - case MA_DSERR_NODRIVER: return MA_FAILED_TO_INIT_BACKEND; - case MA_DSERR_ALREADYINITIALIZED: return MA_DEVICE_ALREADY_INITIALIZED; - case MA_DSERR_NOAGGREGATION: return MA_ERROR; - case MA_DSERR_BUFFERLOST: return MA_UNAVAILABLE; - case MA_DSERR_OTHERAPPHASPRIO: return MA_ACCESS_DENIED; - case MA_DSERR_UNINITIALIZED: return MA_DEVICE_NOT_INITIALIZED; - /*case MA_DSERR_NOINTERFACE: return MA_API_NOT_FOUND;*/ /* E_NOINTERFACE */ - /*case MA_DSERR_ACCESSDENIED: return MA_ACCESS_DENIED;*/ /* E_ACCESSDENIED */ - case MA_DSERR_BUFFERTOOSMALL: return MA_NO_SPACE; - case MA_DSERR_DS8_REQUIRED: return MA_INVALID_OPERATION; - case MA_DSERR_SENDLOOP: return MA_DEADLOCK; - case MA_DSERR_BADSENDBUFFERGUID: return MA_INVALID_ARGS; - case MA_DSERR_OBJECTNOTFOUND: return MA_NO_DEVICE; - case MA_DSERR_FXUNAVAILABLE: return MA_UNAVAILABLE; - - default: return MA_ERROR; - } -} - -/* PROPVARIANT */ -#define MA_VT_LPWSTR 31 -#define MA_VT_BLOB 65 - -#if defined(_MSC_VER) && !defined(__clang__) - #pragma warning(push) - #pragma warning(disable:4201) /* nonstandard extension used: nameless struct/union */ -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wpedantic" /* For ISO C99 doesn't support unnamed structs/unions [-Wpedantic] */ - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc11-extensions" /* anonymous unions are a C11 extension */ - #endif -#endif -typedef struct -{ - WORD vt; - WORD wReserved1; - WORD wReserved2; - WORD wReserved3; - union - { - struct - { - ULONG cbSize; - BYTE* pBlobData; - } blob; - WCHAR* pwszVal; - char pad[16]; /* Just to ensure the size of the struct matches the official version. */ - }; -} MA_PROPVARIANT; -#if defined(_MSC_VER) && !defined(__clang__) - #pragma warning(pop) -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) - #pragma GCC diagnostic pop -#endif - -typedef HRESULT (WINAPI * MA_PFN_CoInitialize)(void* pvReserved); -typedef HRESULT (WINAPI * MA_PFN_CoInitializeEx)(void* pvReserved, DWORD dwCoInit); -typedef void (WINAPI * MA_PFN_CoUninitialize)(void); -typedef HRESULT (WINAPI * MA_PFN_CoCreateInstance)(const IID* rclsid, void* pUnkOuter, DWORD dwClsContext, const IID* riid, void* ppv); -typedef void (WINAPI * MA_PFN_CoTaskMemFree)(void* pv); -typedef HRESULT (WINAPI * MA_PFN_PropVariantClear)(MA_PROPVARIANT *pvar); -typedef int (WINAPI * MA_PFN_StringFromGUID2)(const GUID* const rguid, WCHAR* lpsz, int cchMax); - -typedef HWND (WINAPI * MA_PFN_GetForegroundWindow)(void); -typedef HWND (WINAPI * MA_PFN_GetDesktopWindow)(void); - -#if defined(MA_WIN32_DESKTOP) -/* Microsoft documents these APIs as returning LSTATUS, but the Win32 API shipping with some compilers do not define it. It's just a LONG. */ -typedef LONG (WINAPI * MA_PFN_RegOpenKeyExA)(HKEY hKey, const char* lpSubKey, DWORD ulOptions, DWORD samDesired, HKEY* phkResult); -typedef LONG (WINAPI * MA_PFN_RegCloseKey)(HKEY hKey); -typedef LONG (WINAPI * MA_PFN_RegQueryValueExA)(HKEY hKey, const char* lpValueName, DWORD* lpReserved, DWORD* lpType, BYTE* lpData, DWORD* lpcbData); -#endif /* MA_WIN32_DESKTOP */ - - -MA_API size_t ma_strlen_WCHAR(const WCHAR* str) -{ - size_t len = 0; - while (str[len] != '\0') { - len += 1; - } - - return len; -} - -MA_API int ma_strcmp_WCHAR(const WCHAR *s1, const WCHAR *s2) -{ - while (*s1 != '\0' && *s1 == *s2) { - s1 += 1; - s2 += 1; - } - - return *s1 - *s2; -} - -MA_API int ma_strcpy_s_WCHAR(WCHAR* dst, size_t dstCap, const WCHAR* src) -{ - size_t i; - - if (dst == 0) { - return 22; - } - if (dstCap == 0) { - return 34; - } - if (src == 0) { - dst[0] = '\0'; - return 22; - } - - for (i = 0; i < dstCap && src[i] != '\0'; ++i) { - dst[i] = src[i]; - } - - if (i < dstCap) { - dst[i] = '\0'; - return 0; - } - - dst[0] = '\0'; - return 34; -} -#endif /* MA_WIN32 */ - - -#define MA_DEFAULT_PLAYBACK_DEVICE_NAME "Default Playback Device" -#define MA_DEFAULT_CAPTURE_DEVICE_NAME "Default Capture Device" - - - - -/******************************************************************************* - -Timing - -*******************************************************************************/ -#if defined(MA_WIN32) && !defined(MA_POSIX) - static LARGE_INTEGER g_ma_TimerFrequency; /* <-- Initialized to zero since it's static. */ - void ma_timer_init(ma_timer* pTimer) - { - LARGE_INTEGER counter; - - if (g_ma_TimerFrequency.QuadPart == 0) { - QueryPerformanceFrequency(&g_ma_TimerFrequency); - } - - QueryPerformanceCounter(&counter); - pTimer->counter = counter.QuadPart; - } - - double ma_timer_get_time_in_seconds(ma_timer* pTimer) - { - LARGE_INTEGER counter; - if (!QueryPerformanceCounter(&counter)) { - return 0; - } - - return (double)(counter.QuadPart - pTimer->counter) / g_ma_TimerFrequency.QuadPart; - } -#elif defined(MA_APPLE) && (__MAC_OS_X_VERSION_MIN_REQUIRED < 101200) - static ma_uint64 g_ma_TimerFrequency = 0; - static void ma_timer_init(ma_timer* pTimer) - { - mach_timebase_info_data_t baseTime; - mach_timebase_info(&baseTime); - g_ma_TimerFrequency = (baseTime.denom * 1e9) / baseTime.numer; - - pTimer->counter = mach_absolute_time(); - } - - static double ma_timer_get_time_in_seconds(ma_timer* pTimer) - { - ma_uint64 newTimeCounter = mach_absolute_time(); - ma_uint64 oldTimeCounter = pTimer->counter; - - return (newTimeCounter - oldTimeCounter) / g_ma_TimerFrequency; - } -#elif defined(MA_EMSCRIPTEN) - static MA_INLINE void ma_timer_init(ma_timer* pTimer) - { - pTimer->counterD = emscripten_get_now(); - } - - static MA_INLINE double ma_timer_get_time_in_seconds(ma_timer* pTimer) - { - return (emscripten_get_now() - pTimer->counterD) / 1000; /* Emscripten is in milliseconds. */ - } -#else - #if defined(_POSIX_C_SOURCE) && _POSIX_C_SOURCE >= 199309L - #if defined(CLOCK_MONOTONIC) - #define MA_CLOCK_ID CLOCK_MONOTONIC - #else - #define MA_CLOCK_ID CLOCK_REALTIME - #endif - - static void ma_timer_init(ma_timer* pTimer) - { - struct timespec newTime; - clock_gettime(MA_CLOCK_ID, &newTime); - - pTimer->counter = (newTime.tv_sec * 1000000000) + newTime.tv_nsec; - } - - static double ma_timer_get_time_in_seconds(ma_timer* pTimer) - { - ma_uint64 newTimeCounter; - ma_uint64 oldTimeCounter; - - struct timespec newTime; - clock_gettime(MA_CLOCK_ID, &newTime); - - newTimeCounter = (newTime.tv_sec * 1000000000) + newTime.tv_nsec; - oldTimeCounter = pTimer->counter; - - return (newTimeCounter - oldTimeCounter) / 1000000000.0; - } - #else - static void ma_timer_init(ma_timer* pTimer) - { - struct timeval newTime; - gettimeofday(&newTime, NULL); - - pTimer->counter = (newTime.tv_sec * 1000000) + newTime.tv_usec; - } - - static double ma_timer_get_time_in_seconds(ma_timer* pTimer) - { - ma_uint64 newTimeCounter; - ma_uint64 oldTimeCounter; - - struct timeval newTime; - gettimeofday(&newTime, NULL); - - newTimeCounter = (newTime.tv_sec * 1000000) + newTime.tv_usec; - oldTimeCounter = pTimer->counter; - - return (newTimeCounter - oldTimeCounter) / 1000000.0; - } - #endif -#endif - - -/******************************************************************************* - -Dynamic Linking - -*******************************************************************************/ -MA_API ma_handle ma_dlopen(ma_context* pContext, const char* filename) -{ -#ifndef MA_NO_RUNTIME_LINKING - ma_handle handle; - - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "Loading library: %s\n", filename); - -#ifdef _WIN32 - /* From MSDN: Desktop applications cannot use LoadPackagedLibrary; if a desktop application calls this function it fails with APPMODEL_ERROR_NO_PACKAGE.*/ - #if !defined(WINAPI_FAMILY) || (defined(WINAPI_FAMILY) && (defined(WINAPI_FAMILY_DESKTOP_APP) && WINAPI_FAMILY == WINAPI_FAMILY_DESKTOP_APP)) - handle = (ma_handle)LoadLibraryA(filename); - #else - /* *sigh* It appears there is no ANSI version of LoadPackagedLibrary()... */ - WCHAR filenameW[4096]; - if (MultiByteToWideChar(CP_UTF8, 0, filename, -1, filenameW, sizeof(filenameW)) == 0) { - handle = NULL; - } else { - handle = (ma_handle)LoadPackagedLibrary(filenameW, 0); - } - #endif -#else - handle = (ma_handle)dlopen(filename, RTLD_NOW); -#endif - - /* - I'm not considering failure to load a library an error nor a warning because seamlessly falling through to a lower-priority - backend is a deliberate design choice. Instead I'm logging it as an informational message. - */ - if (handle == NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_INFO, "Failed to load library: %s\n", filename); - } - - (void)pContext; /* It's possible for pContext to be unused. */ - return handle; -#else - /* Runtime linking is disabled. */ - (void)pContext; - (void)filename; - return NULL; -#endif -} - -MA_API void ma_dlclose(ma_context* pContext, ma_handle handle) -{ -#ifndef MA_NO_RUNTIME_LINKING -#ifdef _WIN32 - FreeLibrary((HMODULE)handle); -#else - dlclose((void*)handle); -#endif - - (void)pContext; -#else - /* Runtime linking is disabled. */ - (void)pContext; - (void)handle; -#endif -} - -MA_API ma_proc ma_dlsym(ma_context* pContext, ma_handle handle, const char* symbol) -{ -#ifndef MA_NO_RUNTIME_LINKING - ma_proc proc; - - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "Loading symbol: %s\n", symbol); - -#ifdef _WIN32 - proc = (ma_proc)GetProcAddress((HMODULE)handle, symbol); -#else -#if defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8)) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wpedantic" -#endif - proc = (ma_proc)dlsym((void*)handle, symbol); -#if defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8)) - #pragma GCC diagnostic pop -#endif -#endif - - if (proc == NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "Failed to load symbol: %s\n", symbol); - } - - (void)pContext; /* It's possible for pContext to be unused. */ - return proc; -#else - /* Runtime linking is disabled. */ - (void)pContext; - (void)handle; - (void)symbol; - return NULL; -#endif -} - - -#if 0 -static ma_uint32 ma_get_closest_standard_sample_rate(ma_uint32 sampleRateIn) -{ - ma_uint32 closestRate = 0; - ma_uint32 closestDiff = 0xFFFFFFFF; - size_t iStandardRate; - - for (iStandardRate = 0; iStandardRate < ma_countof(g_maStandardSampleRatePriorities); ++iStandardRate) { - ma_uint32 standardRate = g_maStandardSampleRatePriorities[iStandardRate]; - ma_uint32 diff; - - if (sampleRateIn > standardRate) { - diff = sampleRateIn - standardRate; - } else { - diff = standardRate - sampleRateIn; - } - - if (diff == 0) { - return standardRate; /* The input sample rate is a standard rate. */ - } - - if (closestDiff > diff) { - closestDiff = diff; - closestRate = standardRate; - } - } - - return closestRate; -} -#endif - - -static MA_INLINE unsigned int ma_device_disable_denormals(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (!pDevice->noDisableDenormals) { - return ma_disable_denormals(); - } else { - return 0; - } -} - -static MA_INLINE void ma_device_restore_denormals(ma_device* pDevice, unsigned int prevState) -{ - MA_ASSERT(pDevice != NULL); - - if (!pDevice->noDisableDenormals) { - ma_restore_denormals(prevState); - } else { - /* Do nothing. */ - (void)prevState; - } -} - -static ma_device_notification ma_device_notification_init(ma_device* pDevice, ma_device_notification_type type) -{ - ma_device_notification notification; - - MA_ZERO_OBJECT(¬ification); - notification.pDevice = pDevice; - notification.type = type; - - return notification; -} - -static void ma_device__on_notification(ma_device_notification notification) -{ - MA_ASSERT(notification.pDevice != NULL); - - if (notification.pDevice->onNotification != NULL) { - notification.pDevice->onNotification(¬ification); - } - - /* TEMP FOR COMPATIBILITY: If it's a stopped notification, fire the onStop callback as well. This is only for backwards compatibility and will be removed. */ - if (notification.pDevice->onStop != NULL && notification.type == ma_device_notification_type_stopped) { - notification.pDevice->onStop(notification.pDevice); - } -} - -void ma_device__on_notification_started(ma_device* pDevice) -{ - ma_device__on_notification(ma_device_notification_init(pDevice, ma_device_notification_type_started)); -} - -void ma_device__on_notification_stopped(ma_device* pDevice) -{ - ma_device__on_notification(ma_device_notification_init(pDevice, ma_device_notification_type_stopped)); -} - -void ma_device__on_notification_rerouted(ma_device* pDevice) -{ - ma_device__on_notification(ma_device_notification_init(pDevice, ma_device_notification_type_rerouted)); -} - -void ma_device__on_notification_interruption_began(ma_device* pDevice) -{ - ma_device__on_notification(ma_device_notification_init(pDevice, ma_device_notification_type_interruption_began)); -} - -void ma_device__on_notification_interruption_ended(ma_device* pDevice) -{ - ma_device__on_notification(ma_device_notification_init(pDevice, ma_device_notification_type_interruption_ended)); -} - - -static void ma_device__on_data_inner(ma_device* pDevice, void* pFramesOut, const void* pFramesIn, ma_uint32 frameCount) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pDevice->onData != NULL); - - if (!pDevice->noPreSilencedOutputBuffer && pFramesOut != NULL) { - ma_silence_pcm_frames(pFramesOut, frameCount, pDevice->playback.format, pDevice->playback.channels); - } - - pDevice->onData(pDevice, pFramesOut, pFramesIn, frameCount); -} - -static void ma_device__on_data(ma_device* pDevice, void* pFramesOut, const void* pFramesIn, ma_uint32 frameCount) -{ - MA_ASSERT(pDevice != NULL); - - /* Don't read more data from the client if we're in the process of stopping. */ - if (ma_device_get_state(pDevice) == ma_device_state_stopping) { - return; - } - - if (pDevice->noFixedSizedCallback) { - /* Fast path. Not using a fixed sized callback. Process directly from the specified buffers. */ - ma_device__on_data_inner(pDevice, pFramesOut, pFramesIn, frameCount); - } else { - /* Slow path. Using a fixed sized callback. Need to use the intermediary buffer. */ - ma_uint32 totalFramesProcessed = 0; - - while (totalFramesProcessed < frameCount) { - ma_uint32 totalFramesRemaining = frameCount - totalFramesProcessed; - ma_uint32 framesToProcessThisIteration = 0; - - if (pFramesIn != NULL) { - /* Capturing. Write to the intermediary buffer. If there's no room, fire the callback to empty it. */ - if (pDevice->capture.intermediaryBufferLen < pDevice->capture.intermediaryBufferCap) { - /* There's some room left in the intermediary buffer. Write to it without firing the callback. */ - framesToProcessThisIteration = totalFramesRemaining; - if (framesToProcessThisIteration > pDevice->capture.intermediaryBufferCap - pDevice->capture.intermediaryBufferLen) { - framesToProcessThisIteration = pDevice->capture.intermediaryBufferCap - pDevice->capture.intermediaryBufferLen; - } - - ma_copy_pcm_frames( - ma_offset_pcm_frames_ptr(pDevice->capture.pIntermediaryBuffer, pDevice->capture.intermediaryBufferLen, pDevice->capture.format, pDevice->capture.channels), - ma_offset_pcm_frames_const_ptr(pFramesIn, totalFramesProcessed, pDevice->capture.format, pDevice->capture.channels), - framesToProcessThisIteration, - pDevice->capture.format, pDevice->capture.channels); - - pDevice->capture.intermediaryBufferLen += framesToProcessThisIteration; - } - - if (pDevice->capture.intermediaryBufferLen == pDevice->capture.intermediaryBufferCap) { - /* No room left in the intermediary buffer. Fire the data callback. */ - if (pDevice->type == ma_device_type_duplex) { - /* We'll do the duplex data callback later after we've processed the playback data. */ - } else { - ma_device__on_data_inner(pDevice, NULL, pDevice->capture.pIntermediaryBuffer, pDevice->capture.intermediaryBufferCap); - - /* The intermediary buffer has just been drained. */ - pDevice->capture.intermediaryBufferLen = 0; - } - } - } - - if (pFramesOut != NULL) { - /* Playing back. Read from the intermediary buffer. If there's nothing in it, fire the callback to fill it. */ - if (pDevice->playback.intermediaryBufferLen > 0) { - /* There's some content in the intermediary buffer. Read from that without firing the callback. */ - if (pDevice->type == ma_device_type_duplex) { - /* The frames processed this iteration for a duplex device will always be based on the capture side. Leave it unmodified. */ - } else { - framesToProcessThisIteration = totalFramesRemaining; - if (framesToProcessThisIteration > pDevice->playback.intermediaryBufferLen) { - framesToProcessThisIteration = pDevice->playback.intermediaryBufferLen; - } - } - - ma_copy_pcm_frames( - ma_offset_pcm_frames_ptr(pFramesOut, totalFramesProcessed, pDevice->playback.format, pDevice->playback.channels), - ma_offset_pcm_frames_ptr(pDevice->playback.pIntermediaryBuffer, pDevice->playback.intermediaryBufferCap - pDevice->playback.intermediaryBufferLen, pDevice->playback.format, pDevice->playback.channels), - framesToProcessThisIteration, - pDevice->playback.format, pDevice->playback.channels); - - pDevice->playback.intermediaryBufferLen -= framesToProcessThisIteration; - } - - if (pDevice->playback.intermediaryBufferLen == 0) { - /* There's nothing in the intermediary buffer. Fire the data callback to fill it. */ - if (pDevice->type == ma_device_type_duplex) { - /* In duplex mode, the data callback will be fired later. Nothing to do here. */ - } else { - ma_device__on_data_inner(pDevice, pDevice->playback.pIntermediaryBuffer, NULL, pDevice->playback.intermediaryBufferCap); - - /* The intermediary buffer has just been filled. */ - pDevice->playback.intermediaryBufferLen = pDevice->playback.intermediaryBufferCap; - } - } - } - - /* If we're in duplex mode we might need to do a refill of the data. */ - if (pDevice->type == ma_device_type_duplex) { - if (pDevice->capture.intermediaryBufferLen == pDevice->capture.intermediaryBufferCap) { - ma_device__on_data_inner(pDevice, pDevice->playback.pIntermediaryBuffer, pDevice->capture.pIntermediaryBuffer, pDevice->capture.intermediaryBufferCap); - - pDevice->playback.intermediaryBufferLen = pDevice->playback.intermediaryBufferCap; /* The playback buffer will have just been filled. */ - pDevice->capture.intermediaryBufferLen = 0; /* The intermediary buffer has just been drained. */ - } - } - - /* Make sure this is only incremented once in the duplex case. */ - totalFramesProcessed += framesToProcessThisIteration; - } - } -} - -static void ma_device__handle_data_callback(ma_device* pDevice, void* pFramesOut, const void* pFramesIn, ma_uint32 frameCount) -{ - float masterVolumeFactor; - - ma_device_get_master_volume(pDevice, &masterVolumeFactor); /* Use ma_device_get_master_volume() to ensure the volume is loaded atomically. */ - - if (pDevice->onData) { - unsigned int prevDenormalState = ma_device_disable_denormals(pDevice); - { - /* Volume control of input makes things a bit awkward because the input buffer is read-only. We'll need to use a temp buffer and loop in this case. */ - if (pFramesIn != NULL && masterVolumeFactor < 1) { - ma_uint8 tempFramesIn[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 bpfCapture = ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels); - ma_uint32 bpfPlayback = ma_get_bytes_per_frame(pDevice->playback.format, pDevice->playback.channels); - ma_uint32 totalFramesProcessed = 0; - while (totalFramesProcessed < frameCount) { - ma_uint32 framesToProcessThisIteration = frameCount - totalFramesProcessed; - if (framesToProcessThisIteration > sizeof(tempFramesIn)/bpfCapture) { - framesToProcessThisIteration = sizeof(tempFramesIn)/bpfCapture; - } - - ma_copy_and_apply_volume_factor_pcm_frames(tempFramesIn, ma_offset_ptr(pFramesIn, totalFramesProcessed*bpfCapture), framesToProcessThisIteration, pDevice->capture.format, pDevice->capture.channels, masterVolumeFactor); - - ma_device__on_data(pDevice, ma_offset_ptr(pFramesOut, totalFramesProcessed*bpfPlayback), tempFramesIn, framesToProcessThisIteration); - - totalFramesProcessed += framesToProcessThisIteration; - } - } else { - ma_device__on_data(pDevice, pFramesOut, pFramesIn, frameCount); - } - - /* Volume control and clipping for playback devices. */ - if (pFramesOut != NULL) { - if (masterVolumeFactor < 1) { - if (pFramesIn == NULL) { /* <-- In full-duplex situations, the volume will have been applied to the input samples before the data callback. Applying it again post-callback will incorrectly compound it. */ - ma_apply_volume_factor_pcm_frames(pFramesOut, frameCount, pDevice->playback.format, pDevice->playback.channels, masterVolumeFactor); - } - } - - if (!pDevice->noClip && pDevice->playback.format == ma_format_f32) { - ma_clip_samples_f32((float*)pFramesOut, (const float*)pFramesOut, frameCount * pDevice->playback.channels); /* Intentionally specifying the same pointer for both input and output for in-place processing. */ - } - } - } - ma_device_restore_denormals(pDevice, prevDenormalState); - } -} - - - -/* A helper function for reading sample data from the client. */ -static void ma_device__read_frames_from_client(ma_device* pDevice, ma_uint32 frameCount, void* pFramesOut) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(frameCount > 0); - MA_ASSERT(pFramesOut != NULL); - - if (pDevice->playback.converter.isPassthrough) { - ma_device__handle_data_callback(pDevice, pFramesOut, NULL, frameCount); - } else { - ma_result result; - ma_uint64 totalFramesReadOut; - void* pRunningFramesOut; - - totalFramesReadOut = 0; - pRunningFramesOut = pFramesOut; - - /* - We run slightly different logic depending on whether or not we're using a heap-allocated - buffer for caching input data. This will be the case if the data converter does not have - the ability to retrieve the required input frame count for a given output frame count. - */ - if (pDevice->playback.pInputCache != NULL) { - while (totalFramesReadOut < frameCount) { - ma_uint64 framesToReadThisIterationIn; - ma_uint64 framesToReadThisIterationOut; - - /* If there's any data available in the cache, that needs to get processed first. */ - if (pDevice->playback.inputCacheRemaining > 0) { - framesToReadThisIterationOut = (frameCount - totalFramesReadOut); - framesToReadThisIterationIn = framesToReadThisIterationOut; - if (framesToReadThisIterationIn > pDevice->playback.inputCacheRemaining) { - framesToReadThisIterationIn = pDevice->playback.inputCacheRemaining; - } - - result = ma_data_converter_process_pcm_frames(&pDevice->playback.converter, ma_offset_pcm_frames_ptr(pDevice->playback.pInputCache, pDevice->playback.inputCacheConsumed, pDevice->playback.format, pDevice->playback.channels), &framesToReadThisIterationIn, pRunningFramesOut, &framesToReadThisIterationOut); - if (result != MA_SUCCESS) { - break; - } - - pDevice->playback.inputCacheConsumed += framesToReadThisIterationIn; - pDevice->playback.inputCacheRemaining -= framesToReadThisIterationIn; - - totalFramesReadOut += framesToReadThisIterationOut; - pRunningFramesOut = ma_offset_ptr(pRunningFramesOut, framesToReadThisIterationOut * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - - if (framesToReadThisIterationIn == 0 && framesToReadThisIterationOut == 0) { - break; /* We're done. */ - } - } - - /* Getting here means there's no data in the cache and we need to fill it up with data from the client. */ - if (pDevice->playback.inputCacheRemaining == 0) { - ma_device__handle_data_callback(pDevice, pDevice->playback.pInputCache, NULL, (ma_uint32)pDevice->playback.inputCacheCap); - - pDevice->playback.inputCacheConsumed = 0; - pDevice->playback.inputCacheRemaining = pDevice->playback.inputCacheCap; - } - } - } else { - while (totalFramesReadOut < frameCount) { - ma_uint8 pIntermediaryBuffer[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In client format. */ - ma_uint64 intermediaryBufferCap = sizeof(pIntermediaryBuffer) / ma_get_bytes_per_frame(pDevice->playback.format, pDevice->playback.channels); - ma_uint64 framesToReadThisIterationIn; - ma_uint64 framesReadThisIterationIn; - ma_uint64 framesToReadThisIterationOut; - ma_uint64 framesReadThisIterationOut; - ma_uint64 requiredInputFrameCount; - - framesToReadThisIterationOut = (frameCount - totalFramesReadOut); - framesToReadThisIterationIn = framesToReadThisIterationOut; - if (framesToReadThisIterationIn > intermediaryBufferCap) { - framesToReadThisIterationIn = intermediaryBufferCap; - } - - ma_data_converter_get_required_input_frame_count(&pDevice->playback.converter, framesToReadThisIterationOut, &requiredInputFrameCount); - if (framesToReadThisIterationIn > requiredInputFrameCount) { - framesToReadThisIterationIn = requiredInputFrameCount; - } - - if (framesToReadThisIterationIn > 0) { - ma_device__handle_data_callback(pDevice, pIntermediaryBuffer, NULL, (ma_uint32)framesToReadThisIterationIn); - } - - /* - At this point we have our decoded data in input format and now we need to convert to output format. Note that even if we didn't read any - input frames, we still want to try processing frames because there may some output frames generated from cached input data. - */ - framesReadThisIterationIn = framesToReadThisIterationIn; - framesReadThisIterationOut = framesToReadThisIterationOut; - result = ma_data_converter_process_pcm_frames(&pDevice->playback.converter, pIntermediaryBuffer, &framesReadThisIterationIn, pRunningFramesOut, &framesReadThisIterationOut); - if (result != MA_SUCCESS) { - break; - } - - totalFramesReadOut += framesReadThisIterationOut; - pRunningFramesOut = ma_offset_ptr(pRunningFramesOut, framesReadThisIterationOut * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - - if (framesReadThisIterationIn == 0 && framesReadThisIterationOut == 0) { - break; /* We're done. */ - } - } - } - } -} - -/* A helper for sending sample data to the client. */ -static void ma_device__send_frames_to_client(ma_device* pDevice, ma_uint32 frameCountInDeviceFormat, const void* pFramesInDeviceFormat) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(frameCountInDeviceFormat > 0); - MA_ASSERT(pFramesInDeviceFormat != NULL); - - if (pDevice->capture.converter.isPassthrough) { - ma_device__handle_data_callback(pDevice, NULL, pFramesInDeviceFormat, frameCountInDeviceFormat); - } else { - ma_result result; - ma_uint8 pFramesInClientFormat[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint64 framesInClientFormatCap = sizeof(pFramesInClientFormat) / ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels); - ma_uint64 totalDeviceFramesProcessed = 0; - ma_uint64 totalClientFramesProcessed = 0; - const void* pRunningFramesInDeviceFormat = pFramesInDeviceFormat; - - /* We just keep going until we've exhaused all of our input frames and cannot generate any more output frames. */ - for (;;) { - ma_uint64 deviceFramesProcessedThisIteration; - ma_uint64 clientFramesProcessedThisIteration; - - deviceFramesProcessedThisIteration = (frameCountInDeviceFormat - totalDeviceFramesProcessed); - clientFramesProcessedThisIteration = framesInClientFormatCap; - - result = ma_data_converter_process_pcm_frames(&pDevice->capture.converter, pRunningFramesInDeviceFormat, &deviceFramesProcessedThisIteration, pFramesInClientFormat, &clientFramesProcessedThisIteration); - if (result != MA_SUCCESS) { - break; - } - - if (clientFramesProcessedThisIteration > 0) { - ma_device__handle_data_callback(pDevice, NULL, pFramesInClientFormat, (ma_uint32)clientFramesProcessedThisIteration); /* Safe cast. */ - } - - pRunningFramesInDeviceFormat = ma_offset_ptr(pRunningFramesInDeviceFormat, deviceFramesProcessedThisIteration * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels)); - totalDeviceFramesProcessed += deviceFramesProcessedThisIteration; - totalClientFramesProcessed += clientFramesProcessedThisIteration; - - /* This is just to silence a warning. I might want to use this variable later so leaving in place for now. */ - (void)totalClientFramesProcessed; - - if (deviceFramesProcessedThisIteration == 0 && clientFramesProcessedThisIteration == 0) { - break; /* We're done. */ - } - } - } -} - -static ma_result ma_device__handle_duplex_callback_capture(ma_device* pDevice, ma_uint32 frameCountInDeviceFormat, const void* pFramesInDeviceFormat, ma_pcm_rb* pRB) -{ - ma_result result; - ma_uint32 totalDeviceFramesProcessed = 0; - const void* pRunningFramesInDeviceFormat = pFramesInDeviceFormat; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(frameCountInDeviceFormat > 0); - MA_ASSERT(pFramesInDeviceFormat != NULL); - MA_ASSERT(pRB != NULL); - - /* Write to the ring buffer. The ring buffer is in the client format which means we need to convert. */ - for (;;) { - ma_uint32 framesToProcessInDeviceFormat = (frameCountInDeviceFormat - totalDeviceFramesProcessed); - ma_uint32 framesToProcessInClientFormat = MA_DATA_CONVERTER_STACK_BUFFER_SIZE / ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels); - ma_uint64 framesProcessedInDeviceFormat; - ma_uint64 framesProcessedInClientFormat; - void* pFramesInClientFormat; - - result = ma_pcm_rb_acquire_write(pRB, &framesToProcessInClientFormat, &pFramesInClientFormat); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "Failed to acquire capture PCM frames from ring buffer."); - break; - } - - if (framesToProcessInClientFormat == 0) { - if (ma_pcm_rb_pointer_distance(pRB) == (ma_int32)ma_pcm_rb_get_subbuffer_size(pRB)) { - break; /* Overrun. Not enough room in the ring buffer for input frame. Excess frames are dropped. */ - } - } - - /* Convert. */ - framesProcessedInDeviceFormat = framesToProcessInDeviceFormat; - framesProcessedInClientFormat = framesToProcessInClientFormat; - result = ma_data_converter_process_pcm_frames(&pDevice->capture.converter, pRunningFramesInDeviceFormat, &framesProcessedInDeviceFormat, pFramesInClientFormat, &framesProcessedInClientFormat); - if (result != MA_SUCCESS) { - break; - } - - result = ma_pcm_rb_commit_write(pRB, (ma_uint32)framesProcessedInClientFormat); /* Safe cast. */ - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "Failed to commit capture PCM frames to ring buffer."); - break; - } - - pRunningFramesInDeviceFormat = ma_offset_ptr(pRunningFramesInDeviceFormat, framesProcessedInDeviceFormat * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels)); - totalDeviceFramesProcessed += (ma_uint32)framesProcessedInDeviceFormat; /* Safe cast. */ - - /* We're done when we're unable to process any client nor device frames. */ - if (framesProcessedInClientFormat == 0 && framesProcessedInDeviceFormat == 0) { - break; /* Done. */ - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device__handle_duplex_callback_playback(ma_device* pDevice, ma_uint32 frameCount, void* pFramesInInternalFormat, ma_pcm_rb* pRB) -{ - ma_result result; - ma_uint8 silentInputFrames[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 totalFramesReadOut = 0; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(frameCount > 0); - MA_ASSERT(pFramesInInternalFormat != NULL); - MA_ASSERT(pRB != NULL); - MA_ASSERT(pDevice->playback.pInputCache != NULL); - - /* - Sitting in the ring buffer should be captured data from the capture callback in external format. If there's not enough data in there for - the whole frameCount frames we just use silence instead for the input data. - */ - MA_ZERO_MEMORY(silentInputFrames, sizeof(silentInputFrames)); - - while (totalFramesReadOut < frameCount && ma_device_is_started(pDevice)) { - /* - We should have a buffer allocated on the heap. Any playback frames still sitting in there - need to be sent to the internal device before we process any more data from the client. - */ - if (pDevice->playback.inputCacheRemaining > 0) { - ma_uint64 framesConvertedIn = pDevice->playback.inputCacheRemaining; - ma_uint64 framesConvertedOut = (frameCount - totalFramesReadOut); - ma_data_converter_process_pcm_frames(&pDevice->playback.converter, ma_offset_pcm_frames_ptr(pDevice->playback.pInputCache, pDevice->playback.inputCacheConsumed, pDevice->playback.format, pDevice->playback.channels), &framesConvertedIn, pFramesInInternalFormat, &framesConvertedOut); - - pDevice->playback.inputCacheConsumed += framesConvertedIn; - pDevice->playback.inputCacheRemaining -= framesConvertedIn; - - totalFramesReadOut += (ma_uint32)framesConvertedOut; /* Safe cast. */ - pFramesInInternalFormat = ma_offset_ptr(pFramesInInternalFormat, framesConvertedOut * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - } - - /* If there's no more data in the cache we'll need to fill it with some. */ - if (totalFramesReadOut < frameCount && pDevice->playback.inputCacheRemaining == 0) { - ma_uint32 inputFrameCount; - void* pInputFrames; - - inputFrameCount = (ma_uint32)pDevice->playback.inputCacheCap; - result = ma_pcm_rb_acquire_read(pRB, &inputFrameCount, &pInputFrames); - if (result == MA_SUCCESS) { - if (inputFrameCount > 0) { - ma_device__handle_data_callback(pDevice, pDevice->playback.pInputCache, pInputFrames, inputFrameCount); - } else { - if (ma_pcm_rb_pointer_distance(pRB) == 0) { - break; /* Underrun. */ - } - } - } else { - /* No capture data available. Feed in silence. */ - inputFrameCount = (ma_uint32)ma_min(pDevice->playback.inputCacheCap, sizeof(silentInputFrames) / ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels)); - ma_device__handle_data_callback(pDevice, pDevice->playback.pInputCache, silentInputFrames, inputFrameCount); - } - - pDevice->playback.inputCacheConsumed = 0; - pDevice->playback.inputCacheRemaining = inputFrameCount; - - result = ma_pcm_rb_commit_read(pRB, inputFrameCount); - if (result != MA_SUCCESS) { - return result; /* Should never happen. */ - } - } - } - - return MA_SUCCESS; -} - -/* A helper for changing the state of the device. */ -static MA_INLINE void ma_device__set_state(ma_device* pDevice, ma_device_state newState) -{ - ma_atomic_device_state_set(&pDevice->state, newState); -} - - -#if defined(MA_WIN32) - GUID MA_GUID_KSDATAFORMAT_SUBTYPE_PCM = {0x00000001, 0x0000, 0x0010, {0x80, 0x00, 0x00, 0xaa, 0x00, 0x38, 0x9b, 0x71}}; - GUID MA_GUID_KSDATAFORMAT_SUBTYPE_IEEE_FLOAT = {0x00000003, 0x0000, 0x0010, {0x80, 0x00, 0x00, 0xaa, 0x00, 0x38, 0x9b, 0x71}}; - /*GUID MA_GUID_KSDATAFORMAT_SUBTYPE_ALAW = {0x00000006, 0x0000, 0x0010, {0x80, 0x00, 0x00, 0xaa, 0x00, 0x38, 0x9b, 0x71}};*/ - /*GUID MA_GUID_KSDATAFORMAT_SUBTYPE_MULAW = {0x00000007, 0x0000, 0x0010, {0x80, 0x00, 0x00, 0xaa, 0x00, 0x38, 0x9b, 0x71}};*/ -#endif - - - -MA_API ma_uint32 ma_get_format_priority_index(ma_format format) /* Lower = better. */ -{ - ma_uint32 i; - for (i = 0; i < ma_countof(g_maFormatPriorities); ++i) { - if (g_maFormatPriorities[i] == format) { - return i; - } - } - - /* Getting here means the format could not be found or is equal to ma_format_unknown. */ - return (ma_uint32)-1; -} - -static ma_result ma_device__post_init_setup(ma_device* pDevice, ma_device_type deviceType); - -static ma_bool32 ma_device_descriptor_is_valid(const ma_device_descriptor* pDeviceDescriptor) -{ - if (pDeviceDescriptor == NULL) { - return MA_FALSE; - } - - if (pDeviceDescriptor->format == ma_format_unknown) { - return MA_FALSE; - } - - if (pDeviceDescriptor->channels == 0 || pDeviceDescriptor->channels > MA_MAX_CHANNELS) { - return MA_FALSE; - } - - if (pDeviceDescriptor->sampleRate == 0) { - return MA_FALSE; - } - - return MA_TRUE; -} - - -static ma_result ma_device_audio_thread__default_read_write(ma_device* pDevice) -{ - ma_result result = MA_SUCCESS; - ma_bool32 exitLoop = MA_FALSE; - ma_uint8 capturedDeviceData[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint8 playbackDeviceData[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 capturedDeviceDataCapInFrames = 0; - ma_uint32 playbackDeviceDataCapInFrames = 0; - - MA_ASSERT(pDevice != NULL); - - /* Just some quick validation on the device type and the available callbacks. */ - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex || pDevice->type == ma_device_type_loopback) { - if (pDevice->pContext->callbacks.onDeviceRead == NULL) { - return MA_NOT_IMPLEMENTED; - } - - capturedDeviceDataCapInFrames = sizeof(capturedDeviceData) / ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - if (pDevice->pContext->callbacks.onDeviceWrite == NULL) { - return MA_NOT_IMPLEMENTED; - } - - playbackDeviceDataCapInFrames = sizeof(playbackDeviceData) / ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - } - - /* NOTE: The device was started outside of this function, in the worker thread. */ - - while (ma_device_get_state(pDevice) == ma_device_state_started && !exitLoop) { - switch (pDevice->type) { - case ma_device_type_duplex: - { - /* The process is: onDeviceRead() -> convert -> callback -> convert -> onDeviceWrite() */ - ma_uint32 totalCapturedDeviceFramesProcessed = 0; - ma_uint32 capturedDevicePeriodSizeInFrames = ma_min(pDevice->capture.internalPeriodSizeInFrames, pDevice->playback.internalPeriodSizeInFrames); - - while (totalCapturedDeviceFramesProcessed < capturedDevicePeriodSizeInFrames) { - ma_uint32 capturedDeviceFramesRemaining; - ma_uint32 capturedDeviceFramesProcessed; - ma_uint32 capturedDeviceFramesToProcess; - ma_uint32 capturedDeviceFramesToTryProcessing = capturedDevicePeriodSizeInFrames - totalCapturedDeviceFramesProcessed; - if (capturedDeviceFramesToTryProcessing > capturedDeviceDataCapInFrames) { - capturedDeviceFramesToTryProcessing = capturedDeviceDataCapInFrames; - } - - result = pDevice->pContext->callbacks.onDeviceRead(pDevice, capturedDeviceData, capturedDeviceFramesToTryProcessing, &capturedDeviceFramesToProcess); - if (result != MA_SUCCESS) { - exitLoop = MA_TRUE; - break; - } - - capturedDeviceFramesRemaining = capturedDeviceFramesToProcess; - capturedDeviceFramesProcessed = 0; - - /* At this point we have our captured data in device format and we now need to convert it to client format. */ - for (;;) { - ma_uint8 capturedClientData[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint8 playbackClientData[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 capturedClientDataCapInFrames = sizeof(capturedClientData) / ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels); - ma_uint32 playbackClientDataCapInFrames = sizeof(playbackClientData) / ma_get_bytes_per_frame(pDevice->playback.format, pDevice->playback.channels); - ma_uint64 capturedClientFramesToProcessThisIteration = ma_min(capturedClientDataCapInFrames, playbackClientDataCapInFrames); - ma_uint64 capturedDeviceFramesToProcessThisIteration = capturedDeviceFramesRemaining; - ma_uint8* pRunningCapturedDeviceFrames = ma_offset_ptr(capturedDeviceData, capturedDeviceFramesProcessed * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels)); - - /* Convert capture data from device format to client format. */ - result = ma_data_converter_process_pcm_frames(&pDevice->capture.converter, pRunningCapturedDeviceFrames, &capturedDeviceFramesToProcessThisIteration, capturedClientData, &capturedClientFramesToProcessThisIteration); - if (result != MA_SUCCESS) { - break; - } - - /* - If we weren't able to generate any output frames it must mean we've exhaused all of our input. The only time this would not be the case is if capturedClientData was too small - which should never be the case when it's of the size MA_DATA_CONVERTER_STACK_BUFFER_SIZE. - */ - if (capturedClientFramesToProcessThisIteration == 0) { - break; - } - - ma_device__handle_data_callback(pDevice, playbackClientData, capturedClientData, (ma_uint32)capturedClientFramesToProcessThisIteration); /* Safe cast .*/ - - capturedDeviceFramesProcessed += (ma_uint32)capturedDeviceFramesToProcessThisIteration; /* Safe cast. */ - capturedDeviceFramesRemaining -= (ma_uint32)capturedDeviceFramesToProcessThisIteration; /* Safe cast. */ - - /* At this point the playbackClientData buffer should be holding data that needs to be written to the device. */ - for (;;) { - ma_uint64 convertedClientFrameCount = capturedClientFramesToProcessThisIteration; - ma_uint64 convertedDeviceFrameCount = playbackDeviceDataCapInFrames; - result = ma_data_converter_process_pcm_frames(&pDevice->playback.converter, playbackClientData, &convertedClientFrameCount, playbackDeviceData, &convertedDeviceFrameCount); - if (result != MA_SUCCESS) { - break; - } - - result = pDevice->pContext->callbacks.onDeviceWrite(pDevice, playbackDeviceData, (ma_uint32)convertedDeviceFrameCount, NULL); /* Safe cast. */ - if (result != MA_SUCCESS) { - exitLoop = MA_TRUE; - break; - } - - capturedClientFramesToProcessThisIteration -= (ma_uint32)convertedClientFrameCount; /* Safe cast. */ - if (capturedClientFramesToProcessThisIteration == 0) { - break; - } - } - - /* In case an error happened from ma_device_write__null()... */ - if (result != MA_SUCCESS) { - exitLoop = MA_TRUE; - break; - } - } - - /* Make sure we don't get stuck in the inner loop. */ - if (capturedDeviceFramesProcessed == 0) { - break; - } - - totalCapturedDeviceFramesProcessed += capturedDeviceFramesProcessed; - } - } break; - - case ma_device_type_capture: - case ma_device_type_loopback: - { - ma_uint32 periodSizeInFrames = pDevice->capture.internalPeriodSizeInFrames; - ma_uint32 framesReadThisPeriod = 0; - while (framesReadThisPeriod < periodSizeInFrames) { - ma_uint32 framesRemainingInPeriod = periodSizeInFrames - framesReadThisPeriod; - ma_uint32 framesProcessed; - ma_uint32 framesToReadThisIteration = framesRemainingInPeriod; - if (framesToReadThisIteration > capturedDeviceDataCapInFrames) { - framesToReadThisIteration = capturedDeviceDataCapInFrames; - } - - result = pDevice->pContext->callbacks.onDeviceRead(pDevice, capturedDeviceData, framesToReadThisIteration, &framesProcessed); - if (result != MA_SUCCESS) { - exitLoop = MA_TRUE; - break; - } - - /* Make sure we don't get stuck in the inner loop. */ - if (framesProcessed == 0) { - break; - } - - ma_device__send_frames_to_client(pDevice, framesProcessed, capturedDeviceData); - - framesReadThisPeriod += framesProcessed; - } - } break; - - case ma_device_type_playback: - { - /* We write in chunks of the period size, but use a stack allocated buffer for the intermediary. */ - ma_uint32 periodSizeInFrames = pDevice->playback.internalPeriodSizeInFrames; - ma_uint32 framesWrittenThisPeriod = 0; - while (framesWrittenThisPeriod < periodSizeInFrames) { - ma_uint32 framesRemainingInPeriod = periodSizeInFrames - framesWrittenThisPeriod; - ma_uint32 framesProcessed; - ma_uint32 framesToWriteThisIteration = framesRemainingInPeriod; - if (framesToWriteThisIteration > playbackDeviceDataCapInFrames) { - framesToWriteThisIteration = playbackDeviceDataCapInFrames; - } - - ma_device__read_frames_from_client(pDevice, framesToWriteThisIteration, playbackDeviceData); - - result = pDevice->pContext->callbacks.onDeviceWrite(pDevice, playbackDeviceData, framesToWriteThisIteration, &framesProcessed); - if (result != MA_SUCCESS) { - exitLoop = MA_TRUE; - break; - } - - /* Make sure we don't get stuck in the inner loop. */ - if (framesProcessed == 0) { - break; - } - - framesWrittenThisPeriod += framesProcessed; - } - } break; - - /* Should never get here. */ - default: break; - } - } - - return result; -} - - - -/******************************************************************************* - -Null Backend - -*******************************************************************************/ -#ifdef MA_HAS_NULL - -#define MA_DEVICE_OP_NONE__NULL 0 -#define MA_DEVICE_OP_START__NULL 1 -#define MA_DEVICE_OP_SUSPEND__NULL 2 -#define MA_DEVICE_OP_KILL__NULL 3 - -static ma_thread_result MA_THREADCALL ma_device_thread__null(void* pData) -{ - ma_device* pDevice = (ma_device*)pData; - MA_ASSERT(pDevice != NULL); - - for (;;) { /* Keep the thread alive until the device is uninitialized. */ - ma_uint32 operation; - - /* Wait for an operation to be requested. */ - ma_event_wait(&pDevice->null_device.operationEvent); - - /* At this point an event should have been triggered. */ - operation = pDevice->null_device.operation; - - /* Starting the device needs to put the thread into a loop. */ - if (operation == MA_DEVICE_OP_START__NULL) { - /* Reset the timer just in case. */ - ma_timer_init(&pDevice->null_device.timer); - - /* Getting here means a suspend or kill operation has been requested. */ - pDevice->null_device.operationResult = MA_SUCCESS; - ma_event_signal(&pDevice->null_device.operationCompletionEvent); - ma_semaphore_release(&pDevice->null_device.operationSemaphore); - continue; - } - - /* Suspending the device means we need to stop the timer and just continue the loop. */ - if (operation == MA_DEVICE_OP_SUSPEND__NULL) { - /* We need to add the current run time to the prior run time, then reset the timer. */ - pDevice->null_device.priorRunTime += ma_timer_get_time_in_seconds(&pDevice->null_device.timer); - ma_timer_init(&pDevice->null_device.timer); - - /* We're done. */ - pDevice->null_device.operationResult = MA_SUCCESS; - ma_event_signal(&pDevice->null_device.operationCompletionEvent); - ma_semaphore_release(&pDevice->null_device.operationSemaphore); - continue; - } - - /* Killing the device means we need to get out of this loop so that this thread can terminate. */ - if (operation == MA_DEVICE_OP_KILL__NULL) { - pDevice->null_device.operationResult = MA_SUCCESS; - ma_event_signal(&pDevice->null_device.operationCompletionEvent); - ma_semaphore_release(&pDevice->null_device.operationSemaphore); - break; - } - - /* Getting a signal on a "none" operation probably means an error. Return invalid operation. */ - if (operation == MA_DEVICE_OP_NONE__NULL) { - MA_ASSERT(MA_FALSE); /* <-- Trigger this in debug mode to ensure developers are aware they're doing something wrong (or there's a bug in a miniaudio). */ - pDevice->null_device.operationResult = MA_INVALID_OPERATION; - ma_event_signal(&pDevice->null_device.operationCompletionEvent); - ma_semaphore_release(&pDevice->null_device.operationSemaphore); - continue; /* Continue the loop. Don't terminate. */ - } - } - - return (ma_thread_result)0; -} - -static ma_result ma_device_do_operation__null(ma_device* pDevice, ma_uint32 operation) -{ - ma_result result; - - /* - TODO: Need to review this and consider just using mutual exclusion. I think the original motivation - for this was to just post the event to a queue and return immediately, but that has since changed - and now this function is synchronous. I think this can be simplified to just use a mutex. - */ - - /* - The first thing to do is wait for an operation slot to become available. We only have a single slot for this, but we could extend this later - to support queing of operations. - */ - result = ma_semaphore_wait(&pDevice->null_device.operationSemaphore); - if (result != MA_SUCCESS) { - return result; /* Failed to wait for the event. */ - } - - /* - When we get here it means the background thread is not referencing the operation code and it can be changed. After changing this we need to - signal an event to the worker thread to let it know that it can start work. - */ - pDevice->null_device.operation = operation; - - /* Once the operation code has been set, the worker thread can start work. */ - if (ma_event_signal(&pDevice->null_device.operationEvent) != MA_SUCCESS) { - return MA_ERROR; - } - - /* We want everything to be synchronous so we're going to wait for the worker thread to complete it's operation. */ - if (ma_event_wait(&pDevice->null_device.operationCompletionEvent) != MA_SUCCESS) { - return MA_ERROR; - } - - return pDevice->null_device.operationResult; -} - -static ma_uint64 ma_device_get_total_run_time_in_frames__null(ma_device* pDevice) -{ - ma_uint32 internalSampleRate; - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - internalSampleRate = pDevice->capture.internalSampleRate; - } else { - internalSampleRate = pDevice->playback.internalSampleRate; - } - - return (ma_uint64)((pDevice->null_device.priorRunTime + ma_timer_get_time_in_seconds(&pDevice->null_device.timer)) * internalSampleRate); -} - -static ma_result ma_context_enumerate_devices__null(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_bool32 cbResult = MA_TRUE; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* Playback. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), "NULL Playback Device", (size_t)-1); - deviceInfo.isDefault = MA_TRUE; /* Only one playback and capture device for the null backend, so might as well mark as default. */ - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - - /* Capture. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), "NULL Capture Device", (size_t)-1); - deviceInfo.isDefault = MA_TRUE; /* Only one playback and capture device for the null backend, so might as well mark as default. */ - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - - (void)cbResult; /* Silence a static analysis warning. */ - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__null(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - MA_ASSERT(pContext != NULL); - - if (pDeviceID != NULL && pDeviceID->nullbackend != 0) { - return MA_NO_DEVICE; /* Don't know the device. */ - } - - /* Name / Description */ - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), "NULL Playback Device", (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), "NULL Capture Device", (size_t)-1); - } - - pDeviceInfo->isDefault = MA_TRUE; /* Only one playback and capture device for the null backend, so might as well mark as default. */ - - /* Support everything on the null backend. */ - pDeviceInfo->nativeDataFormats[0].format = ma_format_unknown; - pDeviceInfo->nativeDataFormats[0].channels = 0; - pDeviceInfo->nativeDataFormats[0].sampleRate = 0; - pDeviceInfo->nativeDataFormats[0].flags = 0; - pDeviceInfo->nativeDataFormatCount = 1; - - (void)pContext; - return MA_SUCCESS; -} - - -static ma_result ma_device_uninit__null(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - /* Keep it clean and wait for the device thread to finish before returning. */ - ma_device_do_operation__null(pDevice, MA_DEVICE_OP_KILL__NULL); - - /* Wait for the thread to finish before continuing. */ - ma_thread_wait(&pDevice->null_device.deviceThread); - - /* At this point the loop in the device thread is as good as terminated so we can uninitialize our events. */ - ma_semaphore_uninit(&pDevice->null_device.operationSemaphore); - ma_event_uninit(&pDevice->null_device.operationCompletionEvent); - ma_event_uninit(&pDevice->null_device.operationEvent); - - return MA_SUCCESS; -} - -static ma_result ma_device_init__null(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->null_device); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* The null backend supports everything exactly as we specify it. */ - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - pDescriptorCapture->format = (pDescriptorCapture->format != ma_format_unknown) ? pDescriptorCapture->format : MA_DEFAULT_FORMAT; - pDescriptorCapture->channels = (pDescriptorCapture->channels != 0) ? pDescriptorCapture->channels : MA_DEFAULT_CHANNELS; - pDescriptorCapture->sampleRate = (pDescriptorCapture->sampleRate != 0) ? pDescriptorCapture->sampleRate : MA_DEFAULT_SAMPLE_RATE; - - if (pDescriptorCapture->channelMap[0] == MA_CHANNEL_NONE) { - ma_channel_map_init_standard(ma_standard_channel_map_default, pDescriptorCapture->channelMap, ma_countof(pDescriptorCapture->channelMap), pDescriptorCapture->channels); - } - - pDescriptorCapture->periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptorCapture, pDescriptorCapture->sampleRate, pConfig->performanceProfile); - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - pDescriptorPlayback->format = (pDescriptorPlayback->format != ma_format_unknown) ? pDescriptorPlayback->format : MA_DEFAULT_FORMAT; - pDescriptorPlayback->channels = (pDescriptorPlayback->channels != 0) ? pDescriptorPlayback->channels : MA_DEFAULT_CHANNELS; - pDescriptorPlayback->sampleRate = (pDescriptorPlayback->sampleRate != 0) ? pDescriptorPlayback->sampleRate : MA_DEFAULT_SAMPLE_RATE; - - if (pDescriptorPlayback->channelMap[0] == MA_CHANNEL_NONE) { - ma_channel_map_init_standard(ma_standard_channel_map_default, pDescriptorPlayback->channelMap, ma_countof(pDescriptorCapture->channelMap), pDescriptorPlayback->channels); - } - - pDescriptorPlayback->periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptorPlayback, pDescriptorPlayback->sampleRate, pConfig->performanceProfile); - } - - /* - In order to get timing right, we need to create a thread that does nothing but keeps track of the timer. This timer is started when the - first period is "written" to it, and then stopped in ma_device_stop__null(). - */ - result = ma_event_init(&pDevice->null_device.operationEvent); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_event_init(&pDevice->null_device.operationCompletionEvent); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_semaphore_init(1, &pDevice->null_device.operationSemaphore); /* <-- It's important that the initial value is set to 1. */ - if (result != MA_SUCCESS) { - return result; - } - - result = ma_thread_create(&pDevice->null_device.deviceThread, pDevice->pContext->threadPriority, 0, ma_device_thread__null, pDevice, &pDevice->pContext->allocationCallbacks); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__null(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - ma_device_do_operation__null(pDevice, MA_DEVICE_OP_START__NULL); - - ma_atomic_bool32_set(&pDevice->null_device.isStarted, MA_TRUE); - return MA_SUCCESS; -} - -static ma_result ma_device_stop__null(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - ma_device_do_operation__null(pDevice, MA_DEVICE_OP_SUSPEND__NULL); - - ma_atomic_bool32_set(&pDevice->null_device.isStarted, MA_FALSE); - return MA_SUCCESS; -} - -static ma_bool32 ma_device_is_started__null(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - return ma_atomic_bool32_get(&pDevice->null_device.isStarted); -} - -static ma_result ma_device_write__null(ma_device* pDevice, const void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - ma_result result = MA_SUCCESS; - ma_uint32 totalPCMFramesProcessed; - ma_bool32 wasStartedOnEntry; - - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - wasStartedOnEntry = ma_device_is_started__null(pDevice); - - /* Keep going until everything has been read. */ - totalPCMFramesProcessed = 0; - while (totalPCMFramesProcessed < frameCount) { - ma_uint64 targetFrame; - - /* If there are any frames remaining in the current period, consume those first. */ - if (pDevice->null_device.currentPeriodFramesRemainingPlayback > 0) { - ma_uint32 framesRemaining = (frameCount - totalPCMFramesProcessed); - ma_uint32 framesToProcess = pDevice->null_device.currentPeriodFramesRemainingPlayback; - if (framesToProcess > framesRemaining) { - framesToProcess = framesRemaining; - } - - /* We don't actually do anything with pPCMFrames, so just mark it as unused to prevent a warning. */ - (void)pPCMFrames; - - pDevice->null_device.currentPeriodFramesRemainingPlayback -= framesToProcess; - totalPCMFramesProcessed += framesToProcess; - } - - /* If we've consumed the current period we'll need to mark it as such an ensure the device is started if it's not already. */ - if (pDevice->null_device.currentPeriodFramesRemainingPlayback == 0) { - pDevice->null_device.currentPeriodFramesRemainingPlayback = 0; - - if (!ma_device_is_started__null(pDevice) && !wasStartedOnEntry) { - result = ma_device_start__null(pDevice); - if (result != MA_SUCCESS) { - break; - } - } - } - - /* If we've consumed the whole buffer we can return now. */ - MA_ASSERT(totalPCMFramesProcessed <= frameCount); - if (totalPCMFramesProcessed == frameCount) { - break; - } - - /* Getting here means we've still got more frames to consume, we but need to wait for it to become available. */ - targetFrame = pDevice->null_device.lastProcessedFramePlayback; - for (;;) { - ma_uint64 currentFrame; - - /* Stop waiting if the device has been stopped. */ - if (!ma_device_is_started__null(pDevice)) { - break; - } - - currentFrame = ma_device_get_total_run_time_in_frames__null(pDevice); - if (currentFrame >= targetFrame) { - break; - } - - /* Getting here means we haven't yet reached the target sample, so continue waiting. */ - ma_sleep(10); - } - - pDevice->null_device.lastProcessedFramePlayback += pDevice->playback.internalPeriodSizeInFrames; - pDevice->null_device.currentPeriodFramesRemainingPlayback = pDevice->playback.internalPeriodSizeInFrames; - } - - if (pFramesWritten != NULL) { - *pFramesWritten = totalPCMFramesProcessed; - } - - return result; -} - -static ma_result ma_device_read__null(ma_device* pDevice, void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint32 totalPCMFramesProcessed; - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - /* Keep going until everything has been read. */ - totalPCMFramesProcessed = 0; - while (totalPCMFramesProcessed < frameCount) { - ma_uint64 targetFrame; - - /* If there are any frames remaining in the current period, consume those first. */ - if (pDevice->null_device.currentPeriodFramesRemainingCapture > 0) { - ma_uint32 bpf = ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - ma_uint32 framesRemaining = (frameCount - totalPCMFramesProcessed); - ma_uint32 framesToProcess = pDevice->null_device.currentPeriodFramesRemainingCapture; - if (framesToProcess > framesRemaining) { - framesToProcess = framesRemaining; - } - - /* We need to ensure the output buffer is zeroed. */ - MA_ZERO_MEMORY(ma_offset_ptr(pPCMFrames, totalPCMFramesProcessed*bpf), framesToProcess*bpf); - - pDevice->null_device.currentPeriodFramesRemainingCapture -= framesToProcess; - totalPCMFramesProcessed += framesToProcess; - } - - /* If we've consumed the current period we'll need to mark it as such an ensure the device is started if it's not already. */ - if (pDevice->null_device.currentPeriodFramesRemainingCapture == 0) { - pDevice->null_device.currentPeriodFramesRemainingCapture = 0; - } - - /* If we've consumed the whole buffer we can return now. */ - MA_ASSERT(totalPCMFramesProcessed <= frameCount); - if (totalPCMFramesProcessed == frameCount) { - break; - } - - /* Getting here means we've still got more frames to consume, we but need to wait for it to become available. */ - targetFrame = pDevice->null_device.lastProcessedFrameCapture + pDevice->capture.internalPeriodSizeInFrames; - for (;;) { - ma_uint64 currentFrame; - - /* Stop waiting if the device has been stopped. */ - if (!ma_device_is_started__null(pDevice)) { - break; - } - - currentFrame = ma_device_get_total_run_time_in_frames__null(pDevice); - if (currentFrame >= targetFrame) { - break; - } - - /* Getting here means we haven't yet reached the target sample, so continue waiting. */ - ma_sleep(10); - } - - pDevice->null_device.lastProcessedFrameCapture += pDevice->capture.internalPeriodSizeInFrames; - pDevice->null_device.currentPeriodFramesRemainingCapture = pDevice->capture.internalPeriodSizeInFrames; - } - - if (pFramesRead != NULL) { - *pFramesRead = totalPCMFramesProcessed; - } - - return result; -} - -static ma_result ma_context_uninit__null(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_null); - - (void)pContext; - return MA_SUCCESS; -} - -static ma_result ma_context_init__null(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - MA_ASSERT(pContext != NULL); - - (void)pConfig; - (void)pContext; - - pCallbacks->onContextInit = ma_context_init__null; - pCallbacks->onContextUninit = ma_context_uninit__null; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__null; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__null; - pCallbacks->onDeviceInit = ma_device_init__null; - pCallbacks->onDeviceUninit = ma_device_uninit__null; - pCallbacks->onDeviceStart = ma_device_start__null; - pCallbacks->onDeviceStop = ma_device_stop__null; - pCallbacks->onDeviceRead = ma_device_read__null; - pCallbacks->onDeviceWrite = ma_device_write__null; - pCallbacks->onDeviceDataLoop = NULL; /* Our backend is asynchronous with a blocking read-write API which means we can get miniaudio to deal with the audio thread. */ - - /* The null backend always works. */ - return MA_SUCCESS; -} -#endif - - - -/******************************************************************************* - -WIN32 COMMON - -*******************************************************************************/ -#if defined(MA_WIN32) -#if defined(MA_WIN32_DESKTOP) - #define ma_CoInitializeEx(pContext, pvReserved, dwCoInit) ((pContext->win32.CoInitializeEx) ? ((MA_PFN_CoInitializeEx)pContext->win32.CoInitializeEx)(pvReserved, dwCoInit) : ((MA_PFN_CoInitialize)pContext->win32.CoInitialize)(pvReserved)) - #define ma_CoUninitialize(pContext) ((MA_PFN_CoUninitialize)pContext->win32.CoUninitialize)() - #define ma_CoCreateInstance(pContext, rclsid, pUnkOuter, dwClsContext, riid, ppv) ((MA_PFN_CoCreateInstance)pContext->win32.CoCreateInstance)(rclsid, pUnkOuter, dwClsContext, riid, ppv) - #define ma_CoTaskMemFree(pContext, pv) ((MA_PFN_CoTaskMemFree)pContext->win32.CoTaskMemFree)(pv) - #define ma_PropVariantClear(pContext, pvar) ((MA_PFN_PropVariantClear)pContext->win32.PropVariantClear)(pvar) -#else - #define ma_CoInitializeEx(pContext, pvReserved, dwCoInit) CoInitializeEx(pvReserved, dwCoInit) - #define ma_CoUninitialize(pContext) CoUninitialize() - #define ma_CoCreateInstance(pContext, rclsid, pUnkOuter, dwClsContext, riid, ppv) CoCreateInstance(rclsid, pUnkOuter, dwClsContext, riid, ppv) - #define ma_CoTaskMemFree(pContext, pv) CoTaskMemFree(pv) - #define ma_PropVariantClear(pContext, pvar) PropVariantClear(pvar) -#endif - -#if !defined(MAXULONG_PTR) && !defined(__WATCOMC__) -typedef size_t DWORD_PTR; -#endif - -#if !defined(WAVE_FORMAT_1M08) -#define WAVE_FORMAT_1M08 0x00000001 -#define WAVE_FORMAT_1S08 0x00000002 -#define WAVE_FORMAT_1M16 0x00000004 -#define WAVE_FORMAT_1S16 0x00000008 -#define WAVE_FORMAT_2M08 0x00000010 -#define WAVE_FORMAT_2S08 0x00000020 -#define WAVE_FORMAT_2M16 0x00000040 -#define WAVE_FORMAT_2S16 0x00000080 -#define WAVE_FORMAT_4M08 0x00000100 -#define WAVE_FORMAT_4S08 0x00000200 -#define WAVE_FORMAT_4M16 0x00000400 -#define WAVE_FORMAT_4S16 0x00000800 -#endif - -#if !defined(WAVE_FORMAT_44M08) -#define WAVE_FORMAT_44M08 0x00000100 -#define WAVE_FORMAT_44S08 0x00000200 -#define WAVE_FORMAT_44M16 0x00000400 -#define WAVE_FORMAT_44S16 0x00000800 -#define WAVE_FORMAT_48M08 0x00001000 -#define WAVE_FORMAT_48S08 0x00002000 -#define WAVE_FORMAT_48M16 0x00004000 -#define WAVE_FORMAT_48S16 0x00008000 -#define WAVE_FORMAT_96M08 0x00010000 -#define WAVE_FORMAT_96S08 0x00020000 -#define WAVE_FORMAT_96M16 0x00040000 -#define WAVE_FORMAT_96S16 0x00080000 -#endif - -#ifndef SPEAKER_FRONT_LEFT -#define SPEAKER_FRONT_LEFT 0x1 -#define SPEAKER_FRONT_RIGHT 0x2 -#define SPEAKER_FRONT_CENTER 0x4 -#define SPEAKER_LOW_FREQUENCY 0x8 -#define SPEAKER_BACK_LEFT 0x10 -#define SPEAKER_BACK_RIGHT 0x20 -#define SPEAKER_FRONT_LEFT_OF_CENTER 0x40 -#define SPEAKER_FRONT_RIGHT_OF_CENTER 0x80 -#define SPEAKER_BACK_CENTER 0x100 -#define SPEAKER_SIDE_LEFT 0x200 -#define SPEAKER_SIDE_RIGHT 0x400 -#define SPEAKER_TOP_CENTER 0x800 -#define SPEAKER_TOP_FRONT_LEFT 0x1000 -#define SPEAKER_TOP_FRONT_CENTER 0x2000 -#define SPEAKER_TOP_FRONT_RIGHT 0x4000 -#define SPEAKER_TOP_BACK_LEFT 0x8000 -#define SPEAKER_TOP_BACK_CENTER 0x10000 -#define SPEAKER_TOP_BACK_RIGHT 0x20000 -#endif - -/* -Implement our own version of MA_WAVEFORMATEXTENSIBLE so we can avoid a header. Be careful with this -because MA_WAVEFORMATEX has an extra two bytes over standard WAVEFORMATEX due to padding. The -standard version uses tight packing, but for compiler compatibility we're not doing that with ours. -*/ -typedef struct -{ - WORD wFormatTag; - WORD nChannels; - DWORD nSamplesPerSec; - DWORD nAvgBytesPerSec; - WORD nBlockAlign; - WORD wBitsPerSample; - WORD cbSize; -} MA_WAVEFORMATEX; - -typedef struct -{ - WORD wFormatTag; - WORD nChannels; - DWORD nSamplesPerSec; - DWORD nAvgBytesPerSec; - WORD nBlockAlign; - WORD wBitsPerSample; - WORD cbSize; - union - { - WORD wValidBitsPerSample; - WORD wSamplesPerBlock; - WORD wReserved; - } Samples; - DWORD dwChannelMask; - GUID SubFormat; -} MA_WAVEFORMATEXTENSIBLE; - - - -#ifndef WAVE_FORMAT_EXTENSIBLE -#define WAVE_FORMAT_EXTENSIBLE 0xFFFE -#endif - -#ifndef WAVE_FORMAT_PCM -#define WAVE_FORMAT_PCM 1 -#endif - -#ifndef WAVE_FORMAT_IEEE_FLOAT -#define WAVE_FORMAT_IEEE_FLOAT 0x0003 -#endif - -/* Converts an individual Win32-style channel identifier (SPEAKER_FRONT_LEFT, etc.) to miniaudio. */ -static ma_uint8 ma_channel_id_to_ma__win32(DWORD id) -{ - switch (id) - { - case SPEAKER_FRONT_LEFT: return MA_CHANNEL_FRONT_LEFT; - case SPEAKER_FRONT_RIGHT: return MA_CHANNEL_FRONT_RIGHT; - case SPEAKER_FRONT_CENTER: return MA_CHANNEL_FRONT_CENTER; - case SPEAKER_LOW_FREQUENCY: return MA_CHANNEL_LFE; - case SPEAKER_BACK_LEFT: return MA_CHANNEL_BACK_LEFT; - case SPEAKER_BACK_RIGHT: return MA_CHANNEL_BACK_RIGHT; - case SPEAKER_FRONT_LEFT_OF_CENTER: return MA_CHANNEL_FRONT_LEFT_CENTER; - case SPEAKER_FRONT_RIGHT_OF_CENTER: return MA_CHANNEL_FRONT_RIGHT_CENTER; - case SPEAKER_BACK_CENTER: return MA_CHANNEL_BACK_CENTER; - case SPEAKER_SIDE_LEFT: return MA_CHANNEL_SIDE_LEFT; - case SPEAKER_SIDE_RIGHT: return MA_CHANNEL_SIDE_RIGHT; - case SPEAKER_TOP_CENTER: return MA_CHANNEL_TOP_CENTER; - case SPEAKER_TOP_FRONT_LEFT: return MA_CHANNEL_TOP_FRONT_LEFT; - case SPEAKER_TOP_FRONT_CENTER: return MA_CHANNEL_TOP_FRONT_CENTER; - case SPEAKER_TOP_FRONT_RIGHT: return MA_CHANNEL_TOP_FRONT_RIGHT; - case SPEAKER_TOP_BACK_LEFT: return MA_CHANNEL_TOP_BACK_LEFT; - case SPEAKER_TOP_BACK_CENTER: return MA_CHANNEL_TOP_BACK_CENTER; - case SPEAKER_TOP_BACK_RIGHT: return MA_CHANNEL_TOP_BACK_RIGHT; - default: return 0; - } -} - -/* Converts an individual miniaudio channel identifier (MA_CHANNEL_FRONT_LEFT, etc.) to Win32-style. */ -static DWORD ma_channel_id_to_win32(DWORD id) -{ - switch (id) - { - case MA_CHANNEL_MONO: return SPEAKER_FRONT_CENTER; - case MA_CHANNEL_FRONT_LEFT: return SPEAKER_FRONT_LEFT; - case MA_CHANNEL_FRONT_RIGHT: return SPEAKER_FRONT_RIGHT; - case MA_CHANNEL_FRONT_CENTER: return SPEAKER_FRONT_CENTER; - case MA_CHANNEL_LFE: return SPEAKER_LOW_FREQUENCY; - case MA_CHANNEL_BACK_LEFT: return SPEAKER_BACK_LEFT; - case MA_CHANNEL_BACK_RIGHT: return SPEAKER_BACK_RIGHT; - case MA_CHANNEL_FRONT_LEFT_CENTER: return SPEAKER_FRONT_LEFT_OF_CENTER; - case MA_CHANNEL_FRONT_RIGHT_CENTER: return SPEAKER_FRONT_RIGHT_OF_CENTER; - case MA_CHANNEL_BACK_CENTER: return SPEAKER_BACK_CENTER; - case MA_CHANNEL_SIDE_LEFT: return SPEAKER_SIDE_LEFT; - case MA_CHANNEL_SIDE_RIGHT: return SPEAKER_SIDE_RIGHT; - case MA_CHANNEL_TOP_CENTER: return SPEAKER_TOP_CENTER; - case MA_CHANNEL_TOP_FRONT_LEFT: return SPEAKER_TOP_FRONT_LEFT; - case MA_CHANNEL_TOP_FRONT_CENTER: return SPEAKER_TOP_FRONT_CENTER; - case MA_CHANNEL_TOP_FRONT_RIGHT: return SPEAKER_TOP_FRONT_RIGHT; - case MA_CHANNEL_TOP_BACK_LEFT: return SPEAKER_TOP_BACK_LEFT; - case MA_CHANNEL_TOP_BACK_CENTER: return SPEAKER_TOP_BACK_CENTER; - case MA_CHANNEL_TOP_BACK_RIGHT: return SPEAKER_TOP_BACK_RIGHT; - default: return 0; - } -} - -/* Converts a channel mapping to a Win32-style channel mask. */ -static DWORD ma_channel_map_to_channel_mask__win32(const ma_channel* pChannelMap, ma_uint32 channels) -{ - DWORD dwChannelMask = 0; - ma_uint32 iChannel; - - for (iChannel = 0; iChannel < channels; ++iChannel) { - dwChannelMask |= ma_channel_id_to_win32(pChannelMap[iChannel]); - } - - return dwChannelMask; -} - -/* Converts a Win32-style channel mask to a miniaudio channel map. */ -static void ma_channel_mask_to_channel_map__win32(DWORD dwChannelMask, ma_uint32 channels, ma_channel* pChannelMap) -{ - /* If the channel mask is set to 0, just assume a default Win32 channel map. */ - if (dwChannelMask == 0) { - ma_channel_map_init_standard(ma_standard_channel_map_microsoft, pChannelMap, channels, channels); - } else { - if (channels == 1 && (dwChannelMask & SPEAKER_FRONT_CENTER) != 0) { - pChannelMap[0] = MA_CHANNEL_MONO; - } else { - /* Just iterate over each bit. */ - ma_uint32 iChannel = 0; - ma_uint32 iBit; - - for (iBit = 0; iBit < 32 && iChannel < channels; ++iBit) { - DWORD bitValue = (dwChannelMask & (1UL << iBit)); - if (bitValue != 0) { - /* The bit is set. */ - pChannelMap[iChannel] = ma_channel_id_to_ma__win32(bitValue); - iChannel += 1; - } - } - } - } -} - -#ifdef __cplusplus -static ma_bool32 ma_is_guid_equal(const void* a, const void* b) -{ - return IsEqualGUID(*(const GUID*)a, *(const GUID*)b); -} -#else -#define ma_is_guid_equal(a, b) IsEqualGUID((const GUID*)a, (const GUID*)b) -#endif - -static MA_INLINE ma_bool32 ma_is_guid_null(const void* guid) -{ - static GUID nullguid = {0x00000000, 0x0000, 0x0000, {0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}}; - return ma_is_guid_equal(guid, &nullguid); -} - -static ma_format ma_format_from_WAVEFORMATEX(const MA_WAVEFORMATEX* pWF) -{ - MA_ASSERT(pWF != NULL); - - if (pWF->wFormatTag == WAVE_FORMAT_EXTENSIBLE) { - const MA_WAVEFORMATEXTENSIBLE* pWFEX = (const MA_WAVEFORMATEXTENSIBLE*)pWF; - if (ma_is_guid_equal(&pWFEX->SubFormat, &MA_GUID_KSDATAFORMAT_SUBTYPE_PCM)) { - if (pWFEX->Samples.wValidBitsPerSample == 32) { - return ma_format_s32; - } - if (pWFEX->Samples.wValidBitsPerSample == 24) { - if (pWFEX->wBitsPerSample == 32) { - return ma_format_s32; - } - if (pWFEX->wBitsPerSample == 24) { - return ma_format_s24; - } - } - if (pWFEX->Samples.wValidBitsPerSample == 16) { - return ma_format_s16; - } - if (pWFEX->Samples.wValidBitsPerSample == 8) { - return ma_format_u8; - } - } - if (ma_is_guid_equal(&pWFEX->SubFormat, &MA_GUID_KSDATAFORMAT_SUBTYPE_IEEE_FLOAT)) { - if (pWFEX->Samples.wValidBitsPerSample == 32) { - return ma_format_f32; - } - /* - if (pWFEX->Samples.wValidBitsPerSample == 64) { - return ma_format_f64; - } - */ - } - } else { - if (pWF->wFormatTag == WAVE_FORMAT_PCM) { - if (pWF->wBitsPerSample == 32) { - return ma_format_s32; - } - if (pWF->wBitsPerSample == 24) { - return ma_format_s24; - } - if (pWF->wBitsPerSample == 16) { - return ma_format_s16; - } - if (pWF->wBitsPerSample == 8) { - return ma_format_u8; - } - } - if (pWF->wFormatTag == WAVE_FORMAT_IEEE_FLOAT) { - if (pWF->wBitsPerSample == 32) { - return ma_format_f32; - } - if (pWF->wBitsPerSample == 64) { - /*return ma_format_f64;*/ - } - } - } - - return ma_format_unknown; -} -#endif - - -/******************************************************************************* - -WASAPI Backend - -*******************************************************************************/ -#ifdef MA_HAS_WASAPI -#if 0 -#if defined(_MSC_VER) - #pragma warning(push) - #pragma warning(disable:4091) /* 'typedef ': ignored on left of '' when no variable is declared */ -#endif -#include -#include -#if defined(_MSC_VER) - #pragma warning(pop) -#endif -#endif /* 0 */ - -static ma_result ma_device_reroute__wasapi(ma_device* pDevice, ma_device_type deviceType); - -/* Some compilers don't define VerifyVersionInfoW. Need to write this ourselves. */ -#define MA_WIN32_WINNT_VISTA 0x0600 -#define MA_VER_MINORVERSION 0x01 -#define MA_VER_MAJORVERSION 0x02 -#define MA_VER_SERVICEPACKMAJOR 0x20 -#define MA_VER_GREATER_EQUAL 0x03 - -typedef struct { - DWORD dwOSVersionInfoSize; - DWORD dwMajorVersion; - DWORD dwMinorVersion; - DWORD dwBuildNumber; - DWORD dwPlatformId; - WCHAR szCSDVersion[128]; - WORD wServicePackMajor; - WORD wServicePackMinor; - WORD wSuiteMask; - BYTE wProductType; - BYTE wReserved; -} ma_OSVERSIONINFOEXW; - -typedef BOOL (WINAPI * ma_PFNVerifyVersionInfoW) (ma_OSVERSIONINFOEXW* lpVersionInfo, DWORD dwTypeMask, DWORDLONG dwlConditionMask); -typedef ULONGLONG (WINAPI * ma_PFNVerSetConditionMask)(ULONGLONG dwlConditionMask, DWORD dwTypeBitMask, BYTE dwConditionMask); - - -#ifndef PROPERTYKEY_DEFINED -#define PROPERTYKEY_DEFINED -#ifndef __WATCOMC__ -typedef struct -{ - GUID fmtid; - DWORD pid; -} PROPERTYKEY; -#endif -#endif - -/* Some compilers don't define PropVariantInit(). We just do this ourselves since it's just a memset(). */ -static MA_INLINE void ma_PropVariantInit(MA_PROPVARIANT* pProp) -{ - MA_ZERO_OBJECT(pProp); -} - - -static const PROPERTYKEY MA_PKEY_Device_FriendlyName = {{0xA45C254E, 0xDF1C, 0x4EFD, {0x80, 0x20, 0x67, 0xD1, 0x46, 0xA8, 0x50, 0xE0}}, 14}; -static const PROPERTYKEY MA_PKEY_AudioEngine_DeviceFormat = {{0xF19F064D, 0x82C, 0x4E27, {0xBC, 0x73, 0x68, 0x82, 0xA1, 0xBB, 0x8E, 0x4C}}, 0}; - -static const IID MA_IID_IUnknown = {0x00000000, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}}; /* 00000000-0000-0000-C000-000000000046 */ -#if !defined(MA_WIN32_DESKTOP) && !defined(MA_WIN32_GDK) -static const IID MA_IID_IAgileObject = {0x94EA2B94, 0xE9CC, 0x49E0, {0xC0, 0xFF, 0xEE, 0x64, 0xCA, 0x8F, 0x5B, 0x90}}; /* 94EA2B94-E9CC-49E0-C0FF-EE64CA8F5B90 */ -#endif - -static const IID MA_IID_IAudioClient = {0x1CB9AD4C, 0xDBFA, 0x4C32, {0xB1, 0x78, 0xC2, 0xF5, 0x68, 0xA7, 0x03, 0xB2}}; /* 1CB9AD4C-DBFA-4C32-B178-C2F568A703B2 = __uuidof(IAudioClient) */ -static const IID MA_IID_IAudioClient2 = {0x726778CD, 0xF60A, 0x4EDA, {0x82, 0xDE, 0xE4, 0x76, 0x10, 0xCD, 0x78, 0xAA}}; /* 726778CD-F60A-4EDA-82DE-E47610CD78AA = __uuidof(IAudioClient2) */ -static const IID MA_IID_IAudioClient3 = {0x7ED4EE07, 0x8E67, 0x4CD4, {0x8C, 0x1A, 0x2B, 0x7A, 0x59, 0x87, 0xAD, 0x42}}; /* 7ED4EE07-8E67-4CD4-8C1A-2B7A5987AD42 = __uuidof(IAudioClient3) */ -static const IID MA_IID_IAudioRenderClient = {0xF294ACFC, 0x3146, 0x4483, {0xA7, 0xBF, 0xAD, 0xDC, 0xA7, 0xC2, 0x60, 0xE2}}; /* F294ACFC-3146-4483-A7BF-ADDCA7C260E2 = __uuidof(IAudioRenderClient) */ -static const IID MA_IID_IAudioCaptureClient = {0xC8ADBD64, 0xE71E, 0x48A0, {0xA4, 0xDE, 0x18, 0x5C, 0x39, 0x5C, 0xD3, 0x17}}; /* C8ADBD64-E71E-48A0-A4DE-185C395CD317 = __uuidof(IAudioCaptureClient) */ -static const IID MA_IID_IMMNotificationClient = {0x7991EEC9, 0x7E89, 0x4D85, {0x83, 0x90, 0x6C, 0x70, 0x3C, 0xEC, 0x60, 0xC0}}; /* 7991EEC9-7E89-4D85-8390-6C703CEC60C0 = __uuidof(IMMNotificationClient) */ -#if !defined(MA_WIN32_DESKTOP) && !defined(MA_WIN32_GDK) -static const IID MA_IID_DEVINTERFACE_AUDIO_RENDER = {0xE6327CAD, 0xDCEC, 0x4949, {0xAE, 0x8A, 0x99, 0x1E, 0x97, 0x6A, 0x79, 0xD2}}; /* E6327CAD-DCEC-4949-AE8A-991E976A79D2 */ -static const IID MA_IID_DEVINTERFACE_AUDIO_CAPTURE = {0x2EEF81BE, 0x33FA, 0x4800, {0x96, 0x70, 0x1C, 0xD4, 0x74, 0x97, 0x2C, 0x3F}}; /* 2EEF81BE-33FA-4800-9670-1CD474972C3F */ -static const IID MA_IID_IActivateAudioInterfaceCompletionHandler = {0x41D949AB, 0x9862, 0x444A, {0x80, 0xF6, 0xC2, 0x61, 0x33, 0x4D, 0xA5, 0xEB}}; /* 41D949AB-9862-444A-80F6-C261334DA5EB */ -#endif - -static const IID MA_CLSID_MMDeviceEnumerator_Instance = {0xBCDE0395, 0xE52F, 0x467C, {0x8E, 0x3D, 0xC4, 0x57, 0x92, 0x91, 0x69, 0x2E}}; /* BCDE0395-E52F-467C-8E3D-C4579291692E = __uuidof(MMDeviceEnumerator) */ -static const IID MA_IID_IMMDeviceEnumerator_Instance = {0xA95664D2, 0x9614, 0x4F35, {0xA7, 0x46, 0xDE, 0x8D, 0xB6, 0x36, 0x17, 0xE6}}; /* A95664D2-9614-4F35-A746-DE8DB63617E6 = __uuidof(IMMDeviceEnumerator) */ -#ifdef __cplusplus -#define MA_CLSID_MMDeviceEnumerator MA_CLSID_MMDeviceEnumerator_Instance -#define MA_IID_IMMDeviceEnumerator MA_IID_IMMDeviceEnumerator_Instance -#else -#define MA_CLSID_MMDeviceEnumerator &MA_CLSID_MMDeviceEnumerator_Instance -#define MA_IID_IMMDeviceEnumerator &MA_IID_IMMDeviceEnumerator_Instance -#endif - -typedef struct ma_IUnknown ma_IUnknown; -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) -#define MA_MM_DEVICE_STATE_ACTIVE 1 -#define MA_MM_DEVICE_STATE_DISABLED 2 -#define MA_MM_DEVICE_STATE_NOTPRESENT 4 -#define MA_MM_DEVICE_STATE_UNPLUGGED 8 - -typedef struct ma_IMMDeviceEnumerator ma_IMMDeviceEnumerator; -typedef struct ma_IMMDeviceCollection ma_IMMDeviceCollection; -typedef struct ma_IMMDevice ma_IMMDevice; -#else -typedef struct ma_IActivateAudioInterfaceCompletionHandler ma_IActivateAudioInterfaceCompletionHandler; -typedef struct ma_IActivateAudioInterfaceAsyncOperation ma_IActivateAudioInterfaceAsyncOperation; -#endif -typedef struct ma_IPropertyStore ma_IPropertyStore; -typedef struct ma_IAudioClient ma_IAudioClient; -typedef struct ma_IAudioClient2 ma_IAudioClient2; -typedef struct ma_IAudioClient3 ma_IAudioClient3; -typedef struct ma_IAudioRenderClient ma_IAudioRenderClient; -typedef struct ma_IAudioCaptureClient ma_IAudioCaptureClient; - -typedef ma_int64 MA_REFERENCE_TIME; - -#define MA_AUDCLNT_STREAMFLAGS_CROSSPROCESS 0x00010000 -#define MA_AUDCLNT_STREAMFLAGS_LOOPBACK 0x00020000 -#define MA_AUDCLNT_STREAMFLAGS_EVENTCALLBACK 0x00040000 -#define MA_AUDCLNT_STREAMFLAGS_NOPERSIST 0x00080000 -#define MA_AUDCLNT_STREAMFLAGS_RATEADJUST 0x00100000 -#define MA_AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY 0x08000000 -#define MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM 0x80000000 -#define MA_AUDCLNT_SESSIONFLAGS_EXPIREWHENUNOWNED 0x10000000 -#define MA_AUDCLNT_SESSIONFLAGS_DISPLAY_HIDE 0x20000000 -#define MA_AUDCLNT_SESSIONFLAGS_DISPLAY_HIDEWHENEXPIRED 0x40000000 - -/* Buffer flags. */ -#define MA_AUDCLNT_BUFFERFLAGS_DATA_DISCONTINUITY 1 -#define MA_AUDCLNT_BUFFERFLAGS_SILENT 2 -#define MA_AUDCLNT_BUFFERFLAGS_TIMESTAMP_ERROR 4 - -typedef enum -{ - ma_eRender = 0, - ma_eCapture = 1, - ma_eAll = 2 -} ma_EDataFlow; - -typedef enum -{ - ma_eConsole = 0, - ma_eMultimedia = 1, - ma_eCommunications = 2 -} ma_ERole; - -typedef enum -{ - MA_AUDCLNT_SHAREMODE_SHARED, - MA_AUDCLNT_SHAREMODE_EXCLUSIVE -} MA_AUDCLNT_SHAREMODE; - -typedef enum -{ - MA_AudioCategory_Other = 0 /* <-- miniaudio is only caring about Other. */ -} MA_AUDIO_STREAM_CATEGORY; - -typedef struct -{ - ma_uint32 cbSize; - BOOL bIsOffload; - MA_AUDIO_STREAM_CATEGORY eCategory; -} ma_AudioClientProperties; - -/* IUnknown */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IUnknown* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IUnknown* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IUnknown* pThis); -} ma_IUnknownVtbl; -struct ma_IUnknown -{ - ma_IUnknownVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IUnknown_QueryInterface(ma_IUnknown* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IUnknown_AddRef(ma_IUnknown* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IUnknown_Release(ma_IUnknown* pThis) { return pThis->lpVtbl->Release(pThis); } - -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - /* IMMNotificationClient */ - typedef struct - { - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IMMNotificationClient* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IMMNotificationClient* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IMMNotificationClient* pThis); - - /* IMMNotificationClient */ - HRESULT (STDMETHODCALLTYPE * OnDeviceStateChanged) (ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID, DWORD dwNewState); - HRESULT (STDMETHODCALLTYPE * OnDeviceAdded) (ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID); - HRESULT (STDMETHODCALLTYPE * OnDeviceRemoved) (ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID); - HRESULT (STDMETHODCALLTYPE * OnDefaultDeviceChanged)(ma_IMMNotificationClient* pThis, ma_EDataFlow dataFlow, ma_ERole role, const WCHAR* pDefaultDeviceID); - HRESULT (STDMETHODCALLTYPE * OnPropertyValueChanged)(ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID, const PROPERTYKEY key); - } ma_IMMNotificationClientVtbl; - - /* IMMDeviceEnumerator */ - typedef struct - { - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IMMDeviceEnumerator* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IMMDeviceEnumerator* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IMMDeviceEnumerator* pThis); - - /* IMMDeviceEnumerator */ - HRESULT (STDMETHODCALLTYPE * EnumAudioEndpoints) (ma_IMMDeviceEnumerator* pThis, ma_EDataFlow dataFlow, DWORD dwStateMask, ma_IMMDeviceCollection** ppDevices); - HRESULT (STDMETHODCALLTYPE * GetDefaultAudioEndpoint) (ma_IMMDeviceEnumerator* pThis, ma_EDataFlow dataFlow, ma_ERole role, ma_IMMDevice** ppEndpoint); - HRESULT (STDMETHODCALLTYPE * GetDevice) (ma_IMMDeviceEnumerator* pThis, const WCHAR* pID, ma_IMMDevice** ppDevice); - HRESULT (STDMETHODCALLTYPE * RegisterEndpointNotificationCallback) (ma_IMMDeviceEnumerator* pThis, ma_IMMNotificationClient* pClient); - HRESULT (STDMETHODCALLTYPE * UnregisterEndpointNotificationCallback)(ma_IMMDeviceEnumerator* pThis, ma_IMMNotificationClient* pClient); - } ma_IMMDeviceEnumeratorVtbl; - struct ma_IMMDeviceEnumerator - { - ma_IMMDeviceEnumeratorVtbl* lpVtbl; - }; - static MA_INLINE HRESULT ma_IMMDeviceEnumerator_QueryInterface(ma_IMMDeviceEnumerator* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } - static MA_INLINE ULONG ma_IMMDeviceEnumerator_AddRef(ma_IMMDeviceEnumerator* pThis) { return pThis->lpVtbl->AddRef(pThis); } - static MA_INLINE ULONG ma_IMMDeviceEnumerator_Release(ma_IMMDeviceEnumerator* pThis) { return pThis->lpVtbl->Release(pThis); } - static MA_INLINE HRESULT ma_IMMDeviceEnumerator_EnumAudioEndpoints(ma_IMMDeviceEnumerator* pThis, ma_EDataFlow dataFlow, DWORD dwStateMask, ma_IMMDeviceCollection** ppDevices) { return pThis->lpVtbl->EnumAudioEndpoints(pThis, dataFlow, dwStateMask, ppDevices); } - static MA_INLINE HRESULT ma_IMMDeviceEnumerator_GetDefaultAudioEndpoint(ma_IMMDeviceEnumerator* pThis, ma_EDataFlow dataFlow, ma_ERole role, ma_IMMDevice** ppEndpoint) { return pThis->lpVtbl->GetDefaultAudioEndpoint(pThis, dataFlow, role, ppEndpoint); } - static MA_INLINE HRESULT ma_IMMDeviceEnumerator_GetDevice(ma_IMMDeviceEnumerator* pThis, const WCHAR* pID, ma_IMMDevice** ppDevice) { return pThis->lpVtbl->GetDevice(pThis, pID, ppDevice); } - static MA_INLINE HRESULT ma_IMMDeviceEnumerator_RegisterEndpointNotificationCallback(ma_IMMDeviceEnumerator* pThis, ma_IMMNotificationClient* pClient) { return pThis->lpVtbl->RegisterEndpointNotificationCallback(pThis, pClient); } - static MA_INLINE HRESULT ma_IMMDeviceEnumerator_UnregisterEndpointNotificationCallback(ma_IMMDeviceEnumerator* pThis, ma_IMMNotificationClient* pClient) { return pThis->lpVtbl->UnregisterEndpointNotificationCallback(pThis, pClient); } - - - /* IMMDeviceCollection */ - typedef struct - { - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IMMDeviceCollection* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IMMDeviceCollection* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IMMDeviceCollection* pThis); - - /* IMMDeviceCollection */ - HRESULT (STDMETHODCALLTYPE * GetCount)(ma_IMMDeviceCollection* pThis, UINT* pDevices); - HRESULT (STDMETHODCALLTYPE * Item) (ma_IMMDeviceCollection* pThis, UINT nDevice, ma_IMMDevice** ppDevice); - } ma_IMMDeviceCollectionVtbl; - struct ma_IMMDeviceCollection - { - ma_IMMDeviceCollectionVtbl* lpVtbl; - }; - static MA_INLINE HRESULT ma_IMMDeviceCollection_QueryInterface(ma_IMMDeviceCollection* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } - static MA_INLINE ULONG ma_IMMDeviceCollection_AddRef(ma_IMMDeviceCollection* pThis) { return pThis->lpVtbl->AddRef(pThis); } - static MA_INLINE ULONG ma_IMMDeviceCollection_Release(ma_IMMDeviceCollection* pThis) { return pThis->lpVtbl->Release(pThis); } - static MA_INLINE HRESULT ma_IMMDeviceCollection_GetCount(ma_IMMDeviceCollection* pThis, UINT* pDevices) { return pThis->lpVtbl->GetCount(pThis, pDevices); } - static MA_INLINE HRESULT ma_IMMDeviceCollection_Item(ma_IMMDeviceCollection* pThis, UINT nDevice, ma_IMMDevice** ppDevice) { return pThis->lpVtbl->Item(pThis, nDevice, ppDevice); } - - - /* IMMDevice */ - typedef struct - { - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IMMDevice* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IMMDevice* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IMMDevice* pThis); - - /* IMMDevice */ - HRESULT (STDMETHODCALLTYPE * Activate) (ma_IMMDevice* pThis, const IID* const iid, DWORD dwClsCtx, MA_PROPVARIANT* pActivationParams, void** ppInterface); - HRESULT (STDMETHODCALLTYPE * OpenPropertyStore)(ma_IMMDevice* pThis, DWORD stgmAccess, ma_IPropertyStore** ppProperties); - HRESULT (STDMETHODCALLTYPE * GetId) (ma_IMMDevice* pThis, WCHAR** pID); - HRESULT (STDMETHODCALLTYPE * GetState) (ma_IMMDevice* pThis, DWORD *pState); - } ma_IMMDeviceVtbl; - struct ma_IMMDevice - { - ma_IMMDeviceVtbl* lpVtbl; - }; - static MA_INLINE HRESULT ma_IMMDevice_QueryInterface(ma_IMMDevice* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } - static MA_INLINE ULONG ma_IMMDevice_AddRef(ma_IMMDevice* pThis) { return pThis->lpVtbl->AddRef(pThis); } - static MA_INLINE ULONG ma_IMMDevice_Release(ma_IMMDevice* pThis) { return pThis->lpVtbl->Release(pThis); } - static MA_INLINE HRESULT ma_IMMDevice_Activate(ma_IMMDevice* pThis, const IID* const iid, DWORD dwClsCtx, MA_PROPVARIANT* pActivationParams, void** ppInterface) { return pThis->lpVtbl->Activate(pThis, iid, dwClsCtx, pActivationParams, ppInterface); } - static MA_INLINE HRESULT ma_IMMDevice_OpenPropertyStore(ma_IMMDevice* pThis, DWORD stgmAccess, ma_IPropertyStore** ppProperties) { return pThis->lpVtbl->OpenPropertyStore(pThis, stgmAccess, ppProperties); } - static MA_INLINE HRESULT ma_IMMDevice_GetId(ma_IMMDevice* pThis, WCHAR** pID) { return pThis->lpVtbl->GetId(pThis, pID); } - static MA_INLINE HRESULT ma_IMMDevice_GetState(ma_IMMDevice* pThis, DWORD *pState) { return pThis->lpVtbl->GetState(pThis, pState); } -#else - /* IActivateAudioInterfaceAsyncOperation */ - typedef struct - { - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IActivateAudioInterfaceAsyncOperation* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IActivateAudioInterfaceAsyncOperation* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IActivateAudioInterfaceAsyncOperation* pThis); - - /* IActivateAudioInterfaceAsyncOperation */ - HRESULT (STDMETHODCALLTYPE * GetActivateResult)(ma_IActivateAudioInterfaceAsyncOperation* pThis, HRESULT *pActivateResult, ma_IUnknown** ppActivatedInterface); - } ma_IActivateAudioInterfaceAsyncOperationVtbl; - struct ma_IActivateAudioInterfaceAsyncOperation - { - ma_IActivateAudioInterfaceAsyncOperationVtbl* lpVtbl; - }; - static MA_INLINE HRESULT ma_IActivateAudioInterfaceAsyncOperation_QueryInterface(ma_IActivateAudioInterfaceAsyncOperation* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } - static MA_INLINE ULONG ma_IActivateAudioInterfaceAsyncOperation_AddRef(ma_IActivateAudioInterfaceAsyncOperation* pThis) { return pThis->lpVtbl->AddRef(pThis); } - static MA_INLINE ULONG ma_IActivateAudioInterfaceAsyncOperation_Release(ma_IActivateAudioInterfaceAsyncOperation* pThis) { return pThis->lpVtbl->Release(pThis); } - static MA_INLINE HRESULT ma_IActivateAudioInterfaceAsyncOperation_GetActivateResult(ma_IActivateAudioInterfaceAsyncOperation* pThis, HRESULT *pActivateResult, ma_IUnknown** ppActivatedInterface) { return pThis->lpVtbl->GetActivateResult(pThis, pActivateResult, ppActivatedInterface); } -#endif - -/* IPropertyStore */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IPropertyStore* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IPropertyStore* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IPropertyStore* pThis); - - /* IPropertyStore */ - HRESULT (STDMETHODCALLTYPE * GetCount)(ma_IPropertyStore* pThis, DWORD* pPropCount); - HRESULT (STDMETHODCALLTYPE * GetAt) (ma_IPropertyStore* pThis, DWORD propIndex, PROPERTYKEY* pPropKey); - HRESULT (STDMETHODCALLTYPE * GetValue)(ma_IPropertyStore* pThis, const PROPERTYKEY* const pKey, MA_PROPVARIANT* pPropVar); - HRESULT (STDMETHODCALLTYPE * SetValue)(ma_IPropertyStore* pThis, const PROPERTYKEY* const pKey, const MA_PROPVARIANT* const pPropVar); - HRESULT (STDMETHODCALLTYPE * Commit) (ma_IPropertyStore* pThis); -} ma_IPropertyStoreVtbl; -struct ma_IPropertyStore -{ - ma_IPropertyStoreVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IPropertyStore_QueryInterface(ma_IPropertyStore* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IPropertyStore_AddRef(ma_IPropertyStore* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IPropertyStore_Release(ma_IPropertyStore* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IPropertyStore_GetCount(ma_IPropertyStore* pThis, DWORD* pPropCount) { return pThis->lpVtbl->GetCount(pThis, pPropCount); } -static MA_INLINE HRESULT ma_IPropertyStore_GetAt(ma_IPropertyStore* pThis, DWORD propIndex, PROPERTYKEY* pPropKey) { return pThis->lpVtbl->GetAt(pThis, propIndex, pPropKey); } -static MA_INLINE HRESULT ma_IPropertyStore_GetValue(ma_IPropertyStore* pThis, const PROPERTYKEY* const pKey, MA_PROPVARIANT* pPropVar) { return pThis->lpVtbl->GetValue(pThis, pKey, pPropVar); } -static MA_INLINE HRESULT ma_IPropertyStore_SetValue(ma_IPropertyStore* pThis, const PROPERTYKEY* const pKey, const MA_PROPVARIANT* const pPropVar) { return pThis->lpVtbl->SetValue(pThis, pKey, pPropVar); } -static MA_INLINE HRESULT ma_IPropertyStore_Commit(ma_IPropertyStore* pThis) { return pThis->lpVtbl->Commit(pThis); } - - -/* IAudioClient */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IAudioClient* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IAudioClient* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IAudioClient* pThis); - - /* IAudioClient */ - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IAudioClient* pThis, MA_AUDCLNT_SHAREMODE shareMode, DWORD streamFlags, MA_REFERENCE_TIME bufferDuration, MA_REFERENCE_TIME periodicity, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid); - HRESULT (STDMETHODCALLTYPE * GetBufferSize) (ma_IAudioClient* pThis, ma_uint32* pNumBufferFrames); - HRESULT (STDMETHODCALLTYPE * GetStreamLatency) (ma_IAudioClient* pThis, MA_REFERENCE_TIME* pLatency); - HRESULT (STDMETHODCALLTYPE * GetCurrentPadding)(ma_IAudioClient* pThis, ma_uint32* pNumPaddingFrames); - HRESULT (STDMETHODCALLTYPE * IsFormatSupported)(ma_IAudioClient* pThis, MA_AUDCLNT_SHAREMODE shareMode, const MA_WAVEFORMATEX* pFormat, MA_WAVEFORMATEX** ppClosestMatch); - HRESULT (STDMETHODCALLTYPE * GetMixFormat) (ma_IAudioClient* pThis, MA_WAVEFORMATEX** ppDeviceFormat); - HRESULT (STDMETHODCALLTYPE * GetDevicePeriod) (ma_IAudioClient* pThis, MA_REFERENCE_TIME* pDefaultDevicePeriod, MA_REFERENCE_TIME* pMinimumDevicePeriod); - HRESULT (STDMETHODCALLTYPE * Start) (ma_IAudioClient* pThis); - HRESULT (STDMETHODCALLTYPE * Stop) (ma_IAudioClient* pThis); - HRESULT (STDMETHODCALLTYPE * Reset) (ma_IAudioClient* pThis); - HRESULT (STDMETHODCALLTYPE * SetEventHandle) (ma_IAudioClient* pThis, HANDLE eventHandle); - HRESULT (STDMETHODCALLTYPE * GetService) (ma_IAudioClient* pThis, const IID* const riid, void** pp); -} ma_IAudioClientVtbl; -struct ma_IAudioClient -{ - ma_IAudioClientVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IAudioClient_QueryInterface(ma_IAudioClient* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IAudioClient_AddRef(ma_IAudioClient* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IAudioClient_Release(ma_IAudioClient* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IAudioClient_Initialize(ma_IAudioClient* pThis, MA_AUDCLNT_SHAREMODE shareMode, DWORD streamFlags, MA_REFERENCE_TIME bufferDuration, MA_REFERENCE_TIME periodicity, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid) { return pThis->lpVtbl->Initialize(pThis, shareMode, streamFlags, bufferDuration, periodicity, pFormat, pAudioSessionGuid); } -static MA_INLINE HRESULT ma_IAudioClient_GetBufferSize(ma_IAudioClient* pThis, ma_uint32* pNumBufferFrames) { return pThis->lpVtbl->GetBufferSize(pThis, pNumBufferFrames); } -static MA_INLINE HRESULT ma_IAudioClient_GetStreamLatency(ma_IAudioClient* pThis, MA_REFERENCE_TIME* pLatency) { return pThis->lpVtbl->GetStreamLatency(pThis, pLatency); } -static MA_INLINE HRESULT ma_IAudioClient_GetCurrentPadding(ma_IAudioClient* pThis, ma_uint32* pNumPaddingFrames) { return pThis->lpVtbl->GetCurrentPadding(pThis, pNumPaddingFrames); } -static MA_INLINE HRESULT ma_IAudioClient_IsFormatSupported(ma_IAudioClient* pThis, MA_AUDCLNT_SHAREMODE shareMode, const MA_WAVEFORMATEX* pFormat, MA_WAVEFORMATEX** ppClosestMatch) { return pThis->lpVtbl->IsFormatSupported(pThis, shareMode, pFormat, ppClosestMatch); } -static MA_INLINE HRESULT ma_IAudioClient_GetMixFormat(ma_IAudioClient* pThis, MA_WAVEFORMATEX** ppDeviceFormat) { return pThis->lpVtbl->GetMixFormat(pThis, ppDeviceFormat); } -static MA_INLINE HRESULT ma_IAudioClient_GetDevicePeriod(ma_IAudioClient* pThis, MA_REFERENCE_TIME* pDefaultDevicePeriod, MA_REFERENCE_TIME* pMinimumDevicePeriod) { return pThis->lpVtbl->GetDevicePeriod(pThis, pDefaultDevicePeriod, pMinimumDevicePeriod); } -static MA_INLINE HRESULT ma_IAudioClient_Start(ma_IAudioClient* pThis) { return pThis->lpVtbl->Start(pThis); } -static MA_INLINE HRESULT ma_IAudioClient_Stop(ma_IAudioClient* pThis) { return pThis->lpVtbl->Stop(pThis); } -static MA_INLINE HRESULT ma_IAudioClient_Reset(ma_IAudioClient* pThis) { return pThis->lpVtbl->Reset(pThis); } -static MA_INLINE HRESULT ma_IAudioClient_SetEventHandle(ma_IAudioClient* pThis, HANDLE eventHandle) { return pThis->lpVtbl->SetEventHandle(pThis, eventHandle); } -static MA_INLINE HRESULT ma_IAudioClient_GetService(ma_IAudioClient* pThis, const IID* const riid, void** pp) { return pThis->lpVtbl->GetService(pThis, riid, pp); } - -/* IAudioClient2 */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IAudioClient2* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IAudioClient2* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IAudioClient2* pThis); - - /* IAudioClient */ - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IAudioClient2* pThis, MA_AUDCLNT_SHAREMODE shareMode, DWORD streamFlags, MA_REFERENCE_TIME bufferDuration, MA_REFERENCE_TIME periodicity, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid); - HRESULT (STDMETHODCALLTYPE * GetBufferSize) (ma_IAudioClient2* pThis, ma_uint32* pNumBufferFrames); - HRESULT (STDMETHODCALLTYPE * GetStreamLatency) (ma_IAudioClient2* pThis, MA_REFERENCE_TIME* pLatency); - HRESULT (STDMETHODCALLTYPE * GetCurrentPadding)(ma_IAudioClient2* pThis, ma_uint32* pNumPaddingFrames); - HRESULT (STDMETHODCALLTYPE * IsFormatSupported)(ma_IAudioClient2* pThis, MA_AUDCLNT_SHAREMODE shareMode, const MA_WAVEFORMATEX* pFormat, MA_WAVEFORMATEX** ppClosestMatch); - HRESULT (STDMETHODCALLTYPE * GetMixFormat) (ma_IAudioClient2* pThis, MA_WAVEFORMATEX** ppDeviceFormat); - HRESULT (STDMETHODCALLTYPE * GetDevicePeriod) (ma_IAudioClient2* pThis, MA_REFERENCE_TIME* pDefaultDevicePeriod, MA_REFERENCE_TIME* pMinimumDevicePeriod); - HRESULT (STDMETHODCALLTYPE * Start) (ma_IAudioClient2* pThis); - HRESULT (STDMETHODCALLTYPE * Stop) (ma_IAudioClient2* pThis); - HRESULT (STDMETHODCALLTYPE * Reset) (ma_IAudioClient2* pThis); - HRESULT (STDMETHODCALLTYPE * SetEventHandle) (ma_IAudioClient2* pThis, HANDLE eventHandle); - HRESULT (STDMETHODCALLTYPE * GetService) (ma_IAudioClient2* pThis, const IID* const riid, void** pp); - - /* IAudioClient2 */ - HRESULT (STDMETHODCALLTYPE * IsOffloadCapable) (ma_IAudioClient2* pThis, MA_AUDIO_STREAM_CATEGORY category, BOOL* pOffloadCapable); - HRESULT (STDMETHODCALLTYPE * SetClientProperties)(ma_IAudioClient2* pThis, const ma_AudioClientProperties* pProperties); - HRESULT (STDMETHODCALLTYPE * GetBufferSizeLimits)(ma_IAudioClient2* pThis, const MA_WAVEFORMATEX* pFormat, BOOL eventDriven, MA_REFERENCE_TIME* pMinBufferDuration, MA_REFERENCE_TIME* pMaxBufferDuration); -} ma_IAudioClient2Vtbl; -struct ma_IAudioClient2 -{ - ma_IAudioClient2Vtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IAudioClient2_QueryInterface(ma_IAudioClient2* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IAudioClient2_AddRef(ma_IAudioClient2* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IAudioClient2_Release(ma_IAudioClient2* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IAudioClient2_Initialize(ma_IAudioClient2* pThis, MA_AUDCLNT_SHAREMODE shareMode, DWORD streamFlags, MA_REFERENCE_TIME bufferDuration, MA_REFERENCE_TIME periodicity, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid) { return pThis->lpVtbl->Initialize(pThis, shareMode, streamFlags, bufferDuration, periodicity, pFormat, pAudioSessionGuid); } -static MA_INLINE HRESULT ma_IAudioClient2_GetBufferSize(ma_IAudioClient2* pThis, ma_uint32* pNumBufferFrames) { return pThis->lpVtbl->GetBufferSize(pThis, pNumBufferFrames); } -static MA_INLINE HRESULT ma_IAudioClient2_GetStreamLatency(ma_IAudioClient2* pThis, MA_REFERENCE_TIME* pLatency) { return pThis->lpVtbl->GetStreamLatency(pThis, pLatency); } -static MA_INLINE HRESULT ma_IAudioClient2_GetCurrentPadding(ma_IAudioClient2* pThis, ma_uint32* pNumPaddingFrames) { return pThis->lpVtbl->GetCurrentPadding(pThis, pNumPaddingFrames); } -static MA_INLINE HRESULT ma_IAudioClient2_IsFormatSupported(ma_IAudioClient2* pThis, MA_AUDCLNT_SHAREMODE shareMode, const MA_WAVEFORMATEX* pFormat, MA_WAVEFORMATEX** ppClosestMatch) { return pThis->lpVtbl->IsFormatSupported(pThis, shareMode, pFormat, ppClosestMatch); } -static MA_INLINE HRESULT ma_IAudioClient2_GetMixFormat(ma_IAudioClient2* pThis, MA_WAVEFORMATEX** ppDeviceFormat) { return pThis->lpVtbl->GetMixFormat(pThis, ppDeviceFormat); } -static MA_INLINE HRESULT ma_IAudioClient2_GetDevicePeriod(ma_IAudioClient2* pThis, MA_REFERENCE_TIME* pDefaultDevicePeriod, MA_REFERENCE_TIME* pMinimumDevicePeriod) { return pThis->lpVtbl->GetDevicePeriod(pThis, pDefaultDevicePeriod, pMinimumDevicePeriod); } -static MA_INLINE HRESULT ma_IAudioClient2_Start(ma_IAudioClient2* pThis) { return pThis->lpVtbl->Start(pThis); } -static MA_INLINE HRESULT ma_IAudioClient2_Stop(ma_IAudioClient2* pThis) { return pThis->lpVtbl->Stop(pThis); } -static MA_INLINE HRESULT ma_IAudioClient2_Reset(ma_IAudioClient2* pThis) { return pThis->lpVtbl->Reset(pThis); } -static MA_INLINE HRESULT ma_IAudioClient2_SetEventHandle(ma_IAudioClient2* pThis, HANDLE eventHandle) { return pThis->lpVtbl->SetEventHandle(pThis, eventHandle); } -static MA_INLINE HRESULT ma_IAudioClient2_GetService(ma_IAudioClient2* pThis, const IID* const riid, void** pp) { return pThis->lpVtbl->GetService(pThis, riid, pp); } -static MA_INLINE HRESULT ma_IAudioClient2_IsOffloadCapable(ma_IAudioClient2* pThis, MA_AUDIO_STREAM_CATEGORY category, BOOL* pOffloadCapable) { return pThis->lpVtbl->IsOffloadCapable(pThis, category, pOffloadCapable); } -static MA_INLINE HRESULT ma_IAudioClient2_SetClientProperties(ma_IAudioClient2* pThis, const ma_AudioClientProperties* pProperties) { return pThis->lpVtbl->SetClientProperties(pThis, pProperties); } -static MA_INLINE HRESULT ma_IAudioClient2_GetBufferSizeLimits(ma_IAudioClient2* pThis, const MA_WAVEFORMATEX* pFormat, BOOL eventDriven, MA_REFERENCE_TIME* pMinBufferDuration, MA_REFERENCE_TIME* pMaxBufferDuration) { return pThis->lpVtbl->GetBufferSizeLimits(pThis, pFormat, eventDriven, pMinBufferDuration, pMaxBufferDuration); } - - -/* IAudioClient3 */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IAudioClient3* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IAudioClient3* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IAudioClient3* pThis); - - /* IAudioClient */ - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IAudioClient3* pThis, MA_AUDCLNT_SHAREMODE shareMode, DWORD streamFlags, MA_REFERENCE_TIME bufferDuration, MA_REFERENCE_TIME periodicity, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid); - HRESULT (STDMETHODCALLTYPE * GetBufferSize) (ma_IAudioClient3* pThis, ma_uint32* pNumBufferFrames); - HRESULT (STDMETHODCALLTYPE * GetStreamLatency) (ma_IAudioClient3* pThis, MA_REFERENCE_TIME* pLatency); - HRESULT (STDMETHODCALLTYPE * GetCurrentPadding)(ma_IAudioClient3* pThis, ma_uint32* pNumPaddingFrames); - HRESULT (STDMETHODCALLTYPE * IsFormatSupported)(ma_IAudioClient3* pThis, MA_AUDCLNT_SHAREMODE shareMode, const MA_WAVEFORMATEX* pFormat, MA_WAVEFORMATEX** ppClosestMatch); - HRESULT (STDMETHODCALLTYPE * GetMixFormat) (ma_IAudioClient3* pThis, MA_WAVEFORMATEX** ppDeviceFormat); - HRESULT (STDMETHODCALLTYPE * GetDevicePeriod) (ma_IAudioClient3* pThis, MA_REFERENCE_TIME* pDefaultDevicePeriod, MA_REFERENCE_TIME* pMinimumDevicePeriod); - HRESULT (STDMETHODCALLTYPE * Start) (ma_IAudioClient3* pThis); - HRESULT (STDMETHODCALLTYPE * Stop) (ma_IAudioClient3* pThis); - HRESULT (STDMETHODCALLTYPE * Reset) (ma_IAudioClient3* pThis); - HRESULT (STDMETHODCALLTYPE * SetEventHandle) (ma_IAudioClient3* pThis, HANDLE eventHandle); - HRESULT (STDMETHODCALLTYPE * GetService) (ma_IAudioClient3* pThis, const IID* const riid, void** pp); - - /* IAudioClient2 */ - HRESULT (STDMETHODCALLTYPE * IsOffloadCapable) (ma_IAudioClient3* pThis, MA_AUDIO_STREAM_CATEGORY category, BOOL* pOffloadCapable); - HRESULT (STDMETHODCALLTYPE * SetClientProperties)(ma_IAudioClient3* pThis, const ma_AudioClientProperties* pProperties); - HRESULT (STDMETHODCALLTYPE * GetBufferSizeLimits)(ma_IAudioClient3* pThis, const MA_WAVEFORMATEX* pFormat, BOOL eventDriven, MA_REFERENCE_TIME* pMinBufferDuration, MA_REFERENCE_TIME* pMaxBufferDuration); - - /* IAudioClient3 */ - HRESULT (STDMETHODCALLTYPE * GetSharedModeEnginePeriod) (ma_IAudioClient3* pThis, const MA_WAVEFORMATEX* pFormat, ma_uint32* pDefaultPeriodInFrames, ma_uint32* pFundamentalPeriodInFrames, ma_uint32* pMinPeriodInFrames, ma_uint32* pMaxPeriodInFrames); - HRESULT (STDMETHODCALLTYPE * GetCurrentSharedModeEnginePeriod)(ma_IAudioClient3* pThis, MA_WAVEFORMATEX** ppFormat, ma_uint32* pCurrentPeriodInFrames); - HRESULT (STDMETHODCALLTYPE * InitializeSharedAudioStream) (ma_IAudioClient3* pThis, DWORD streamFlags, ma_uint32 periodInFrames, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid); -} ma_IAudioClient3Vtbl; -struct ma_IAudioClient3 -{ - ma_IAudioClient3Vtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IAudioClient3_QueryInterface(ma_IAudioClient3* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IAudioClient3_AddRef(ma_IAudioClient3* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IAudioClient3_Release(ma_IAudioClient3* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IAudioClient3_Initialize(ma_IAudioClient3* pThis, MA_AUDCLNT_SHAREMODE shareMode, DWORD streamFlags, MA_REFERENCE_TIME bufferDuration, MA_REFERENCE_TIME periodicity, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGuid) { return pThis->lpVtbl->Initialize(pThis, shareMode, streamFlags, bufferDuration, periodicity, pFormat, pAudioSessionGuid); } -static MA_INLINE HRESULT ma_IAudioClient3_GetBufferSize(ma_IAudioClient3* pThis, ma_uint32* pNumBufferFrames) { return pThis->lpVtbl->GetBufferSize(pThis, pNumBufferFrames); } -static MA_INLINE HRESULT ma_IAudioClient3_GetStreamLatency(ma_IAudioClient3* pThis, MA_REFERENCE_TIME* pLatency) { return pThis->lpVtbl->GetStreamLatency(pThis, pLatency); } -static MA_INLINE HRESULT ma_IAudioClient3_GetCurrentPadding(ma_IAudioClient3* pThis, ma_uint32* pNumPaddingFrames) { return pThis->lpVtbl->GetCurrentPadding(pThis, pNumPaddingFrames); } -static MA_INLINE HRESULT ma_IAudioClient3_IsFormatSupported(ma_IAudioClient3* pThis, MA_AUDCLNT_SHAREMODE shareMode, const MA_WAVEFORMATEX* pFormat, MA_WAVEFORMATEX** ppClosestMatch) { return pThis->lpVtbl->IsFormatSupported(pThis, shareMode, pFormat, ppClosestMatch); } -static MA_INLINE HRESULT ma_IAudioClient3_GetMixFormat(ma_IAudioClient3* pThis, MA_WAVEFORMATEX** ppDeviceFormat) { return pThis->lpVtbl->GetMixFormat(pThis, ppDeviceFormat); } -static MA_INLINE HRESULT ma_IAudioClient3_GetDevicePeriod(ma_IAudioClient3* pThis, MA_REFERENCE_TIME* pDefaultDevicePeriod, MA_REFERENCE_TIME* pMinimumDevicePeriod) { return pThis->lpVtbl->GetDevicePeriod(pThis, pDefaultDevicePeriod, pMinimumDevicePeriod); } -static MA_INLINE HRESULT ma_IAudioClient3_Start(ma_IAudioClient3* pThis) { return pThis->lpVtbl->Start(pThis); } -static MA_INLINE HRESULT ma_IAudioClient3_Stop(ma_IAudioClient3* pThis) { return pThis->lpVtbl->Stop(pThis); } -static MA_INLINE HRESULT ma_IAudioClient3_Reset(ma_IAudioClient3* pThis) { return pThis->lpVtbl->Reset(pThis); } -static MA_INLINE HRESULT ma_IAudioClient3_SetEventHandle(ma_IAudioClient3* pThis, HANDLE eventHandle) { return pThis->lpVtbl->SetEventHandle(pThis, eventHandle); } -static MA_INLINE HRESULT ma_IAudioClient3_GetService(ma_IAudioClient3* pThis, const IID* const riid, void** pp) { return pThis->lpVtbl->GetService(pThis, riid, pp); } -static MA_INLINE HRESULT ma_IAudioClient3_IsOffloadCapable(ma_IAudioClient3* pThis, MA_AUDIO_STREAM_CATEGORY category, BOOL* pOffloadCapable) { return pThis->lpVtbl->IsOffloadCapable(pThis, category, pOffloadCapable); } -static MA_INLINE HRESULT ma_IAudioClient3_SetClientProperties(ma_IAudioClient3* pThis, const ma_AudioClientProperties* pProperties) { return pThis->lpVtbl->SetClientProperties(pThis, pProperties); } -static MA_INLINE HRESULT ma_IAudioClient3_GetBufferSizeLimits(ma_IAudioClient3* pThis, const MA_WAVEFORMATEX* pFormat, BOOL eventDriven, MA_REFERENCE_TIME* pMinBufferDuration, MA_REFERENCE_TIME* pMaxBufferDuration) { return pThis->lpVtbl->GetBufferSizeLimits(pThis, pFormat, eventDriven, pMinBufferDuration, pMaxBufferDuration); } -static MA_INLINE HRESULT ma_IAudioClient3_GetSharedModeEnginePeriod(ma_IAudioClient3* pThis, const MA_WAVEFORMATEX* pFormat, ma_uint32* pDefaultPeriodInFrames, ma_uint32* pFundamentalPeriodInFrames, ma_uint32* pMinPeriodInFrames, ma_uint32* pMaxPeriodInFrames) { return pThis->lpVtbl->GetSharedModeEnginePeriod(pThis, pFormat, pDefaultPeriodInFrames, pFundamentalPeriodInFrames, pMinPeriodInFrames, pMaxPeriodInFrames); } -static MA_INLINE HRESULT ma_IAudioClient3_GetCurrentSharedModeEnginePeriod(ma_IAudioClient3* pThis, MA_WAVEFORMATEX** ppFormat, ma_uint32* pCurrentPeriodInFrames) { return pThis->lpVtbl->GetCurrentSharedModeEnginePeriod(pThis, ppFormat, pCurrentPeriodInFrames); } -static MA_INLINE HRESULT ma_IAudioClient3_InitializeSharedAudioStream(ma_IAudioClient3* pThis, DWORD streamFlags, ma_uint32 periodInFrames, const MA_WAVEFORMATEX* pFormat, const GUID* pAudioSessionGUID) { return pThis->lpVtbl->InitializeSharedAudioStream(pThis, streamFlags, periodInFrames, pFormat, pAudioSessionGUID); } - - -/* IAudioRenderClient */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IAudioRenderClient* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IAudioRenderClient* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IAudioRenderClient* pThis); - - /* IAudioRenderClient */ - HRESULT (STDMETHODCALLTYPE * GetBuffer) (ma_IAudioRenderClient* pThis, ma_uint32 numFramesRequested, BYTE** ppData); - HRESULT (STDMETHODCALLTYPE * ReleaseBuffer)(ma_IAudioRenderClient* pThis, ma_uint32 numFramesWritten, DWORD dwFlags); -} ma_IAudioRenderClientVtbl; -struct ma_IAudioRenderClient -{ - ma_IAudioRenderClientVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IAudioRenderClient_QueryInterface(ma_IAudioRenderClient* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IAudioRenderClient_AddRef(ma_IAudioRenderClient* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IAudioRenderClient_Release(ma_IAudioRenderClient* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IAudioRenderClient_GetBuffer(ma_IAudioRenderClient* pThis, ma_uint32 numFramesRequested, BYTE** ppData) { return pThis->lpVtbl->GetBuffer(pThis, numFramesRequested, ppData); } -static MA_INLINE HRESULT ma_IAudioRenderClient_ReleaseBuffer(ma_IAudioRenderClient* pThis, ma_uint32 numFramesWritten, DWORD dwFlags) { return pThis->lpVtbl->ReleaseBuffer(pThis, numFramesWritten, dwFlags); } - - -/* IAudioCaptureClient */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IAudioCaptureClient* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IAudioCaptureClient* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IAudioCaptureClient* pThis); - - /* IAudioRenderClient */ - HRESULT (STDMETHODCALLTYPE * GetBuffer) (ma_IAudioCaptureClient* pThis, BYTE** ppData, ma_uint32* pNumFramesToRead, DWORD* pFlags, ma_uint64* pDevicePosition, ma_uint64* pQPCPosition); - HRESULT (STDMETHODCALLTYPE * ReleaseBuffer) (ma_IAudioCaptureClient* pThis, ma_uint32 numFramesRead); - HRESULT (STDMETHODCALLTYPE * GetNextPacketSize)(ma_IAudioCaptureClient* pThis, ma_uint32* pNumFramesInNextPacket); -} ma_IAudioCaptureClientVtbl; -struct ma_IAudioCaptureClient -{ - ma_IAudioCaptureClientVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IAudioCaptureClient_QueryInterface(ma_IAudioCaptureClient* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IAudioCaptureClient_AddRef(ma_IAudioCaptureClient* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IAudioCaptureClient_Release(ma_IAudioCaptureClient* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IAudioCaptureClient_GetBuffer(ma_IAudioCaptureClient* pThis, BYTE** ppData, ma_uint32* pNumFramesToRead, DWORD* pFlags, ma_uint64* pDevicePosition, ma_uint64* pQPCPosition) { return pThis->lpVtbl->GetBuffer(pThis, ppData, pNumFramesToRead, pFlags, pDevicePosition, pQPCPosition); } -static MA_INLINE HRESULT ma_IAudioCaptureClient_ReleaseBuffer(ma_IAudioCaptureClient* pThis, ma_uint32 numFramesRead) { return pThis->lpVtbl->ReleaseBuffer(pThis, numFramesRead); } -static MA_INLINE HRESULT ma_IAudioCaptureClient_GetNextPacketSize(ma_IAudioCaptureClient* pThis, ma_uint32* pNumFramesInNextPacket) { return pThis->lpVtbl->GetNextPacketSize(pThis, pNumFramesInNextPacket); } - -#if defined(MA_WIN32_UWP) -/* mmdevapi Functions */ -typedef HRESULT (WINAPI * MA_PFN_ActivateAudioInterfaceAsync)(const wchar_t* deviceInterfacePath, const IID* riid, MA_PROPVARIANT* activationParams, ma_IActivateAudioInterfaceCompletionHandler* completionHandler, ma_IActivateAudioInterfaceAsyncOperation** activationOperation); -#endif - -/* Avrt Functions */ -typedef HANDLE (WINAPI * MA_PFN_AvSetMmThreadCharacteristicsA)(const char* TaskName, DWORD* TaskIndex); -typedef BOOL (WINAPI * MA_PFN_AvRevertMmThreadCharacteristics)(HANDLE AvrtHandle); - -#if !defined(MA_WIN32_DESKTOP) && !defined(MA_WIN32_GDK) -typedef struct ma_completion_handler_uwp ma_completion_handler_uwp; - -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_completion_handler_uwp* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_completion_handler_uwp* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_completion_handler_uwp* pThis); - - /* IActivateAudioInterfaceCompletionHandler */ - HRESULT (STDMETHODCALLTYPE * ActivateCompleted)(ma_completion_handler_uwp* pThis, ma_IActivateAudioInterfaceAsyncOperation* pActivateOperation); -} ma_completion_handler_uwp_vtbl; -struct ma_completion_handler_uwp -{ - ma_completion_handler_uwp_vtbl* lpVtbl; - MA_ATOMIC(4, ma_uint32) counter; - HANDLE hEvent; -}; - -static HRESULT STDMETHODCALLTYPE ma_completion_handler_uwp_QueryInterface(ma_completion_handler_uwp* pThis, const IID* const riid, void** ppObject) -{ - /* - We need to "implement" IAgileObject which is just an indicator that's used internally by WASAPI for some multithreading management. To - "implement" this, we just make sure we return pThis when the IAgileObject is requested. - */ - if (!ma_is_guid_equal(riid, &MA_IID_IUnknown) && !ma_is_guid_equal(riid, &MA_IID_IActivateAudioInterfaceCompletionHandler) && !ma_is_guid_equal(riid, &MA_IID_IAgileObject)) { - *ppObject = NULL; - return E_NOINTERFACE; - } - - /* Getting here means the IID is IUnknown or IMMNotificationClient. */ - *ppObject = (void*)pThis; - ((ma_completion_handler_uwp_vtbl*)pThis->lpVtbl)->AddRef(pThis); - return S_OK; -} - -static ULONG STDMETHODCALLTYPE ma_completion_handler_uwp_AddRef(ma_completion_handler_uwp* pThis) -{ - return (ULONG)c89atomic_fetch_add_32(&pThis->counter, 1) + 1; -} - -static ULONG STDMETHODCALLTYPE ma_completion_handler_uwp_Release(ma_completion_handler_uwp* pThis) -{ - ma_uint32 newRefCount = c89atomic_fetch_sub_32(&pThis->counter, 1) - 1; - if (newRefCount == 0) { - return 0; /* We don't free anything here because we never allocate the object on the heap. */ - } - - return (ULONG)newRefCount; -} - -static HRESULT STDMETHODCALLTYPE ma_completion_handler_uwp_ActivateCompleted(ma_completion_handler_uwp* pThis, ma_IActivateAudioInterfaceAsyncOperation* pActivateOperation) -{ - (void)pActivateOperation; - SetEvent(pThis->hEvent); - return S_OK; -} - - -static ma_completion_handler_uwp_vtbl g_maCompletionHandlerVtblInstance = { - ma_completion_handler_uwp_QueryInterface, - ma_completion_handler_uwp_AddRef, - ma_completion_handler_uwp_Release, - ma_completion_handler_uwp_ActivateCompleted -}; - -static ma_result ma_completion_handler_uwp_init(ma_completion_handler_uwp* pHandler) -{ - MA_ASSERT(pHandler != NULL); - MA_ZERO_OBJECT(pHandler); - - pHandler->lpVtbl = &g_maCompletionHandlerVtblInstance; - pHandler->counter = 1; - pHandler->hEvent = CreateEventA(NULL, FALSE, FALSE, NULL); - if (pHandler->hEvent == NULL) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - -static void ma_completion_handler_uwp_uninit(ma_completion_handler_uwp* pHandler) -{ - if (pHandler->hEvent != NULL) { - CloseHandle(pHandler->hEvent); - } -} - -static void ma_completion_handler_uwp_wait(ma_completion_handler_uwp* pHandler) -{ - WaitForSingleObject((HANDLE)pHandler->hEvent, INFINITE); -} -#endif /* !MA_WIN32_DESKTOP */ - -/* We need a virtual table for our notification client object that's used for detecting changes to the default device. */ -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) -static HRESULT STDMETHODCALLTYPE ma_IMMNotificationClient_QueryInterface(ma_IMMNotificationClient* pThis, const IID* const riid, void** ppObject) -{ - /* - We care about two interfaces - IUnknown and IMMNotificationClient. If the requested IID is something else - we just return E_NOINTERFACE. Otherwise we need to increment the reference counter and return S_OK. - */ - if (!ma_is_guid_equal(riid, &MA_IID_IUnknown) && !ma_is_guid_equal(riid, &MA_IID_IMMNotificationClient)) { - *ppObject = NULL; - return E_NOINTERFACE; - } - - /* Getting here means the IID is IUnknown or IMMNotificationClient. */ - *ppObject = (void*)pThis; - ((ma_IMMNotificationClientVtbl*)pThis->lpVtbl)->AddRef(pThis); - return S_OK; -} - -static ULONG STDMETHODCALLTYPE ma_IMMNotificationClient_AddRef(ma_IMMNotificationClient* pThis) -{ - return (ULONG)c89atomic_fetch_add_32(&pThis->counter, 1) + 1; -} - -static ULONG STDMETHODCALLTYPE ma_IMMNotificationClient_Release(ma_IMMNotificationClient* pThis) -{ - ma_uint32 newRefCount = c89atomic_fetch_sub_32(&pThis->counter, 1) - 1; - if (newRefCount == 0) { - return 0; /* We don't free anything here because we never allocate the object on the heap. */ - } - - return (ULONG)newRefCount; -} - -static HRESULT STDMETHODCALLTYPE ma_IMMNotificationClient_OnDeviceStateChanged(ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID, DWORD dwNewState) -{ - ma_bool32 isThisDevice = MA_FALSE; - ma_bool32 isCapture = MA_FALSE; - ma_bool32 isPlayback = MA_FALSE; - -#ifdef MA_DEBUG_OUTPUT - /*ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "IMMNotificationClient_OnDeviceStateChanged(pDeviceID=%S, dwNewState=%u)\n", (pDeviceID != NULL) ? pDeviceID : L"(NULL)", (unsigned int)dwNewState);*/ -#endif - - /* - There have been reports of a hang when a playback device is disconnected. The idea with this code is to explicitly stop the device if we detect - that the device is disabled or has been unplugged. - */ - if (pThis->pDevice->wasapi.allowCaptureAutoStreamRouting && (pThis->pDevice->type == ma_device_type_capture || pThis->pDevice->type == ma_device_type_duplex || pThis->pDevice->type == ma_device_type_loopback)) { - isCapture = MA_TRUE; - if (ma_strcmp_WCHAR(pThis->pDevice->capture.id.wasapi, pDeviceID) == 0) { - isThisDevice = MA_TRUE; - } - } - - if (pThis->pDevice->wasapi.allowPlaybackAutoStreamRouting && (pThis->pDevice->type == ma_device_type_playback || pThis->pDevice->type == ma_device_type_duplex)) { - isPlayback = MA_TRUE; - if (ma_strcmp_WCHAR(pThis->pDevice->playback.id.wasapi, pDeviceID) == 0) { - isThisDevice = MA_TRUE; - } - } - - - /* - If the device ID matches our device we need to mark our device as detached and stop it. When a - device is added in OnDeviceAdded(), we'll restart it. We only mark it as detached if the device - was started at the time of being removed. - */ - if (isThisDevice) { - if ((dwNewState & MA_MM_DEVICE_STATE_ACTIVE) == 0) { - /* - Unplugged or otherwise unavailable. Mark as detached if we were in a playing state. We'll - use this to determine whether or not we need to automatically start the device when it's - plugged back in again. - */ - if (ma_device_get_state(pThis->pDevice) == ma_device_state_started) { - if (isPlayback) { - pThis->pDevice->wasapi.isDetachedPlayback = MA_TRUE; - } - if (isCapture) { - pThis->pDevice->wasapi.isDetachedCapture = MA_TRUE; - } - - ma_device_stop(pThis->pDevice); - } - } - - if ((dwNewState & MA_MM_DEVICE_STATE_ACTIVE) != 0) { - /* The device was activated. If we were detached, we need to start it again. */ - ma_bool8 tryRestartingDevice = MA_FALSE; - - if (isPlayback) { - if (pThis->pDevice->wasapi.isDetachedPlayback) { - pThis->pDevice->wasapi.isDetachedPlayback = MA_FALSE; - ma_device_reroute__wasapi(pThis->pDevice, ma_device_type_playback); - tryRestartingDevice = MA_TRUE; - } - } - - if (isCapture) { - if (pThis->pDevice->wasapi.isDetachedCapture) { - pThis->pDevice->wasapi.isDetachedCapture = MA_FALSE; - ma_device_reroute__wasapi(pThis->pDevice, (pThis->pDevice->type == ma_device_type_loopback) ? ma_device_type_loopback : ma_device_type_capture); - tryRestartingDevice = MA_TRUE; - } - } - - if (tryRestartingDevice) { - if (pThis->pDevice->wasapi.isDetachedPlayback == MA_FALSE && pThis->pDevice->wasapi.isDetachedCapture == MA_FALSE) { - ma_device_start(pThis->pDevice); - } - } - } - } - - return S_OK; -} - -static HRESULT STDMETHODCALLTYPE ma_IMMNotificationClient_OnDeviceAdded(ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID) -{ -#ifdef MA_DEBUG_OUTPUT - /*ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "IMMNotificationClient_OnDeviceAdded(pDeviceID=%S)\n", (pDeviceID != NULL) ? pDeviceID : L"(NULL)");*/ -#endif - - /* We don't need to worry about this event for our purposes. */ - (void)pThis; - (void)pDeviceID; - return S_OK; -} - -static HRESULT STDMETHODCALLTYPE ma_IMMNotificationClient_OnDeviceRemoved(ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID) -{ -#ifdef MA_DEBUG_OUTPUT - /*ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "IMMNotificationClient_OnDeviceRemoved(pDeviceID=%S)\n", (pDeviceID != NULL) ? pDeviceID : L"(NULL)");*/ -#endif - - /* We don't need to worry about this event for our purposes. */ - (void)pThis; - (void)pDeviceID; - return S_OK; -} - -static HRESULT STDMETHODCALLTYPE ma_IMMNotificationClient_OnDefaultDeviceChanged(ma_IMMNotificationClient* pThis, ma_EDataFlow dataFlow, ma_ERole role, const WCHAR* pDefaultDeviceID) -{ -#ifdef MA_DEBUG_OUTPUT - /*ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "IMMNotificationClient_OnDefaultDeviceChanged(dataFlow=%d, role=%d, pDefaultDeviceID=%S)\n", dataFlow, role, (pDefaultDeviceID != NULL) ? pDefaultDeviceID : L"(NULL)");*/ -#endif - - /* We only ever use the eConsole role in miniaudio. */ - if (role != ma_eConsole) { - ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Stream rerouting: role != eConsole\n"); - return S_OK; - } - - /* We only care about devices with the same data flow and role as the current device. */ - if ((pThis->pDevice->type == ma_device_type_playback && dataFlow != ma_eRender) || - (pThis->pDevice->type == ma_device_type_capture && dataFlow != ma_eCapture) || - (pThis->pDevice->type == ma_device_type_loopback && dataFlow != ma_eRender)) { - ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Stream rerouting abandoned because dataFlow does match device type.\n"); - return S_OK; - } - - /* We need to consider dataFlow as ma_eCapture if device is ma_device_type_loopback */ - if (pThis->pDevice->type == ma_device_type_loopback) { - dataFlow = ma_eCapture; - } - - /* Don't do automatic stream routing if we're not allowed. */ - if ((dataFlow == ma_eRender && pThis->pDevice->wasapi.allowPlaybackAutoStreamRouting == MA_FALSE) || - (dataFlow == ma_eCapture && pThis->pDevice->wasapi.allowCaptureAutoStreamRouting == MA_FALSE)) { - ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Stream rerouting abandoned because automatic stream routing has been disabled by the device config.\n"); - return S_OK; - } - - /* - Not currently supporting automatic stream routing in exclusive mode. This is not working correctly on my machine due to - AUDCLNT_E_DEVICE_IN_USE errors when reinitializing the device. If this is a bug in miniaudio, we can try re-enabling this once - it's fixed. - */ - if ((dataFlow == ma_eRender && pThis->pDevice->playback.shareMode == ma_share_mode_exclusive) || - (dataFlow == ma_eCapture && pThis->pDevice->capture.shareMode == ma_share_mode_exclusive)) { - ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Stream rerouting abandoned because the device shared mode is exclusive.\n"); - return S_OK; - } - - - - /* - Second attempt at device rerouting. We're going to retrieve the device's state at the time of - the route change. We're then going to stop the device, reinitialize the device, and then start - it again if the state before stopping was ma_device_state_started. - */ - { - ma_uint32 previousState = ma_device_get_state(pThis->pDevice); - ma_bool8 restartDevice = MA_FALSE; - - if (previousState == ma_device_state_uninitialized || previousState == ma_device_state_starting) { - ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Stream rerouting abandoned because the device is in the process of starting.\n"); - return S_OK; - } - - if (previousState == ma_device_state_started) { - ma_device_stop(pThis->pDevice); - restartDevice = MA_TRUE; - } - - if (pDefaultDeviceID != NULL) { /* <-- The input device ID will be null if there's no other device available. */ - ma_mutex_lock(&pThis->pDevice->wasapi.rerouteLock); - { - if (dataFlow == ma_eRender) { - ma_device_reroute__wasapi(pThis->pDevice, ma_device_type_playback); - - if (pThis->pDevice->wasapi.isDetachedPlayback) { - pThis->pDevice->wasapi.isDetachedPlayback = MA_FALSE; - - if (pThis->pDevice->type == ma_device_type_duplex && pThis->pDevice->wasapi.isDetachedCapture) { - restartDevice = MA_FALSE; /* It's a duplex device and the capture side is detached. We cannot be restarting the device just yet. */ - } - else { - restartDevice = MA_TRUE; /* It's not a duplex device, or the capture side is also attached so we can go ahead and restart the device. */ - } - } - } - else { - ma_device_reroute__wasapi(pThis->pDevice, (pThis->pDevice->type == ma_device_type_loopback) ? ma_device_type_loopback : ma_device_type_capture); - - if (pThis->pDevice->wasapi.isDetachedCapture) { - pThis->pDevice->wasapi.isDetachedCapture = MA_FALSE; - - if (pThis->pDevice->type == ma_device_type_duplex && pThis->pDevice->wasapi.isDetachedPlayback) { - restartDevice = MA_FALSE; /* It's a duplex device and the playback side is detached. We cannot be restarting the device just yet. */ - } - else { - restartDevice = MA_TRUE; /* It's not a duplex device, or the playback side is also attached so we can go ahead and restart the device. */ - } - } - } - } - ma_mutex_unlock(&pThis->pDevice->wasapi.rerouteLock); - - if (restartDevice) { - ma_device_start(pThis->pDevice); - } - } - } - - return S_OK; -} - -static HRESULT STDMETHODCALLTYPE ma_IMMNotificationClient_OnPropertyValueChanged(ma_IMMNotificationClient* pThis, const WCHAR* pDeviceID, const PROPERTYKEY key) -{ -#ifdef MA_DEBUG_OUTPUT - /*ma_log_postf(ma_device_get_log(pThis->pDevice), MA_LOG_LEVEL_DEBUG, "IMMNotificationClient_OnPropertyValueChanged(pDeviceID=%S)\n", (pDeviceID != NULL) ? pDeviceID : L"(NULL)");*/ -#endif - - (void)pThis; - (void)pDeviceID; - (void)key; - return S_OK; -} - -static ma_IMMNotificationClientVtbl g_maNotificationCientVtbl = { - ma_IMMNotificationClient_QueryInterface, - ma_IMMNotificationClient_AddRef, - ma_IMMNotificationClient_Release, - ma_IMMNotificationClient_OnDeviceStateChanged, - ma_IMMNotificationClient_OnDeviceAdded, - ma_IMMNotificationClient_OnDeviceRemoved, - ma_IMMNotificationClient_OnDefaultDeviceChanged, - ma_IMMNotificationClient_OnPropertyValueChanged -}; -#endif /* MA_WIN32_DESKTOP */ - -static const char* ma_to_usage_string__wasapi(ma_wasapi_usage usage) -{ - switch (usage) - { - case ma_wasapi_usage_default: return NULL; - case ma_wasapi_usage_games: return "Games"; - case ma_wasapi_usage_pro_audio: return "Pro Audio"; - default: break; - } - - return NULL; -} - -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) -typedef ma_IMMDevice ma_WASAPIDeviceInterface; -#else -typedef ma_IUnknown ma_WASAPIDeviceInterface; -#endif - - -#define MA_CONTEXT_COMMAND_QUIT__WASAPI 1 -#define MA_CONTEXT_COMMAND_CREATE_IAUDIOCLIENT__WASAPI 2 -#define MA_CONTEXT_COMMAND_RELEASE_IAUDIOCLIENT__WASAPI 3 - -static ma_context_command__wasapi ma_context_init_command__wasapi(int code) -{ - ma_context_command__wasapi cmd; - - MA_ZERO_OBJECT(&cmd); - cmd.code = code; - - return cmd; -} - -static ma_result ma_context_post_command__wasapi(ma_context* pContext, const ma_context_command__wasapi* pCmd) -{ - /* For now we are doing everything synchronously, but I might relax this later if the need arises. */ - ma_result result; - ma_bool32 isUsingLocalEvent = MA_FALSE; - ma_event localEvent; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pCmd != NULL); - - if (pCmd->pEvent == NULL) { - isUsingLocalEvent = MA_TRUE; - - result = ma_event_init(&localEvent); - if (result != MA_SUCCESS) { - return result; /* Failed to create the event for this command. */ - } - } - - /* Here is where we add the command to the list. If there's not enough room we'll spin until there is. */ - ma_mutex_lock(&pContext->wasapi.commandLock); - { - ma_uint32 index; - - /* Spin until we've got some space available. */ - while (pContext->wasapi.commandCount == ma_countof(pContext->wasapi.commands)) { - ma_yield(); - } - - /* Space is now available. Can safely add to the list. */ - index = (pContext->wasapi.commandIndex + pContext->wasapi.commandCount) % ma_countof(pContext->wasapi.commands); - pContext->wasapi.commands[index] = *pCmd; - pContext->wasapi.commands[index].pEvent = &localEvent; - pContext->wasapi.commandCount += 1; - - /* Now that the command has been added, release the semaphore so ma_context_next_command__wasapi() can return. */ - ma_semaphore_release(&pContext->wasapi.commandSem); - } - ma_mutex_unlock(&pContext->wasapi.commandLock); - - if (isUsingLocalEvent) { - ma_event_wait(&localEvent); - ma_event_uninit(&localEvent); - } - - return MA_SUCCESS; -} - -static ma_result ma_context_next_command__wasapi(ma_context* pContext, ma_context_command__wasapi* pCmd) -{ - ma_result result = MA_SUCCESS; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pCmd != NULL); - - result = ma_semaphore_wait(&pContext->wasapi.commandSem); - if (result == MA_SUCCESS) { - ma_mutex_lock(&pContext->wasapi.commandLock); - { - *pCmd = pContext->wasapi.commands[pContext->wasapi.commandIndex]; - pContext->wasapi.commandIndex = (pContext->wasapi.commandIndex + 1) % ma_countof(pContext->wasapi.commands); - pContext->wasapi.commandCount -= 1; - } - ma_mutex_unlock(&pContext->wasapi.commandLock); - } - - return result; -} - -static ma_thread_result MA_THREADCALL ma_context_command_thread__wasapi(void* pUserData) -{ - ma_result result; - ma_context* pContext = (ma_context*)pUserData; - MA_ASSERT(pContext != NULL); - - for (;;) { - ma_context_command__wasapi cmd; - result = ma_context_next_command__wasapi(pContext, &cmd); - if (result != MA_SUCCESS) { - break; - } - - switch (cmd.code) - { - case MA_CONTEXT_COMMAND_QUIT__WASAPI: - { - /* Do nothing. Handled after the switch. */ - } break; - - case MA_CONTEXT_COMMAND_CREATE_IAUDIOCLIENT__WASAPI: - { - if (cmd.data.createAudioClient.deviceType == ma_device_type_playback) { - *cmd.data.createAudioClient.pResult = ma_result_from_HRESULT(ma_IAudioClient_GetService((ma_IAudioClient*)cmd.data.createAudioClient.pAudioClient, &MA_IID_IAudioRenderClient, cmd.data.createAudioClient.ppAudioClientService)); - } else { - *cmd.data.createAudioClient.pResult = ma_result_from_HRESULT(ma_IAudioClient_GetService((ma_IAudioClient*)cmd.data.createAudioClient.pAudioClient, &MA_IID_IAudioCaptureClient, cmd.data.createAudioClient.ppAudioClientService)); - } - } break; - - case MA_CONTEXT_COMMAND_RELEASE_IAUDIOCLIENT__WASAPI: - { - if (cmd.data.releaseAudioClient.deviceType == ma_device_type_playback) { - if (cmd.data.releaseAudioClient.pDevice->wasapi.pAudioClientPlayback != NULL) { - ma_IAudioClient_Release((ma_IAudioClient*)cmd.data.releaseAudioClient.pDevice->wasapi.pAudioClientPlayback); - cmd.data.releaseAudioClient.pDevice->wasapi.pAudioClientPlayback = NULL; - } - } - - if (cmd.data.releaseAudioClient.deviceType == ma_device_type_capture) { - if (cmd.data.releaseAudioClient.pDevice->wasapi.pAudioClientCapture != NULL) { - ma_IAudioClient_Release((ma_IAudioClient*)cmd.data.releaseAudioClient.pDevice->wasapi.pAudioClientCapture); - cmd.data.releaseAudioClient.pDevice->wasapi.pAudioClientCapture = NULL; - } - } - } break; - - default: - { - /* Unknown command. Ignore it, but trigger an assert in debug mode so we're aware of it. */ - MA_ASSERT(MA_FALSE); - } break; - } - - if (cmd.pEvent != NULL) { - ma_event_signal(cmd.pEvent); - } - - if (cmd.code == MA_CONTEXT_COMMAND_QUIT__WASAPI) { - break; /* Received a quit message. Get out of here. */ - } - } - - return (ma_thread_result)0; -} - -static ma_result ma_device_create_IAudioClient_service__wasapi(ma_context* pContext, ma_device_type deviceType, ma_IAudioClient* pAudioClient, void** ppAudioClientService) -{ - ma_result result; - ma_result cmdResult; - ma_context_command__wasapi cmd = ma_context_init_command__wasapi(MA_CONTEXT_COMMAND_CREATE_IAUDIOCLIENT__WASAPI); - cmd.data.createAudioClient.deviceType = deviceType; - cmd.data.createAudioClient.pAudioClient = (void*)pAudioClient; - cmd.data.createAudioClient.ppAudioClientService = ppAudioClientService; - cmd.data.createAudioClient.pResult = &cmdResult; /* Declared locally, but won't be dereferenced after this function returns since execution of the command will wait here. */ - - result = ma_context_post_command__wasapi(pContext, &cmd); /* This will not return until the command has actually been run. */ - if (result != MA_SUCCESS) { - return result; - } - - return *cmd.data.createAudioClient.pResult; -} - -#if 0 /* Not used at the moment, but leaving here for future use. */ -static ma_result ma_device_release_IAudioClient_service__wasapi(ma_device* pDevice, ma_device_type deviceType) -{ - ma_result result; - ma_context_command__wasapi cmd = ma_context_init_command__wasapi(MA_CONTEXT_COMMAND_RELEASE_IAUDIOCLIENT__WASAPI); - cmd.data.releaseAudioClient.pDevice = pDevice; - cmd.data.releaseAudioClient.deviceType = deviceType; - - result = ma_context_post_command__wasapi(pDevice->pContext, &cmd); /* This will not return until the command has actually been run. */ - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} -#endif - - -static void ma_add_native_data_format_to_device_info_from_WAVEFORMATEX(const MA_WAVEFORMATEX* pWF, ma_share_mode shareMode, ma_device_info* pInfo) -{ - MA_ASSERT(pWF != NULL); - MA_ASSERT(pInfo != NULL); - - if (pInfo->nativeDataFormatCount >= ma_countof(pInfo->nativeDataFormats)) { - return; /* Too many data formats. Need to ignore this one. Don't think this should ever happen with WASAPI. */ - } - - pInfo->nativeDataFormats[pInfo->nativeDataFormatCount].format = ma_format_from_WAVEFORMATEX(pWF); - pInfo->nativeDataFormats[pInfo->nativeDataFormatCount].channels = pWF->nChannels; - pInfo->nativeDataFormats[pInfo->nativeDataFormatCount].sampleRate = pWF->nSamplesPerSec; - pInfo->nativeDataFormats[pInfo->nativeDataFormatCount].flags = (shareMode == ma_share_mode_exclusive) ? MA_DATA_FORMAT_FLAG_EXCLUSIVE_MODE : 0; - pInfo->nativeDataFormatCount += 1; -} - -static ma_result ma_context_get_device_info_from_IAudioClient__wasapi(ma_context* pContext, /*ma_IMMDevice**/void* pMMDevice, ma_IAudioClient* pAudioClient, ma_device_info* pInfo) -{ - HRESULT hr; - MA_WAVEFORMATEX* pWF = NULL; - - MA_ASSERT(pAudioClient != NULL); - MA_ASSERT(pInfo != NULL); - - /* Shared Mode. We use GetMixFormat() here. */ - hr = ma_IAudioClient_GetMixFormat((ma_IAudioClient*)pAudioClient, (MA_WAVEFORMATEX**)&pWF); - if (SUCCEEDED(hr)) { - ma_add_native_data_format_to_device_info_from_WAVEFORMATEX(pWF, ma_share_mode_shared, pInfo); - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to retrieve mix format for device info retrieval."); - return ma_result_from_HRESULT(hr); - } - - /* - Exlcusive Mode. We repeatedly call IsFormatSupported() here. This is not currently supported on - UWP. Failure to retrieve the exclusive mode format is not considered an error, so from here on - out, MA_SUCCESS is guaranteed to be returned. - */ - #if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - { - ma_IPropertyStore *pProperties; - - /* - The first thing to do is get the format from PKEY_AudioEngine_DeviceFormat. This should give us a channel count we assume is - correct which will simplify our searching. - */ - hr = ma_IMMDevice_OpenPropertyStore((ma_IMMDevice*)pMMDevice, STGM_READ, &pProperties); - if (SUCCEEDED(hr)) { - MA_PROPVARIANT var; - ma_PropVariantInit(&var); - - hr = ma_IPropertyStore_GetValue(pProperties, &MA_PKEY_AudioEngine_DeviceFormat, &var); - if (SUCCEEDED(hr)) { - pWF = (MA_WAVEFORMATEX*)var.blob.pBlobData; - - /* - In my testing, the format returned by PKEY_AudioEngine_DeviceFormat is suitable for exclusive mode so we check this format - first. If this fails, fall back to a search. - */ - hr = ma_IAudioClient_IsFormatSupported((ma_IAudioClient*)pAudioClient, MA_AUDCLNT_SHAREMODE_EXCLUSIVE, pWF, NULL); - if (SUCCEEDED(hr)) { - /* The format returned by PKEY_AudioEngine_DeviceFormat is supported. */ - ma_add_native_data_format_to_device_info_from_WAVEFORMATEX(pWF, ma_share_mode_exclusive, pInfo); - } else { - /* - The format returned by PKEY_AudioEngine_DeviceFormat is not supported, so fall back to a search. We assume the channel - count returned by MA_PKEY_AudioEngine_DeviceFormat is valid and correct. For simplicity we're only returning one format. - */ - ma_uint32 channels = pWF->nChannels; - ma_channel defaultChannelMap[MA_MAX_CHANNELS]; - MA_WAVEFORMATEXTENSIBLE wf; - ma_bool32 found; - ma_uint32 iFormat; - - /* Make sure we don't overflow the channel map. */ - if (channels > MA_MAX_CHANNELS) { - channels = MA_MAX_CHANNELS; - } - - ma_channel_map_init_standard(ma_standard_channel_map_microsoft, defaultChannelMap, ma_countof(defaultChannelMap), channels); - - MA_ZERO_OBJECT(&wf); - wf.cbSize = sizeof(wf); - wf.wFormatTag = WAVE_FORMAT_EXTENSIBLE; - wf.nChannels = (WORD)channels; - wf.dwChannelMask = ma_channel_map_to_channel_mask__win32(defaultChannelMap, channels); - - found = MA_FALSE; - for (iFormat = 0; iFormat < ma_countof(g_maFormatPriorities); ++iFormat) { - ma_format format = g_maFormatPriorities[iFormat]; - ma_uint32 iSampleRate; - - wf.wBitsPerSample = (WORD)(ma_get_bytes_per_sample(format)*8); - wf.nBlockAlign = (WORD)(wf.nChannels * wf.wBitsPerSample / 8); - wf.nAvgBytesPerSec = wf.nBlockAlign * wf.nSamplesPerSec; - wf.Samples.wValidBitsPerSample = /*(format == ma_format_s24_32) ? 24 :*/ wf.wBitsPerSample; - if (format == ma_format_f32) { - wf.SubFormat = MA_GUID_KSDATAFORMAT_SUBTYPE_IEEE_FLOAT; - } else { - wf.SubFormat = MA_GUID_KSDATAFORMAT_SUBTYPE_PCM; - } - - for (iSampleRate = 0; iSampleRate < ma_countof(g_maStandardSampleRatePriorities); ++iSampleRate) { - wf.nSamplesPerSec = g_maStandardSampleRatePriorities[iSampleRate]; - - hr = ma_IAudioClient_IsFormatSupported((ma_IAudioClient*)pAudioClient, MA_AUDCLNT_SHAREMODE_EXCLUSIVE, (MA_WAVEFORMATEX*)&wf, NULL); - if (SUCCEEDED(hr)) { - ma_add_native_data_format_to_device_info_from_WAVEFORMATEX((MA_WAVEFORMATEX*)&wf, ma_share_mode_exclusive, pInfo); - found = MA_TRUE; - break; - } - } - - if (found) { - break; - } - } - - ma_PropVariantClear(pContext, &var); - - if (!found) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "[WASAPI] Failed to find suitable device format for device info retrieval."); - } - } - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "[WASAPI] Failed to retrieve device format for device info retrieval."); - } - - ma_IPropertyStore_Release(pProperties); - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "[WASAPI] Failed to open property store for device info retrieval."); - } - } - #else - { - (void)pMMDevice; /* Unused. */ - } - #endif - - return MA_SUCCESS; -} - -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) -static ma_EDataFlow ma_device_type_to_EDataFlow(ma_device_type deviceType) -{ - if (deviceType == ma_device_type_playback) { - return ma_eRender; - } else if (deviceType == ma_device_type_capture) { - return ma_eCapture; - } else { - MA_ASSERT(MA_FALSE); - return ma_eRender; /* Should never hit this. */ - } -} - -static ma_result ma_context_create_IMMDeviceEnumerator__wasapi(ma_context* pContext, ma_IMMDeviceEnumerator** ppDeviceEnumerator) -{ - HRESULT hr; - ma_IMMDeviceEnumerator* pDeviceEnumerator; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppDeviceEnumerator != NULL); - - *ppDeviceEnumerator = NULL; /* Safety. */ - - hr = ma_CoCreateInstance(pContext, MA_CLSID_MMDeviceEnumerator, NULL, CLSCTX_ALL, MA_IID_IMMDeviceEnumerator, (void**)&pDeviceEnumerator); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create device enumerator."); - return ma_result_from_HRESULT(hr); - } - - *ppDeviceEnumerator = pDeviceEnumerator; - - return MA_SUCCESS; -} - -static WCHAR* ma_context_get_default_device_id_from_IMMDeviceEnumerator__wasapi(ma_context* pContext, ma_IMMDeviceEnumerator* pDeviceEnumerator, ma_device_type deviceType) -{ - HRESULT hr; - ma_IMMDevice* pMMDefaultDevice = NULL; - WCHAR* pDefaultDeviceID = NULL; - ma_EDataFlow dataFlow; - ma_ERole role; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDeviceEnumerator != NULL); - - (void)pContext; - - /* Grab the EDataFlow type from the device type. */ - dataFlow = ma_device_type_to_EDataFlow(deviceType); - - /* The role is always eConsole, but we may make this configurable later. */ - role = ma_eConsole; - - hr = ma_IMMDeviceEnumerator_GetDefaultAudioEndpoint(pDeviceEnumerator, dataFlow, role, &pMMDefaultDevice); - if (FAILED(hr)) { - return NULL; - } - - hr = ma_IMMDevice_GetId(pMMDefaultDevice, &pDefaultDeviceID); - - ma_IMMDevice_Release(pMMDefaultDevice); - pMMDefaultDevice = NULL; - - if (FAILED(hr)) { - return NULL; - } - - return pDefaultDeviceID; -} - -static WCHAR* ma_context_get_default_device_id__wasapi(ma_context* pContext, ma_device_type deviceType) /* Free the returned pointer with ma_CoTaskMemFree() */ -{ - ma_result result; - ma_IMMDeviceEnumerator* pDeviceEnumerator; - WCHAR* pDefaultDeviceID = NULL; - - MA_ASSERT(pContext != NULL); - - result = ma_context_create_IMMDeviceEnumerator__wasapi(pContext, &pDeviceEnumerator); - if (result != MA_SUCCESS) { - return NULL; - } - - pDefaultDeviceID = ma_context_get_default_device_id_from_IMMDeviceEnumerator__wasapi(pContext, pDeviceEnumerator, deviceType); - - ma_IMMDeviceEnumerator_Release(pDeviceEnumerator); - return pDefaultDeviceID; -} - -static ma_result ma_context_get_MMDevice__wasapi(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_IMMDevice** ppMMDevice) -{ - ma_IMMDeviceEnumerator* pDeviceEnumerator; - HRESULT hr; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppMMDevice != NULL); - - hr = ma_CoCreateInstance(pContext, MA_CLSID_MMDeviceEnumerator, NULL, CLSCTX_ALL, MA_IID_IMMDeviceEnumerator, (void**)&pDeviceEnumerator); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create IMMDeviceEnumerator.\n"); - return ma_result_from_HRESULT(hr); - } - - if (pDeviceID == NULL) { - hr = ma_IMMDeviceEnumerator_GetDefaultAudioEndpoint(pDeviceEnumerator, (deviceType == ma_device_type_capture) ? ma_eCapture : ma_eRender, ma_eConsole, ppMMDevice); - } else { - hr = ma_IMMDeviceEnumerator_GetDevice(pDeviceEnumerator, pDeviceID->wasapi, ppMMDevice); - } - - ma_IMMDeviceEnumerator_Release(pDeviceEnumerator); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to retrieve IMMDevice.\n"); - return ma_result_from_HRESULT(hr); - } - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_id_from_MMDevice__wasapi(ma_context* pContext, ma_IMMDevice* pMMDevice, ma_device_id* pDeviceID) -{ - WCHAR* pDeviceIDString; - HRESULT hr; - - MA_ASSERT(pDeviceID != NULL); - - hr = ma_IMMDevice_GetId(pMMDevice, &pDeviceIDString); - if (SUCCEEDED(hr)) { - size_t idlen = ma_strlen_WCHAR(pDeviceIDString); - if (idlen+1 > ma_countof(pDeviceID->wasapi)) { - ma_CoTaskMemFree(pContext, pDeviceIDString); - MA_ASSERT(MA_FALSE); /* NOTE: If this is triggered, please report it. It means the format of the ID must haved change and is too long to fit in our fixed sized buffer. */ - return MA_ERROR; - } - - MA_COPY_MEMORY(pDeviceID->wasapi, pDeviceIDString, idlen * sizeof(wchar_t)); - pDeviceID->wasapi[idlen] = '\0'; - - ma_CoTaskMemFree(pContext, pDeviceIDString); - - return MA_SUCCESS; - } - - return MA_ERROR; -} - -static ma_result ma_context_get_device_info_from_MMDevice__wasapi(ma_context* pContext, ma_IMMDevice* pMMDevice, WCHAR* pDefaultDeviceID, ma_bool32 onlySimpleInfo, ma_device_info* pInfo) -{ - ma_result result; - HRESULT hr; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pMMDevice != NULL); - MA_ASSERT(pInfo != NULL); - - /* ID. */ - result = ma_context_get_device_id_from_MMDevice__wasapi(pContext, pMMDevice, &pInfo->id); - if (result == MA_SUCCESS) { - if (pDefaultDeviceID != NULL) { - if (ma_strcmp_WCHAR(pInfo->id.wasapi, pDefaultDeviceID) == 0) { - pInfo->isDefault = MA_TRUE; - } - } - } - - /* Description / Friendly Name */ - { - ma_IPropertyStore *pProperties; - hr = ma_IMMDevice_OpenPropertyStore(pMMDevice, STGM_READ, &pProperties); - if (SUCCEEDED(hr)) { - MA_PROPVARIANT var; - - ma_PropVariantInit(&var); - hr = ma_IPropertyStore_GetValue(pProperties, &MA_PKEY_Device_FriendlyName, &var); - if (SUCCEEDED(hr)) { - WideCharToMultiByte(CP_UTF8, 0, var.pwszVal, -1, pInfo->name, sizeof(pInfo->name), 0, FALSE); - ma_PropVariantClear(pContext, &var); - } - - ma_IPropertyStore_Release(pProperties); - } - } - - /* Format */ - if (!onlySimpleInfo) { - ma_IAudioClient* pAudioClient; - hr = ma_IMMDevice_Activate(pMMDevice, &MA_IID_IAudioClient, CLSCTX_ALL, NULL, (void**)&pAudioClient); - if (SUCCEEDED(hr)) { - result = ma_context_get_device_info_from_IAudioClient__wasapi(pContext, pMMDevice, pAudioClient, pInfo); - - ma_IAudioClient_Release(pAudioClient); - return result; - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to activate audio client for device info retrieval."); - return ma_result_from_HRESULT(hr); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_context_enumerate_devices_by_type__wasapi(ma_context* pContext, ma_IMMDeviceEnumerator* pDeviceEnumerator, ma_device_type deviceType, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_result result = MA_SUCCESS; - UINT deviceCount; - HRESULT hr; - ma_uint32 iDevice; - WCHAR* pDefaultDeviceID = NULL; - ma_IMMDeviceCollection* pDeviceCollection = NULL; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* Grab the default device. We use this to know whether or not flag the returned device info as being the default. */ - pDefaultDeviceID = ma_context_get_default_device_id_from_IMMDeviceEnumerator__wasapi(pContext, pDeviceEnumerator, deviceType); - - /* We need to enumerate the devices which returns a device collection. */ - hr = ma_IMMDeviceEnumerator_EnumAudioEndpoints(pDeviceEnumerator, ma_device_type_to_EDataFlow(deviceType), MA_MM_DEVICE_STATE_ACTIVE, &pDeviceCollection); - if (SUCCEEDED(hr)) { - hr = ma_IMMDeviceCollection_GetCount(pDeviceCollection, &deviceCount); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to get device count.\n"); - result = ma_result_from_HRESULT(hr); - goto done; - } - - for (iDevice = 0; iDevice < deviceCount; ++iDevice) { - ma_device_info deviceInfo; - ma_IMMDevice* pMMDevice; - - MA_ZERO_OBJECT(&deviceInfo); - - hr = ma_IMMDeviceCollection_Item(pDeviceCollection, iDevice, &pMMDevice); - if (SUCCEEDED(hr)) { - result = ma_context_get_device_info_from_MMDevice__wasapi(pContext, pMMDevice, pDefaultDeviceID, MA_TRUE, &deviceInfo); /* MA_TRUE = onlySimpleInfo. */ - - ma_IMMDevice_Release(pMMDevice); - if (result == MA_SUCCESS) { - ma_bool32 cbResult = callback(pContext, deviceType, &deviceInfo, pUserData); - if (cbResult == MA_FALSE) { - break; - } - } - } - } - } - -done: - if (pDefaultDeviceID != NULL) { - ma_CoTaskMemFree(pContext, pDefaultDeviceID); - pDefaultDeviceID = NULL; - } - - if (pDeviceCollection != NULL) { - ma_IMMDeviceCollection_Release(pDeviceCollection); - pDeviceCollection = NULL; - } - - return result; -} - -static ma_result ma_context_get_IAudioClient_Desktop__wasapi(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, MA_PROPVARIANT* pActivationParams, ma_IAudioClient** ppAudioClient, ma_IMMDevice** ppMMDevice) -{ - ma_result result; - HRESULT hr; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppAudioClient != NULL); - MA_ASSERT(ppMMDevice != NULL); - - result = ma_context_get_MMDevice__wasapi(pContext, deviceType, pDeviceID, ppMMDevice); - if (result != MA_SUCCESS) { - return result; - } - - hr = ma_IMMDevice_Activate(*ppMMDevice, &MA_IID_IAudioClient, CLSCTX_ALL, pActivationParams, (void**)ppAudioClient); - if (FAILED(hr)) { - return ma_result_from_HRESULT(hr); - } - - return MA_SUCCESS; -} -#else -static ma_result ma_context_get_IAudioClient_UWP__wasapi(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, MA_PROPVARIANT* pActivationParams, ma_IAudioClient** ppAudioClient, ma_IUnknown** ppActivatedInterface) -{ - ma_IActivateAudioInterfaceAsyncOperation *pAsyncOp = NULL; - ma_completion_handler_uwp completionHandler; - IID iid; - WCHAR* iidStr; - HRESULT hr; - ma_result result; - HRESULT activateResult; - ma_IUnknown* pActivatedInterface; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppAudioClient != NULL); - - if (pDeviceID != NULL) { - iidStr = (WCHAR*)pDeviceID->wasapi; - } else { - if (deviceType == ma_device_type_capture) { - iid = MA_IID_DEVINTERFACE_AUDIO_CAPTURE; - } else { - iid = MA_IID_DEVINTERFACE_AUDIO_RENDER; - } - - #if defined(__cplusplus) - hr = StringFromIID(iid, &iidStr); - #else - hr = StringFromIID(&iid, &iidStr); - #endif - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to convert device IID to string for ActivateAudioInterfaceAsync(). Out of memory.\n"); - return ma_result_from_HRESULT(hr); - } - } - - result = ma_completion_handler_uwp_init(&completionHandler); - if (result != MA_SUCCESS) { - ma_CoTaskMemFree(pContext, iidStr); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create event for waiting for ActivateAudioInterfaceAsync().\n"); - return result; - } - - hr = ((MA_PFN_ActivateAudioInterfaceAsync)pContext->wasapi.ActivateAudioInterfaceAsync)(iidStr, &MA_IID_IAudioClient, pActivationParams, (ma_IActivateAudioInterfaceCompletionHandler*)&completionHandler, (ma_IActivateAudioInterfaceAsyncOperation**)&pAsyncOp); - if (FAILED(hr)) { - ma_completion_handler_uwp_uninit(&completionHandler); - ma_CoTaskMemFree(pContext, iidStr); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] ActivateAudioInterfaceAsync() failed.\n"); - return ma_result_from_HRESULT(hr); - } - - if (pDeviceID == NULL) { - ma_CoTaskMemFree(pContext, iidStr); - } - - /* Wait for the async operation for finish. */ - ma_completion_handler_uwp_wait(&completionHandler); - ma_completion_handler_uwp_uninit(&completionHandler); - - hr = ma_IActivateAudioInterfaceAsyncOperation_GetActivateResult(pAsyncOp, &activateResult, &pActivatedInterface); - ma_IActivateAudioInterfaceAsyncOperation_Release(pAsyncOp); - - if (FAILED(hr) || FAILED(activateResult)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to activate device.\n"); - return FAILED(hr) ? ma_result_from_HRESULT(hr) : ma_result_from_HRESULT(activateResult); - } - - /* Here is where we grab the IAudioClient interface. */ - hr = ma_IUnknown_QueryInterface(pActivatedInterface, &MA_IID_IAudioClient, (void**)ppAudioClient); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to query IAudioClient interface.\n"); - return ma_result_from_HRESULT(hr); - } - - if (ppActivatedInterface) { - *ppActivatedInterface = pActivatedInterface; - } else { - ma_IUnknown_Release(pActivatedInterface); - } - - return MA_SUCCESS; -} -#endif - - -/* https://docs.microsoft.com/en-us/windows/win32/api/audioclientactivationparams/ne-audioclientactivationparams-audioclient_activation_type */ -typedef enum -{ - MA_AUDIOCLIENT_ACTIVATION_TYPE_DEFAULT, - MA_AUDIOCLIENT_ACTIVATION_TYPE_PROCESS_LOOPBACK -} MA_AUDIOCLIENT_ACTIVATION_TYPE; - -/* https://docs.microsoft.com/en-us/windows/win32/api/audioclientactivationparams/ne-audioclientactivationparams-process_loopback_mode */ -typedef enum -{ - MA_PROCESS_LOOPBACK_MODE_INCLUDE_TARGET_PROCESS_TREE, - MA_PROCESS_LOOPBACK_MODE_EXCLUDE_TARGET_PROCESS_TREE -} MA_PROCESS_LOOPBACK_MODE; - -/* https://docs.microsoft.com/en-us/windows/win32/api/audioclientactivationparams/ns-audioclientactivationparams-audioclient_process_loopback_params */ -typedef struct -{ - DWORD TargetProcessId; - MA_PROCESS_LOOPBACK_MODE ProcessLoopbackMode; -} MA_AUDIOCLIENT_PROCESS_LOOPBACK_PARAMS; - -#if defined(_MSC_VER) && !defined(__clang__) - #pragma warning(push) - #pragma warning(disable:4201) /* nonstandard extension used: nameless struct/union */ -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wpedantic" /* For ISO C99 doesn't support unnamed structs/unions [-Wpedantic] */ - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc11-extensions" /* anonymous unions are a C11 extension */ - #endif -#endif -/* https://docs.microsoft.com/en-us/windows/win32/api/audioclientactivationparams/ns-audioclientactivationparams-audioclient_activation_params */ -typedef struct -{ - MA_AUDIOCLIENT_ACTIVATION_TYPE ActivationType; - union - { - MA_AUDIOCLIENT_PROCESS_LOOPBACK_PARAMS ProcessLoopbackParams; - }; -} MA_AUDIOCLIENT_ACTIVATION_PARAMS; -#if defined(_MSC_VER) && !defined(__clang__) - #pragma warning(pop) -#elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) - #pragma GCC diagnostic pop -#endif - -#define MA_VIRTUAL_AUDIO_DEVICE_PROCESS_LOOPBACK L"VAD\\Process_Loopback" - -static ma_result ma_context_get_IAudioClient__wasapi(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_uint32 loopbackProcessID, ma_bool32 loopbackProcessExclude, ma_IAudioClient** ppAudioClient, ma_WASAPIDeviceInterface** ppDeviceInterface) -{ - ma_result result; - ma_bool32 usingProcessLoopback = MA_FALSE; - MA_AUDIOCLIENT_ACTIVATION_PARAMS audioclientActivationParams; - MA_PROPVARIANT activationParams; - MA_PROPVARIANT* pActivationParams = NULL; - ma_device_id virtualDeviceID; - - /* Activation parameters specific to loopback mode. Note that process-specific loopback will only work when a default device ID is specified. */ - if (deviceType == ma_device_type_loopback && loopbackProcessID != 0 && pDeviceID == NULL) { - usingProcessLoopback = MA_TRUE; - } - - if (usingProcessLoopback) { - MA_ZERO_OBJECT(&audioclientActivationParams); - audioclientActivationParams.ActivationType = MA_AUDIOCLIENT_ACTIVATION_TYPE_PROCESS_LOOPBACK; - audioclientActivationParams.ProcessLoopbackParams.ProcessLoopbackMode = (loopbackProcessExclude) ? MA_PROCESS_LOOPBACK_MODE_EXCLUDE_TARGET_PROCESS_TREE : MA_PROCESS_LOOPBACK_MODE_INCLUDE_TARGET_PROCESS_TREE; - audioclientActivationParams.ProcessLoopbackParams.TargetProcessId = (DWORD)loopbackProcessID; - - ma_PropVariantInit(&activationParams); - activationParams.vt = MA_VT_BLOB; - activationParams.blob.cbSize = sizeof(audioclientActivationParams); - activationParams.blob.pBlobData = (BYTE*)&audioclientActivationParams; - pActivationParams = &activationParams; - - /* When requesting a specific device ID we need to use a special device ID. */ - MA_COPY_MEMORY(virtualDeviceID.wasapi, MA_VIRTUAL_AUDIO_DEVICE_PROCESS_LOOPBACK, (wcslen(MA_VIRTUAL_AUDIO_DEVICE_PROCESS_LOOPBACK) + 1) * sizeof(wchar_t)); /* +1 for the null terminator. */ - pDeviceID = &virtualDeviceID; - } else { - pActivationParams = NULL; /* No activation parameters required. */ - } - -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - result = ma_context_get_IAudioClient_Desktop__wasapi(pContext, deviceType, pDeviceID, pActivationParams, ppAudioClient, ppDeviceInterface); -#else - result = ma_context_get_IAudioClient_UWP__wasapi(pContext, deviceType, pDeviceID, pActivationParams, ppAudioClient, ppDeviceInterface); -#endif - - /* - If loopback mode was requested with a process ID and initialization failed, it could be because it's - trying to run on an older version of Windows where it's not supported. We need to let the caller - know about this with a log message. - */ - if (result != MA_SUCCESS) { - if (usingProcessLoopback) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Loopback mode requested to %s process ID %u, but initialization failed. Support for this feature begins with Windows 10 Build 20348. Confirm your version of Windows or consider not using process-specific loopback.\n", (loopbackProcessExclude) ? "exclude" : "include", loopbackProcessID); - } - } - - return result; -} - - -static ma_result ma_context_enumerate_devices__wasapi(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - /* Different enumeration for desktop and UWP. */ -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - /* Desktop */ - HRESULT hr; - ma_IMMDeviceEnumerator* pDeviceEnumerator; - - hr = ma_CoCreateInstance(pContext, MA_CLSID_MMDeviceEnumerator, NULL, CLSCTX_ALL, MA_IID_IMMDeviceEnumerator, (void**)&pDeviceEnumerator); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create device enumerator."); - return ma_result_from_HRESULT(hr); - } - - ma_context_enumerate_devices_by_type__wasapi(pContext, pDeviceEnumerator, ma_device_type_playback, callback, pUserData); - ma_context_enumerate_devices_by_type__wasapi(pContext, pDeviceEnumerator, ma_device_type_capture, callback, pUserData); - - ma_IMMDeviceEnumerator_Release(pDeviceEnumerator); -#else - /* - UWP - - The MMDevice API is only supported on desktop applications. For now, while I'm still figuring out how to properly enumerate - over devices without using MMDevice, I'm restricting devices to defaults. - - Hint: DeviceInformation::FindAllAsync() with DeviceClass.AudioCapture/AudioRender. https://blogs.windows.com/buildingapps/2014/05/15/real-time-audio-in-windows-store-and-windows-phone-apps/ - */ - if (callback) { - ma_bool32 cbResult = MA_TRUE; - - /* Playback. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - deviceInfo.isDefault = MA_TRUE; - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - - /* Capture. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - deviceInfo.isDefault = MA_TRUE; - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - } -#endif - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__wasapi(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - ma_result result; - ma_IMMDevice* pMMDevice = NULL; - WCHAR* pDefaultDeviceID = NULL; - - result = ma_context_get_MMDevice__wasapi(pContext, deviceType, pDeviceID, &pMMDevice); - if (result != MA_SUCCESS) { - return result; - } - - /* We need the default device ID so we can set the isDefault flag in the device info. */ - pDefaultDeviceID = ma_context_get_default_device_id__wasapi(pContext, deviceType); - - result = ma_context_get_device_info_from_MMDevice__wasapi(pContext, pMMDevice, pDefaultDeviceID, MA_FALSE, pDeviceInfo); /* MA_FALSE = !onlySimpleInfo. */ - - if (pDefaultDeviceID != NULL) { - ma_CoTaskMemFree(pContext, pDefaultDeviceID); - pDefaultDeviceID = NULL; - } - - ma_IMMDevice_Release(pMMDevice); - - return result; -#else - ma_IAudioClient* pAudioClient; - ma_result result; - - /* UWP currently only uses default devices. */ - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - result = ma_context_get_IAudioClient_UWP__wasapi(pContext, deviceType, pDeviceID, NULL, &pAudioClient, NULL); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_context_get_device_info_from_IAudioClient__wasapi(pContext, NULL, pAudioClient, pDeviceInfo); - - pDeviceInfo->isDefault = MA_TRUE; /* UWP only supports default devices. */ - - ma_IAudioClient_Release(pAudioClient); - return result; -#endif -} - -static ma_result ma_device_uninit__wasapi(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - if (pDevice->wasapi.pDeviceEnumerator) { - ((ma_IMMDeviceEnumerator*)pDevice->wasapi.pDeviceEnumerator)->lpVtbl->UnregisterEndpointNotificationCallback((ma_IMMDeviceEnumerator*)pDevice->wasapi.pDeviceEnumerator, &pDevice->wasapi.notificationClient); - ma_IMMDeviceEnumerator_Release((ma_IMMDeviceEnumerator*)pDevice->wasapi.pDeviceEnumerator); - } -#endif - - if (pDevice->wasapi.pRenderClient) { - if (pDevice->wasapi.pMappedBufferPlayback != NULL) { - ma_IAudioRenderClient_ReleaseBuffer((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient, pDevice->wasapi.mappedBufferPlaybackCap, 0); - pDevice->wasapi.pMappedBufferPlayback = NULL; - pDevice->wasapi.mappedBufferPlaybackCap = 0; - pDevice->wasapi.mappedBufferPlaybackLen = 0; - } - - ma_IAudioRenderClient_Release((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient); - } - if (pDevice->wasapi.pCaptureClient) { - if (pDevice->wasapi.pMappedBufferCapture != NULL) { - ma_IAudioCaptureClient_ReleaseBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, pDevice->wasapi.mappedBufferCaptureCap); - pDevice->wasapi.pMappedBufferCapture = NULL; - pDevice->wasapi.mappedBufferCaptureCap = 0; - pDevice->wasapi.mappedBufferCaptureLen = 0; - } - - ma_IAudioCaptureClient_Release((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient); - } - - if (pDevice->wasapi.pAudioClientPlayback) { - ma_IAudioClient_Release((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback); - } - if (pDevice->wasapi.pAudioClientCapture) { - ma_IAudioClient_Release((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - } - - if (pDevice->wasapi.hEventPlayback) { - CloseHandle((HANDLE)pDevice->wasapi.hEventPlayback); - } - if (pDevice->wasapi.hEventCapture) { - CloseHandle((HANDLE)pDevice->wasapi.hEventCapture); - } - - return MA_SUCCESS; -} - - -typedef struct -{ - /* Input. */ - ma_format formatIn; - ma_uint32 channelsIn; - ma_uint32 sampleRateIn; - ma_channel channelMapIn[MA_MAX_CHANNELS]; - ma_uint32 periodSizeInFramesIn; - ma_uint32 periodSizeInMillisecondsIn; - ma_uint32 periodsIn; - ma_share_mode shareMode; - ma_performance_profile performanceProfile; - ma_bool32 noAutoConvertSRC; - ma_bool32 noDefaultQualitySRC; - ma_bool32 noHardwareOffloading; - ma_uint32 loopbackProcessID; - ma_bool32 loopbackProcessExclude; - - /* Output. */ - ma_IAudioClient* pAudioClient; - ma_IAudioRenderClient* pRenderClient; - ma_IAudioCaptureClient* pCaptureClient; - ma_format formatOut; - ma_uint32 channelsOut; - ma_uint32 sampleRateOut; - ma_channel channelMapOut[MA_MAX_CHANNELS]; - ma_uint32 periodSizeInFramesOut; - ma_uint32 periodsOut; - ma_bool32 usingAudioClient3; - char deviceName[256]; - ma_device_id id; -} ma_device_init_internal_data__wasapi; - -static ma_result ma_device_init_internal__wasapi(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_init_internal_data__wasapi* pData) -{ - HRESULT hr; - ma_result result = MA_SUCCESS; - const char* errorMsg = ""; - MA_AUDCLNT_SHAREMODE shareMode = MA_AUDCLNT_SHAREMODE_SHARED; - DWORD streamFlags = 0; - MA_REFERENCE_TIME periodDurationInMicroseconds; - ma_bool32 wasInitializedUsingIAudioClient3 = MA_FALSE; - MA_WAVEFORMATEXTENSIBLE wf; - ma_WASAPIDeviceInterface* pDeviceInterface = NULL; - ma_IAudioClient2* pAudioClient2; - ma_uint32 nativeSampleRate; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pData != NULL); - - /* This function is only used to initialize one device type: either playback, capture or loopback. Never full-duplex. */ - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - pData->pAudioClient = NULL; - pData->pRenderClient = NULL; - pData->pCaptureClient = NULL; - - streamFlags = MA_AUDCLNT_STREAMFLAGS_EVENTCALLBACK; - if (!pData->noAutoConvertSRC && pData->sampleRateIn != 0 && pData->shareMode != ma_share_mode_exclusive) { /* <-- Exclusive streams must use the native sample rate. */ - streamFlags |= MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM; - } - if (!pData->noDefaultQualitySRC && pData->sampleRateIn != 0 && (streamFlags & MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM) != 0) { - streamFlags |= MA_AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY; - } - if (deviceType == ma_device_type_loopback) { - streamFlags |= MA_AUDCLNT_STREAMFLAGS_LOOPBACK; - } - - result = ma_context_get_IAudioClient__wasapi(pContext, deviceType, pDeviceID, pData->loopbackProcessID, pData->loopbackProcessExclude, &pData->pAudioClient, &pDeviceInterface); - if (result != MA_SUCCESS) { - goto done; - } - - MA_ZERO_OBJECT(&wf); - - /* Try enabling hardware offloading. */ - if (!pData->noHardwareOffloading) { - hr = ma_IAudioClient_QueryInterface(pData->pAudioClient, &MA_IID_IAudioClient2, (void**)&pAudioClient2); - if (SUCCEEDED(hr)) { - BOOL isHardwareOffloadingSupported = 0; - hr = ma_IAudioClient2_IsOffloadCapable(pAudioClient2, MA_AudioCategory_Other, &isHardwareOffloadingSupported); - if (SUCCEEDED(hr) && isHardwareOffloadingSupported) { - ma_AudioClientProperties clientProperties; - MA_ZERO_OBJECT(&clientProperties); - clientProperties.cbSize = sizeof(clientProperties); - clientProperties.bIsOffload = 1; - clientProperties.eCategory = MA_AudioCategory_Other; - ma_IAudioClient2_SetClientProperties(pAudioClient2, &clientProperties); - } - - pAudioClient2->lpVtbl->Release(pAudioClient2); - } - } - - /* Here is where we try to determine the best format to use with the device. If the client if wanting exclusive mode, first try finding the best format for that. If this fails, fall back to shared mode. */ - result = MA_FORMAT_NOT_SUPPORTED; - if (pData->shareMode == ma_share_mode_exclusive) { - #if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - /* In exclusive mode on desktop we always use the backend's native format. */ - ma_IPropertyStore* pStore = NULL; - hr = ma_IMMDevice_OpenPropertyStore(pDeviceInterface, STGM_READ, &pStore); - if (SUCCEEDED(hr)) { - MA_PROPVARIANT prop; - ma_PropVariantInit(&prop); - hr = ma_IPropertyStore_GetValue(pStore, &MA_PKEY_AudioEngine_DeviceFormat, &prop); - if (SUCCEEDED(hr)) { - MA_WAVEFORMATEX* pActualFormat = (MA_WAVEFORMATEX*)prop.blob.pBlobData; - hr = ma_IAudioClient_IsFormatSupported((ma_IAudioClient*)pData->pAudioClient, MA_AUDCLNT_SHAREMODE_EXCLUSIVE, pActualFormat, NULL); - if (SUCCEEDED(hr)) { - MA_COPY_MEMORY(&wf, pActualFormat, sizeof(MA_WAVEFORMATEXTENSIBLE)); - } - - ma_PropVariantClear(pContext, &prop); - } - - ma_IPropertyStore_Release(pStore); - } - #else - /* - I do not know how to query the device's native format on UWP so for now I'm just disabling support for - exclusive mode. The alternative is to enumerate over different formats and check IsFormatSupported() - until you find one that works. - - TODO: Add support for exclusive mode to UWP. - */ - hr = S_FALSE; - #endif - - if (hr == S_OK) { - shareMode = MA_AUDCLNT_SHAREMODE_EXCLUSIVE; - result = MA_SUCCESS; - } else { - result = MA_SHARE_MODE_NOT_SUPPORTED; - } - } else { - /* In shared mode we are always using the format reported by the operating system. */ - MA_WAVEFORMATEXTENSIBLE* pNativeFormat = NULL; - hr = ma_IAudioClient_GetMixFormat((ma_IAudioClient*)pData->pAudioClient, (MA_WAVEFORMATEX**)&pNativeFormat); - if (hr != S_OK) { - result = MA_FORMAT_NOT_SUPPORTED; - } else { - MA_COPY_MEMORY(&wf, pNativeFormat, sizeof(wf)); - result = MA_SUCCESS; - } - - ma_CoTaskMemFree(pContext, pNativeFormat); - - shareMode = MA_AUDCLNT_SHAREMODE_SHARED; - } - - /* Return an error if we still haven't found a format. */ - if (result != MA_SUCCESS) { - errorMsg = "[WASAPI] Failed to find best device mix format."; - goto done; - } - - /* - Override the native sample rate with the one requested by the caller, but only if we're not using the default sample rate. We'll use - WASAPI to perform the sample rate conversion. - */ - nativeSampleRate = wf.nSamplesPerSec; - if (streamFlags & MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM) { - wf.nSamplesPerSec = (pData->sampleRateIn != 0) ? pData->sampleRateIn : MA_DEFAULT_SAMPLE_RATE; - wf.nAvgBytesPerSec = wf.nSamplesPerSec * wf.nBlockAlign; - } - - pData->formatOut = ma_format_from_WAVEFORMATEX((MA_WAVEFORMATEX*)&wf); - if (pData->formatOut == ma_format_unknown) { - /* - The format isn't supported. This is almost certainly because the exclusive mode format isn't supported by miniaudio. We need to return MA_SHARE_MODE_NOT_SUPPORTED - in this case so that the caller can detect it and fall back to shared mode if desired. We should never get here if shared mode was requested, but just for - completeness we'll check for it and return MA_FORMAT_NOT_SUPPORTED. - */ - if (shareMode == MA_AUDCLNT_SHAREMODE_EXCLUSIVE) { - result = MA_SHARE_MODE_NOT_SUPPORTED; - } else { - result = MA_FORMAT_NOT_SUPPORTED; - } - - errorMsg = "[WASAPI] Native format not supported."; - goto done; - } - - pData->channelsOut = wf.nChannels; - pData->sampleRateOut = wf.nSamplesPerSec; - - /* Get the internal channel map based on the channel mask. */ - ma_channel_mask_to_channel_map__win32(wf.dwChannelMask, pData->channelsOut, pData->channelMapOut); - - /* Period size. */ - pData->periodsOut = (pData->periodsIn != 0) ? pData->periodsIn : MA_DEFAULT_PERIODS; - pData->periodSizeInFramesOut = pData->periodSizeInFramesIn; - if (pData->periodSizeInFramesOut == 0) { - if (pData->periodSizeInMillisecondsIn == 0) { - if (pData->performanceProfile == ma_performance_profile_low_latency) { - pData->periodSizeInFramesOut = ma_calculate_buffer_size_in_frames_from_milliseconds(MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_LOW_LATENCY, wf.nSamplesPerSec); - } else { - pData->periodSizeInFramesOut = ma_calculate_buffer_size_in_frames_from_milliseconds(MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE, wf.nSamplesPerSec); - } - } else { - pData->periodSizeInFramesOut = ma_calculate_buffer_size_in_frames_from_milliseconds(pData->periodSizeInMillisecondsIn, wf.nSamplesPerSec); - } - } - - periodDurationInMicroseconds = ((ma_uint64)pData->periodSizeInFramesOut * 1000 * 1000) / wf.nSamplesPerSec; - - - /* Slightly different initialization for shared and exclusive modes. We try exclusive mode first, and if it fails, fall back to shared mode. */ - if (shareMode == MA_AUDCLNT_SHAREMODE_EXCLUSIVE) { - MA_REFERENCE_TIME bufferDuration = periodDurationInMicroseconds * pData->periodsOut * 10; - - /* - If the periodicy is too small, Initialize() will fail with AUDCLNT_E_INVALID_DEVICE_PERIOD. In this case we should just keep increasing - it and trying it again. - */ - hr = E_FAIL; - for (;;) { - hr = ma_IAudioClient_Initialize((ma_IAudioClient*)pData->pAudioClient, shareMode, streamFlags, bufferDuration, bufferDuration, (MA_WAVEFORMATEX*)&wf, NULL); - if (hr == MA_AUDCLNT_E_INVALID_DEVICE_PERIOD) { - if (bufferDuration > 500*10000) { - break; - } else { - if (bufferDuration == 0) { /* <-- Just a sanity check to prevent an infinit loop. Should never happen, but it makes me feel better. */ - break; - } - - bufferDuration = bufferDuration * 2; - continue; - } - } else { - break; - } - } - - if (hr == MA_AUDCLNT_E_BUFFER_SIZE_NOT_ALIGNED) { - ma_uint32 bufferSizeInFrames; - hr = ma_IAudioClient_GetBufferSize((ma_IAudioClient*)pData->pAudioClient, &bufferSizeInFrames); - if (SUCCEEDED(hr)) { - bufferDuration = (MA_REFERENCE_TIME)((10000.0 * 1000 / wf.nSamplesPerSec * bufferSizeInFrames) + 0.5); - - /* Unfortunately we need to release and re-acquire the audio client according to MSDN. Seems silly - why not just call IAudioClient_Initialize() again?! */ - ma_IAudioClient_Release((ma_IAudioClient*)pData->pAudioClient); - - #if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - hr = ma_IMMDevice_Activate(pDeviceInterface, &MA_IID_IAudioClient, CLSCTX_ALL, NULL, (void**)&pData->pAudioClient); - #else - hr = ma_IUnknown_QueryInterface(pDeviceInterface, &MA_IID_IAudioClient, (void**)&pData->pAudioClient); - #endif - - if (SUCCEEDED(hr)) { - hr = ma_IAudioClient_Initialize((ma_IAudioClient*)pData->pAudioClient, shareMode, streamFlags, bufferDuration, bufferDuration, (MA_WAVEFORMATEX*)&wf, NULL); - } - } - } - - if (FAILED(hr)) { - /* Failed to initialize in exclusive mode. Don't fall back to shared mode - instead tell the client about it. They can reinitialize in shared mode if they want. */ - if (hr == E_ACCESSDENIED) { - errorMsg = "[WASAPI] Failed to initialize device in exclusive mode. Access denied.", result = MA_ACCESS_DENIED; - } else if (hr == MA_AUDCLNT_E_DEVICE_IN_USE) { - errorMsg = "[WASAPI] Failed to initialize device in exclusive mode. Device in use.", result = MA_BUSY; - } else { - errorMsg = "[WASAPI] Failed to initialize device in exclusive mode."; result = ma_result_from_HRESULT(hr); - } - goto done; - } - } - - if (shareMode == MA_AUDCLNT_SHAREMODE_SHARED) { - /* - Low latency shared mode via IAudioClient3. - - NOTE - ==== - Contrary to the documentation on MSDN (https://docs.microsoft.com/en-us/windows/win32/api/audioclient/nf-audioclient-iaudioclient3-initializesharedaudiostream), the - use of AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM and AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY with IAudioClient3_InitializeSharedAudioStream() absolutely does not work. Using - any of these flags will result in HRESULT code 0x88890021. The other problem is that calling IAudioClient3_GetSharedModeEnginePeriod() with a sample rate different to - that returned by IAudioClient_GetMixFormat() also results in an error. I'm therefore disabling low-latency shared mode with AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM. - */ - #ifndef MA_WASAPI_NO_LOW_LATENCY_SHARED_MODE - { - if ((streamFlags & MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM) == 0 || nativeSampleRate == wf.nSamplesPerSec) { - ma_IAudioClient3* pAudioClient3 = NULL; - hr = ma_IAudioClient_QueryInterface(pData->pAudioClient, &MA_IID_IAudioClient3, (void**)&pAudioClient3); - if (SUCCEEDED(hr)) { - ma_uint32 defaultPeriodInFrames; - ma_uint32 fundamentalPeriodInFrames; - ma_uint32 minPeriodInFrames; - ma_uint32 maxPeriodInFrames; - hr = ma_IAudioClient3_GetSharedModeEnginePeriod(pAudioClient3, (MA_WAVEFORMATEX*)&wf, &defaultPeriodInFrames, &fundamentalPeriodInFrames, &minPeriodInFrames, &maxPeriodInFrames); - if (SUCCEEDED(hr)) { - ma_uint32 desiredPeriodInFrames = pData->periodSizeInFramesOut; - ma_uint32 actualPeriodInFrames = desiredPeriodInFrames; - - /* Make sure the period size is a multiple of fundamentalPeriodInFrames. */ - actualPeriodInFrames = actualPeriodInFrames / fundamentalPeriodInFrames; - actualPeriodInFrames = actualPeriodInFrames * fundamentalPeriodInFrames; - - /* The period needs to be clamped between minPeriodInFrames and maxPeriodInFrames. */ - actualPeriodInFrames = ma_clamp(actualPeriodInFrames, minPeriodInFrames, maxPeriodInFrames); - - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[WASAPI] Trying IAudioClient3_InitializeSharedAudioStream(actualPeriodInFrames=%d)\n", actualPeriodInFrames); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " defaultPeriodInFrames=%d\n", defaultPeriodInFrames); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " fundamentalPeriodInFrames=%d\n", fundamentalPeriodInFrames); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " minPeriodInFrames=%d\n", minPeriodInFrames); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " maxPeriodInFrames=%d\n", maxPeriodInFrames); - - /* If the client requested a largish buffer than we don't actually want to use low latency shared mode because it forces small buffers. */ - if (actualPeriodInFrames >= desiredPeriodInFrames) { - /* - MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM | MA_AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY must not be in the stream flags. If either of these are specified, - IAudioClient3_InitializeSharedAudioStream() will fail. - */ - hr = ma_IAudioClient3_InitializeSharedAudioStream(pAudioClient3, streamFlags & ~(MA_AUDCLNT_STREAMFLAGS_AUTOCONVERTPCM | MA_AUDCLNT_STREAMFLAGS_SRC_DEFAULT_QUALITY), actualPeriodInFrames, (MA_WAVEFORMATEX*)&wf, NULL); - if (SUCCEEDED(hr)) { - wasInitializedUsingIAudioClient3 = MA_TRUE; - pData->periodSizeInFramesOut = actualPeriodInFrames; - - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[WASAPI] Using IAudioClient3\n"); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " periodSizeInFramesOut=%d\n", pData->periodSizeInFramesOut); - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[WASAPI] IAudioClient3_InitializeSharedAudioStream failed. Falling back to IAudioClient.\n"); - } - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[WASAPI] Not using IAudioClient3 because the desired period size is larger than the maximum supported by IAudioClient3.\n"); - } - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[WASAPI] IAudioClient3_GetSharedModeEnginePeriod failed. Falling back to IAudioClient.\n"); - } - - ma_IAudioClient3_Release(pAudioClient3); - pAudioClient3 = NULL; - } - } - } - #else - { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[WASAPI] Not using IAudioClient3 because MA_WASAPI_NO_LOW_LATENCY_SHARED_MODE is enabled.\n"); - } - #endif - - /* If we don't have an IAudioClient3 then we need to use the normal initialization routine. */ - if (!wasInitializedUsingIAudioClient3) { - MA_REFERENCE_TIME bufferDuration = periodDurationInMicroseconds * pData->periodsOut * 10; /* <-- Multiply by 10 for microseconds to 100-nanoseconds. */ - hr = ma_IAudioClient_Initialize((ma_IAudioClient*)pData->pAudioClient, shareMode, streamFlags, bufferDuration, 0, (const MA_WAVEFORMATEX*)&wf, NULL); - if (FAILED(hr)) { - if (hr == E_ACCESSDENIED) { - errorMsg = "[WASAPI] Failed to initialize device. Access denied.", result = MA_ACCESS_DENIED; - } else if (hr == MA_AUDCLNT_E_DEVICE_IN_USE) { - errorMsg = "[WASAPI] Failed to initialize device. Device in use.", result = MA_BUSY; - } else { - errorMsg = "[WASAPI] Failed to initialize device.", result = ma_result_from_HRESULT(hr); - } - - goto done; - } - } - } - - if (!wasInitializedUsingIAudioClient3) { - ma_uint32 bufferSizeInFrames; - hr = ma_IAudioClient_GetBufferSize((ma_IAudioClient*)pData->pAudioClient, &bufferSizeInFrames); - if (FAILED(hr)) { - errorMsg = "[WASAPI] Failed to get audio client's actual buffer size.", result = ma_result_from_HRESULT(hr); - goto done; - } - - pData->periodSizeInFramesOut = bufferSizeInFrames / pData->periodsOut; - } - - pData->usingAudioClient3 = wasInitializedUsingIAudioClient3; - - - if (deviceType == ma_device_type_playback) { - result = ma_device_create_IAudioClient_service__wasapi(pContext, deviceType, (ma_IAudioClient*)pData->pAudioClient, (void**)&pData->pRenderClient); - } else { - result = ma_device_create_IAudioClient_service__wasapi(pContext, deviceType, (ma_IAudioClient*)pData->pAudioClient, (void**)&pData->pCaptureClient); - } - - /*if (FAILED(hr)) {*/ - if (result != MA_SUCCESS) { - errorMsg = "[WASAPI] Failed to get audio client service."; - goto done; - } - - - /* Grab the name of the device. */ - #if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - { - ma_IPropertyStore *pProperties; - hr = ma_IMMDevice_OpenPropertyStore(pDeviceInterface, STGM_READ, &pProperties); - if (SUCCEEDED(hr)) { - MA_PROPVARIANT varName; - ma_PropVariantInit(&varName); - hr = ma_IPropertyStore_GetValue(pProperties, &MA_PKEY_Device_FriendlyName, &varName); - if (SUCCEEDED(hr)) { - WideCharToMultiByte(CP_UTF8, 0, varName.pwszVal, -1, pData->deviceName, sizeof(pData->deviceName), 0, FALSE); - ma_PropVariantClear(pContext, &varName); - } - - ma_IPropertyStore_Release(pProperties); - } - } - #endif - - /* - For the WASAPI backend we need to know the actual IDs of the device in order to do automatic - stream routing so that IDs can be compared and we can determine which device has been detached - and whether or not it matches with our ma_device. - */ - #if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - { - /* Desktop */ - ma_context_get_device_id_from_MMDevice__wasapi(pContext, pDeviceInterface, &pData->id); - } - #else - { - /* UWP */ - /* TODO: Implement me. Need to figure out how to get the ID of the default device. */ - } - #endif - -done: - /* Clean up. */ -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - if (pDeviceInterface != NULL) { - ma_IMMDevice_Release(pDeviceInterface); - } -#else - if (pDeviceInterface != NULL) { - ma_IUnknown_Release(pDeviceInterface); - } -#endif - - if (result != MA_SUCCESS) { - if (pData->pRenderClient) { - ma_IAudioRenderClient_Release((ma_IAudioRenderClient*)pData->pRenderClient); - pData->pRenderClient = NULL; - } - if (pData->pCaptureClient) { - ma_IAudioCaptureClient_Release((ma_IAudioCaptureClient*)pData->pCaptureClient); - pData->pCaptureClient = NULL; - } - if (pData->pAudioClient) { - ma_IAudioClient_Release((ma_IAudioClient*)pData->pAudioClient); - pData->pAudioClient = NULL; - } - - if (errorMsg != NULL && errorMsg[0] != '\0') { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "%s\n", errorMsg); - } - - return result; - } else { - return MA_SUCCESS; - } -} - -static ma_result ma_device_reinit__wasapi(ma_device* pDevice, ma_device_type deviceType) -{ - ma_device_init_internal_data__wasapi data; - ma_result result; - - MA_ASSERT(pDevice != NULL); - - /* We only re-initialize the playback or capture device. Never a full-duplex device. */ - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - - /* - Before reinitializing the device we need to free the previous audio clients. - - There's a known memory leak here. We will be calling this from the routing change callback that - is fired by WASAPI. If we attempt to release the IAudioClient we will deadlock. In my opinion - this is a bug. I'm not sure what I need to do to handle this cleanly, but I think we'll probably - need some system where we post an event, but delay the execution of it until the callback has - returned. I'm not sure how to do this reliably, however. I have set up some infrastructure for - a command thread which might be useful for this. - */ - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_loopback) { - if (pDevice->wasapi.pCaptureClient) { - ma_IAudioCaptureClient_Release((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient); - pDevice->wasapi.pCaptureClient = NULL; - } - - if (pDevice->wasapi.pAudioClientCapture) { - /*ma_device_release_IAudioClient_service__wasapi(pDevice, ma_device_type_capture);*/ - pDevice->wasapi.pAudioClientCapture = NULL; - } - } - - if (deviceType == ma_device_type_playback) { - if (pDevice->wasapi.pRenderClient) { - ma_IAudioRenderClient_Release((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient); - pDevice->wasapi.pRenderClient = NULL; - } - - if (pDevice->wasapi.pAudioClientPlayback) { - /*ma_device_release_IAudioClient_service__wasapi(pDevice, ma_device_type_playback);*/ - pDevice->wasapi.pAudioClientPlayback = NULL; - } - } - - - if (deviceType == ma_device_type_playback) { - data.formatIn = pDevice->playback.format; - data.channelsIn = pDevice->playback.channels; - MA_COPY_MEMORY(data.channelMapIn, pDevice->playback.channelMap, sizeof(pDevice->playback.channelMap)); - data.shareMode = pDevice->playback.shareMode; - } else { - data.formatIn = pDevice->capture.format; - data.channelsIn = pDevice->capture.channels; - MA_COPY_MEMORY(data.channelMapIn, pDevice->capture.channelMap, sizeof(pDevice->capture.channelMap)); - data.shareMode = pDevice->capture.shareMode; - } - - data.sampleRateIn = pDevice->sampleRate; - data.periodSizeInFramesIn = pDevice->wasapi.originalPeriodSizeInFrames; - data.periodSizeInMillisecondsIn = pDevice->wasapi.originalPeriodSizeInMilliseconds; - data.periodsIn = pDevice->wasapi.originalPeriods; - data.performanceProfile = pDevice->wasapi.originalPerformanceProfile; - data.noAutoConvertSRC = pDevice->wasapi.noAutoConvertSRC; - data.noDefaultQualitySRC = pDevice->wasapi.noDefaultQualitySRC; - data.noHardwareOffloading = pDevice->wasapi.noHardwareOffloading; - data.loopbackProcessID = pDevice->wasapi.loopbackProcessID; - data.loopbackProcessExclude = pDevice->wasapi.loopbackProcessExclude; - result = ma_device_init_internal__wasapi(pDevice->pContext, deviceType, NULL, &data); - if (result != MA_SUCCESS) { - return result; - } - - /* At this point we have some new objects ready to go. We need to uninitialize the previous ones and then set the new ones. */ - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_loopback) { - pDevice->wasapi.pAudioClientCapture = data.pAudioClient; - pDevice->wasapi.pCaptureClient = data.pCaptureClient; - - pDevice->capture.internalFormat = data.formatOut; - pDevice->capture.internalChannels = data.channelsOut; - pDevice->capture.internalSampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDevice->capture.internalChannelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDevice->capture.internalPeriodSizeInFrames = data.periodSizeInFramesOut; - pDevice->capture.internalPeriods = data.periodsOut; - ma_strcpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), data.deviceName); - - ma_IAudioClient_SetEventHandle((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture, (HANDLE)pDevice->wasapi.hEventCapture); - - pDevice->wasapi.periodSizeInFramesCapture = data.periodSizeInFramesOut; - ma_IAudioClient_GetBufferSize((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture, &pDevice->wasapi.actualBufferSizeInFramesCapture); - - /* We must always have a valid ID. */ - ma_strcpy_s_WCHAR(pDevice->capture.id.wasapi, sizeof(pDevice->capture.id.wasapi), data.id.wasapi); - } - - if (deviceType == ma_device_type_playback) { - pDevice->wasapi.pAudioClientPlayback = data.pAudioClient; - pDevice->wasapi.pRenderClient = data.pRenderClient; - - pDevice->playback.internalFormat = data.formatOut; - pDevice->playback.internalChannels = data.channelsOut; - pDevice->playback.internalSampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDevice->playback.internalChannelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDevice->playback.internalPeriodSizeInFrames = data.periodSizeInFramesOut; - pDevice->playback.internalPeriods = data.periodsOut; - ma_strcpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), data.deviceName); - - ma_IAudioClient_SetEventHandle((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback, (HANDLE)pDevice->wasapi.hEventPlayback); - - pDevice->wasapi.periodSizeInFramesPlayback = data.periodSizeInFramesOut; - ma_IAudioClient_GetBufferSize((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback, &pDevice->wasapi.actualBufferSizeInFramesPlayback); - - /* We must always have a valid ID because rerouting will look at it. */ - ma_strcpy_s_WCHAR(pDevice->playback.id.wasapi, sizeof(pDevice->playback.id.wasapi), data.id.wasapi); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_init__wasapi(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result = MA_SUCCESS; - -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - HRESULT hr; - ma_IMMDeviceEnumerator* pDeviceEnumerator; -#endif - - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->wasapi); - pDevice->wasapi.usage = pConfig->wasapi.usage; - pDevice->wasapi.noAutoConvertSRC = pConfig->wasapi.noAutoConvertSRC; - pDevice->wasapi.noDefaultQualitySRC = pConfig->wasapi.noDefaultQualitySRC; - pDevice->wasapi.noHardwareOffloading = pConfig->wasapi.noHardwareOffloading; - pDevice->wasapi.loopbackProcessID = pConfig->wasapi.loopbackProcessID; - pDevice->wasapi.loopbackProcessExclude = pConfig->wasapi.loopbackProcessExclude; - - /* Exclusive mode is not allowed with loopback. */ - if (pConfig->deviceType == ma_device_type_loopback && pConfig->playback.shareMode == ma_share_mode_exclusive) { - return MA_INVALID_DEVICE_CONFIG; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex || pConfig->deviceType == ma_device_type_loopback) { - ma_device_init_internal_data__wasapi data; - data.formatIn = pDescriptorCapture->format; - data.channelsIn = pDescriptorCapture->channels; - data.sampleRateIn = pDescriptorCapture->sampleRate; - MA_COPY_MEMORY(data.channelMapIn, pDescriptorCapture->channelMap, sizeof(pDescriptorCapture->channelMap)); - data.periodSizeInFramesIn = pDescriptorCapture->periodSizeInFrames; - data.periodSizeInMillisecondsIn = pDescriptorCapture->periodSizeInMilliseconds; - data.periodsIn = pDescriptorCapture->periodCount; - data.shareMode = pDescriptorCapture->shareMode; - data.performanceProfile = pConfig->performanceProfile; - data.noAutoConvertSRC = pConfig->wasapi.noAutoConvertSRC; - data.noDefaultQualitySRC = pConfig->wasapi.noDefaultQualitySRC; - data.noHardwareOffloading = pConfig->wasapi.noHardwareOffloading; - data.loopbackProcessID = pConfig->wasapi.loopbackProcessID; - data.loopbackProcessExclude = pConfig->wasapi.loopbackProcessExclude; - - result = ma_device_init_internal__wasapi(pDevice->pContext, (pConfig->deviceType == ma_device_type_loopback) ? ma_device_type_loopback : ma_device_type_capture, pDescriptorCapture->pDeviceID, &data); - if (result != MA_SUCCESS) { - return result; - } - - pDevice->wasapi.pAudioClientCapture = data.pAudioClient; - pDevice->wasapi.pCaptureClient = data.pCaptureClient; - pDevice->wasapi.originalPeriodSizeInMilliseconds = pDescriptorCapture->periodSizeInMilliseconds; - pDevice->wasapi.originalPeriodSizeInFrames = pDescriptorCapture->periodSizeInFrames; - pDevice->wasapi.originalPeriods = pDescriptorCapture->periodCount; - pDevice->wasapi.originalPerformanceProfile = pConfig->performanceProfile; - - /* - The event for capture needs to be manual reset for the same reason as playback. We keep the initial state set to unsignaled, - however, because we want to block until we actually have something for the first call to ma_device_read(). - */ - pDevice->wasapi.hEventCapture = (ma_handle)CreateEventA(NULL, FALSE, FALSE, NULL); /* Auto reset, unsignaled by default. */ - if (pDevice->wasapi.hEventCapture == NULL) { - result = ma_result_from_GetLastError(GetLastError()); - - if (pDevice->wasapi.pCaptureClient != NULL) { - ma_IAudioCaptureClient_Release((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient); - pDevice->wasapi.pCaptureClient = NULL; - } - if (pDevice->wasapi.pAudioClientCapture != NULL) { - ma_IAudioClient_Release((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - pDevice->wasapi.pAudioClientCapture = NULL; - } - - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create event for capture."); - return result; - } - ma_IAudioClient_SetEventHandle((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture, (HANDLE)pDevice->wasapi.hEventCapture); - - pDevice->wasapi.periodSizeInFramesCapture = data.periodSizeInFramesOut; - ma_IAudioClient_GetBufferSize((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture, &pDevice->wasapi.actualBufferSizeInFramesCapture); - - /* We must always have a valid ID. */ - ma_strcpy_s_WCHAR(pDevice->capture.id.wasapi, sizeof(pDevice->capture.id.wasapi), data.id.wasapi); - - /* The descriptor needs to be updated with actual values. */ - pDescriptorCapture->format = data.formatOut; - pDescriptorCapture->channels = data.channelsOut; - pDescriptorCapture->sampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDescriptorCapture->channelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDescriptorCapture->periodSizeInFrames = data.periodSizeInFramesOut; - pDescriptorCapture->periodCount = data.periodsOut; - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_device_init_internal_data__wasapi data; - data.formatIn = pDescriptorPlayback->format; - data.channelsIn = pDescriptorPlayback->channels; - data.sampleRateIn = pDescriptorPlayback->sampleRate; - MA_COPY_MEMORY(data.channelMapIn, pDescriptorPlayback->channelMap, sizeof(pDescriptorPlayback->channelMap)); - data.periodSizeInFramesIn = pDescriptorPlayback->periodSizeInFrames; - data.periodSizeInMillisecondsIn = pDescriptorPlayback->periodSizeInMilliseconds; - data.periodsIn = pDescriptorPlayback->periodCount; - data.shareMode = pDescriptorPlayback->shareMode; - data.performanceProfile = pConfig->performanceProfile; - data.noAutoConvertSRC = pConfig->wasapi.noAutoConvertSRC; - data.noDefaultQualitySRC = pConfig->wasapi.noDefaultQualitySRC; - data.noHardwareOffloading = pConfig->wasapi.noHardwareOffloading; - data.loopbackProcessID = pConfig->wasapi.loopbackProcessID; - data.loopbackProcessExclude = pConfig->wasapi.loopbackProcessExclude; - - result = ma_device_init_internal__wasapi(pDevice->pContext, ma_device_type_playback, pDescriptorPlayback->pDeviceID, &data); - if (result != MA_SUCCESS) { - if (pConfig->deviceType == ma_device_type_duplex) { - if (pDevice->wasapi.pCaptureClient != NULL) { - ma_IAudioCaptureClient_Release((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient); - pDevice->wasapi.pCaptureClient = NULL; - } - if (pDevice->wasapi.pAudioClientCapture != NULL) { - ma_IAudioClient_Release((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - pDevice->wasapi.pAudioClientCapture = NULL; - } - - CloseHandle((HANDLE)pDevice->wasapi.hEventCapture); - pDevice->wasapi.hEventCapture = NULL; - } - return result; - } - - pDevice->wasapi.pAudioClientPlayback = data.pAudioClient; - pDevice->wasapi.pRenderClient = data.pRenderClient; - pDevice->wasapi.originalPeriodSizeInMilliseconds = pDescriptorPlayback->periodSizeInMilliseconds; - pDevice->wasapi.originalPeriodSizeInFrames = pDescriptorPlayback->periodSizeInFrames; - pDevice->wasapi.originalPeriods = pDescriptorPlayback->periodCount; - pDevice->wasapi.originalPerformanceProfile = pConfig->performanceProfile; - - /* - The event for playback is needs to be manual reset because we want to explicitly control the fact that it becomes signalled - only after the whole available space has been filled, never before. - - The playback event also needs to be initially set to a signaled state so that the first call to ma_device_write() is able - to get passed WaitForMultipleObjects(). - */ - pDevice->wasapi.hEventPlayback = (ma_handle)CreateEventA(NULL, FALSE, TRUE, NULL); /* Auto reset, signaled by default. */ - if (pDevice->wasapi.hEventPlayback == NULL) { - result = ma_result_from_GetLastError(GetLastError()); - - if (pConfig->deviceType == ma_device_type_duplex) { - if (pDevice->wasapi.pCaptureClient != NULL) { - ma_IAudioCaptureClient_Release((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient); - pDevice->wasapi.pCaptureClient = NULL; - } - if (pDevice->wasapi.pAudioClientCapture != NULL) { - ma_IAudioClient_Release((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - pDevice->wasapi.pAudioClientCapture = NULL; - } - - CloseHandle((HANDLE)pDevice->wasapi.hEventCapture); - pDevice->wasapi.hEventCapture = NULL; - } - - if (pDevice->wasapi.pRenderClient != NULL) { - ma_IAudioRenderClient_Release((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient); - pDevice->wasapi.pRenderClient = NULL; - } - if (pDevice->wasapi.pAudioClientPlayback != NULL) { - ma_IAudioClient_Release((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback); - pDevice->wasapi.pAudioClientPlayback = NULL; - } - - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create event for playback."); - return result; - } - ma_IAudioClient_SetEventHandle((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback, (HANDLE)pDevice->wasapi.hEventPlayback); - - pDevice->wasapi.periodSizeInFramesPlayback = data.periodSizeInFramesOut; - ma_IAudioClient_GetBufferSize((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback, &pDevice->wasapi.actualBufferSizeInFramesPlayback); - - /* We must always have a valid ID because rerouting will look at it. */ - ma_strcpy_s_WCHAR(pDevice->playback.id.wasapi, sizeof(pDevice->playback.id.wasapi), data.id.wasapi); - - /* The descriptor needs to be updated with actual values. */ - pDescriptorPlayback->format = data.formatOut; - pDescriptorPlayback->channels = data.channelsOut; - pDescriptorPlayback->sampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDescriptorPlayback->channelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDescriptorPlayback->periodSizeInFrames = data.periodSizeInFramesOut; - pDescriptorPlayback->periodCount = data.periodsOut; - } - - /* - We need to register a notification client to detect when the device has been disabled, unplugged or re-routed (when the default device changes). When - we are connecting to the default device we want to do automatic stream routing when the device is disabled or unplugged. Otherwise we want to just - stop the device outright and let the application handle it. - */ -#if defined(MA_WIN32_DESKTOP) || defined(MA_WIN32_GDK) - if (pConfig->wasapi.noAutoStreamRouting == MA_FALSE) { - if ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex || pConfig->deviceType == ma_device_type_loopback) && pConfig->capture.pDeviceID == NULL) { - pDevice->wasapi.allowCaptureAutoStreamRouting = MA_TRUE; - } - if ((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pConfig->playback.pDeviceID == NULL) { - pDevice->wasapi.allowPlaybackAutoStreamRouting = MA_TRUE; - } - } - - ma_mutex_init(&pDevice->wasapi.rerouteLock); - - hr = ma_CoCreateInstance(pDevice->pContext, MA_CLSID_MMDeviceEnumerator, NULL, CLSCTX_ALL, MA_IID_IMMDeviceEnumerator, (void**)&pDeviceEnumerator); - if (FAILED(hr)) { - ma_device_uninit__wasapi(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to create device enumerator."); - return ma_result_from_HRESULT(hr); - } - - pDevice->wasapi.notificationClient.lpVtbl = (void*)&g_maNotificationCientVtbl; - pDevice->wasapi.notificationClient.counter = 1; - pDevice->wasapi.notificationClient.pDevice = pDevice; - - hr = pDeviceEnumerator->lpVtbl->RegisterEndpointNotificationCallback(pDeviceEnumerator, &pDevice->wasapi.notificationClient); - if (SUCCEEDED(hr)) { - pDevice->wasapi.pDeviceEnumerator = (ma_ptr)pDeviceEnumerator; - } else { - /* Not the end of the world if we fail to register the notification callback. We just won't support automatic stream routing. */ - ma_IMMDeviceEnumerator_Release(pDeviceEnumerator); - } -#endif - - ma_atomic_bool32_set(&pDevice->wasapi.isStartedCapture, MA_FALSE); - ma_atomic_bool32_set(&pDevice->wasapi.isStartedPlayback, MA_FALSE); - - return MA_SUCCESS; -} - -static ma_result ma_device__get_available_frames__wasapi(ma_device* pDevice, ma_IAudioClient* pAudioClient, ma_uint32* pFrameCount) -{ - ma_uint32 paddingFramesCount; - HRESULT hr; - ma_share_mode shareMode; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pFrameCount != NULL); - - *pFrameCount = 0; - - if ((ma_ptr)pAudioClient != pDevice->wasapi.pAudioClientPlayback && (ma_ptr)pAudioClient != pDevice->wasapi.pAudioClientCapture) { - return MA_INVALID_OPERATION; - } - - /* - I've had a report that GetCurrentPadding() is returning a frame count of 0 which is preventing - higher level function calls from doing anything because it thinks nothing is available. I have - taken a look at the documentation and it looks like this is unnecessary in exclusive mode. - - From Microsoft's documentation: - - For an exclusive-mode rendering or capture stream that was initialized with the - AUDCLNT_STREAMFLAGS_EVENTCALLBACK flag, the client typically has no use for the padding - value reported by GetCurrentPadding. Instead, the client accesses an entire buffer during - each processing pass. - - Considering this, I'm going to skip GetCurrentPadding() for exclusive mode and just report the - entire buffer. This depends on the caller making sure they wait on the event handler. - */ - shareMode = ((ma_ptr)pAudioClient == pDevice->wasapi.pAudioClientPlayback) ? pDevice->playback.shareMode : pDevice->capture.shareMode; - if (shareMode == ma_share_mode_shared) { - /* Shared mode. */ - hr = ma_IAudioClient_GetCurrentPadding(pAudioClient, &paddingFramesCount); - if (FAILED(hr)) { - return ma_result_from_HRESULT(hr); - } - - if ((ma_ptr)pAudioClient == pDevice->wasapi.pAudioClientPlayback) { - *pFrameCount = pDevice->wasapi.actualBufferSizeInFramesPlayback - paddingFramesCount; - } else { - *pFrameCount = paddingFramesCount; - } - } else { - /* Exclusive mode. */ - if ((ma_ptr)pAudioClient == pDevice->wasapi.pAudioClientPlayback) { - *pFrameCount = pDevice->wasapi.actualBufferSizeInFramesPlayback; - } else { - *pFrameCount = pDevice->wasapi.actualBufferSizeInFramesCapture; - } - } - - return MA_SUCCESS; -} - - -static ma_result ma_device_reroute__wasapi(ma_device* pDevice, ma_device_type deviceType) -{ - ma_result result; - - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "=== CHANGING DEVICE ===\n"); - - result = ma_device_reinit__wasapi(pDevice, deviceType); - if (result != MA_SUCCESS) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[WASAPI] Reinitializing device after route change failed.\n"); - return result; - } - - ma_device__post_init_setup(pDevice, deviceType); - ma_device__on_notification_rerouted(pDevice); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "=== DEVICE CHANGED ===\n"); - - return MA_SUCCESS; -} - -static ma_result ma_device_start__wasapi_nolock(ma_device* pDevice) -{ - HRESULT hr; - - if (pDevice->pContext->wasapi.hAvrt) { - const char* pTaskName = ma_to_usage_string__wasapi(pDevice->wasapi.usage); - if (pTaskName) { - DWORD idx = 0; - pDevice->wasapi.hAvrtHandle = (ma_handle)((MA_PFN_AvSetMmThreadCharacteristicsA)pDevice->pContext->wasapi.AvSetMmThreadCharacteristicsA)(pTaskName, &idx); - } - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex || pDevice->type == ma_device_type_loopback) { - hr = ma_IAudioClient_Start((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to start internal capture device."); - return ma_result_from_HRESULT(hr); - } - - ma_atomic_bool32_set(&pDevice->wasapi.isStartedCapture, MA_TRUE); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - hr = ma_IAudioClient_Start((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to start internal playback device."); - return ma_result_from_HRESULT(hr); - } - - ma_atomic_bool32_set(&pDevice->wasapi.isStartedPlayback, MA_TRUE); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__wasapi(ma_device* pDevice) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - /* Wait for any rerouting to finish before attempting to start the device. */ - ma_mutex_lock(&pDevice->wasapi.rerouteLock); - { - result = ma_device_start__wasapi_nolock(pDevice); - } - ma_mutex_unlock(&pDevice->wasapi.rerouteLock); - - return result; -} - -static ma_result ma_device_stop__wasapi_nolock(ma_device* pDevice) -{ - ma_result result; - HRESULT hr; - - MA_ASSERT(pDevice != NULL); - - if (pDevice->wasapi.hAvrtHandle) { - ((MA_PFN_AvRevertMmThreadCharacteristics)pDevice->pContext->wasapi.AvRevertMmThreadcharacteristics)((HANDLE)pDevice->wasapi.hAvrtHandle); - pDevice->wasapi.hAvrtHandle = NULL; - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex || pDevice->type == ma_device_type_loopback) { - hr = ma_IAudioClient_Stop((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to stop internal capture device."); - return ma_result_from_HRESULT(hr); - } - - /* The audio client needs to be reset otherwise restarting will fail. */ - hr = ma_IAudioClient_Reset((ma_IAudioClient*)pDevice->wasapi.pAudioClientCapture); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to reset internal capture device."); - return ma_result_from_HRESULT(hr); - } - - /* If we have a mapped buffer we need to release it. */ - if (pDevice->wasapi.pMappedBufferCapture != NULL) { - ma_IAudioCaptureClient_ReleaseBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, pDevice->wasapi.mappedBufferCaptureCap); - pDevice->wasapi.pMappedBufferCapture = NULL; - pDevice->wasapi.mappedBufferCaptureCap = 0; - pDevice->wasapi.mappedBufferCaptureLen = 0; - } - - ma_atomic_bool32_set(&pDevice->wasapi.isStartedCapture, MA_FALSE); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - /* - The buffer needs to be drained before stopping the device. Not doing this will result in the last few frames not getting output to - the speakers. This is a problem for very short sounds because it'll result in a significant portion of it not getting played. - */ - if (ma_atomic_bool32_get(&pDevice->wasapi.isStartedPlayback)) { - /* We need to make sure we put a timeout here or else we'll risk getting stuck in a deadlock in some cases. */ - DWORD waitTime = pDevice->wasapi.actualBufferSizeInFramesPlayback / pDevice->playback.internalSampleRate; - - if (pDevice->playback.shareMode == ma_share_mode_exclusive) { - WaitForSingleObject((HANDLE)pDevice->wasapi.hEventPlayback, waitTime); - } - else { - ma_uint32 prevFramesAvaialablePlayback = (ma_uint32)-1; - ma_uint32 framesAvailablePlayback; - for (;;) { - result = ma_device__get_available_frames__wasapi(pDevice, (ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback, &framesAvailablePlayback); - if (result != MA_SUCCESS) { - break; - } - - if (framesAvailablePlayback >= pDevice->wasapi.actualBufferSizeInFramesPlayback) { - break; - } - - /* - Just a safety check to avoid an infinite loop. If this iteration results in a situation where the number of available frames - has not changed, get out of the loop. I don't think this should ever happen, but I think it's nice to have just in case. - */ - if (framesAvailablePlayback == prevFramesAvaialablePlayback) { - break; - } - prevFramesAvaialablePlayback = framesAvailablePlayback; - - WaitForSingleObject((HANDLE)pDevice->wasapi.hEventPlayback, waitTime * 1000); - ResetEvent((HANDLE)pDevice->wasapi.hEventPlayback); /* Manual reset. */ - } - } - } - - hr = ma_IAudioClient_Stop((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to stop internal playback device."); - return ma_result_from_HRESULT(hr); - } - - /* The audio client needs to be reset otherwise restarting will fail. */ - hr = ma_IAudioClient_Reset((ma_IAudioClient*)pDevice->wasapi.pAudioClientPlayback); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to reset internal playback device."); - return ma_result_from_HRESULT(hr); - } - - if (pDevice->wasapi.pMappedBufferPlayback != NULL) { - ma_IAudioRenderClient_ReleaseBuffer((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient, pDevice->wasapi.mappedBufferPlaybackCap, 0); - pDevice->wasapi.pMappedBufferPlayback = NULL; - pDevice->wasapi.mappedBufferPlaybackCap = 0; - pDevice->wasapi.mappedBufferPlaybackLen = 0; - } - - ma_atomic_bool32_set(&pDevice->wasapi.isStartedPlayback, MA_FALSE); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__wasapi(ma_device* pDevice) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - /* Wait for any rerouting to finish before attempting to stop the device. */ - ma_mutex_lock(&pDevice->wasapi.rerouteLock); - { - result = ma_device_stop__wasapi_nolock(pDevice); - } - ma_mutex_unlock(&pDevice->wasapi.rerouteLock); - - return result; -} - - -#ifndef MA_WASAPI_WAIT_TIMEOUT_MILLISECONDS -#define MA_WASAPI_WAIT_TIMEOUT_MILLISECONDS 5000 -#endif - -static ma_result ma_device_read__wasapi(ma_device* pDevice, void* pFrames, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint32 totalFramesProcessed = 0; - - /* - When reading, we need to get a buffer and process all of it before releasing it. Because the - frame count (frameCount) can be different to the size of the buffer, we'll need to cache the - pointer to the buffer. - */ - - /* Keep running until we've processed the requested number of frames. */ - while (ma_device_get_state(pDevice) == ma_device_state_started && totalFramesProcessed < frameCount) { - ma_uint32 framesRemaining = frameCount - totalFramesProcessed; - - /* If we have a mapped data buffer, consume that first. */ - if (pDevice->wasapi.pMappedBufferCapture != NULL) { - /* We have a cached data pointer so consume that before grabbing another one from WASAPI. */ - ma_uint32 framesToProcessNow = framesRemaining; - if (framesToProcessNow > pDevice->wasapi.mappedBufferCaptureLen) { - framesToProcessNow = pDevice->wasapi.mappedBufferCaptureLen; - } - - /* Now just copy the data over to the output buffer. */ - ma_copy_pcm_frames( - ma_offset_pcm_frames_ptr(pFrames, totalFramesProcessed, pDevice->capture.internalFormat, pDevice->capture.internalChannels), - ma_offset_pcm_frames_const_ptr(pDevice->wasapi.pMappedBufferCapture, pDevice->wasapi.mappedBufferCaptureCap - pDevice->wasapi.mappedBufferCaptureLen, pDevice->capture.internalFormat, pDevice->capture.internalChannels), - framesToProcessNow, - pDevice->capture.internalFormat, pDevice->capture.internalChannels - ); - - totalFramesProcessed += framesToProcessNow; - pDevice->wasapi.mappedBufferCaptureLen -= framesToProcessNow; - - /* If the data buffer has been fully consumed we need to release it. */ - if (pDevice->wasapi.mappedBufferCaptureLen == 0) { - ma_IAudioCaptureClient_ReleaseBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, pDevice->wasapi.mappedBufferCaptureCap); - pDevice->wasapi.pMappedBufferCapture = NULL; - pDevice->wasapi.mappedBufferCaptureCap = 0; - } - } else { - /* We don't have any cached data pointer, so grab another one. */ - HRESULT hr; - DWORD flags = 0; - - /* First just ask WASAPI for a data buffer. If it's not available, we'll wait for more. */ - hr = ma_IAudioCaptureClient_GetBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, (BYTE**)&pDevice->wasapi.pMappedBufferCapture, &pDevice->wasapi.mappedBufferCaptureCap, &flags, NULL, NULL); - if (hr == S_OK) { - /* We got a data buffer. Continue to the next loop iteration which will then read from the mapped pointer. */ - pDevice->wasapi.mappedBufferCaptureLen = pDevice->wasapi.mappedBufferCaptureCap; - - /* - There have been reports that indicate that at times the AUDCLNT_BUFFERFLAGS_DATA_DISCONTINUITY is reported for every - call to IAudioCaptureClient_GetBuffer() above which results in spamming of the debug messages below. To partially - work around this, I'm only outputting these messages when MA_DEBUG_OUTPUT is explicitly defined. The better solution - would be to figure out why the flag is always getting reported. - */ - #if defined(MA_DEBUG_OUTPUT) - { - if (flags != 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Capture Flags: %ld\n", flags); - - if ((flags & MA_AUDCLNT_BUFFERFLAGS_DATA_DISCONTINUITY) != 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Data discontinuity (possible overrun). Attempting recovery. mappedBufferCaptureCap=%d\n", pDevice->wasapi.mappedBufferCaptureCap); - } - } - } - #endif - - /* Overrun detection. */ - if ((flags & MA_AUDCLNT_BUFFERFLAGS_DATA_DISCONTINUITY) != 0) { - /* Glitched. Probably due to an overrun. */ - - /* - If we got an overrun it probably means we're straddling the end of the buffer. In normal capture - mode this is the fault of the client application because they're responsible for ensuring data is - processed fast enough. In duplex mode, however, the processing of audio is tied to the playback - device, so this can possibly be the result of a timing de-sync. - - In capture mode we're not going to do any kind of recovery because the real fix is for the client - application to process faster. In duplex mode, we'll treat this as a desync and reset the buffers - to prevent a never-ending sequence of glitches due to straddling the end of the buffer. - */ - if (pDevice->type == ma_device_type_duplex) { - /* - Experiment: - - If we empty out the *entire* buffer we may end up putting ourselves into an underrun position - which isn't really any better than the overrun we're probably in right now. Instead we'll just - empty out about half. - */ - ma_uint32 i; - ma_uint32 periodCount = (pDevice->wasapi.actualBufferSizeInFramesCapture / pDevice->wasapi.periodSizeInFramesCapture); - ma_uint32 iterationCount = periodCount / 2; - if ((periodCount % 2) > 0) { - iterationCount += 1; - } - - for (i = 0; i < iterationCount; i += 1) { - hr = ma_IAudioCaptureClient_ReleaseBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, pDevice->wasapi.mappedBufferCaptureCap); - if (FAILED(hr)) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Data discontinuity recovery: IAudioCaptureClient_ReleaseBuffer() failed with %ld.\n", hr); - break; - } - - flags = 0; - hr = ma_IAudioCaptureClient_GetBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, (BYTE**)&pDevice->wasapi.pMappedBufferCapture, &pDevice->wasapi.mappedBufferCaptureCap, &flags, NULL, NULL); - if (hr == MA_AUDCLNT_S_BUFFER_EMPTY || FAILED(hr)) { - /* - The buffer has been completely emptied or an error occurred. In this case we'll need - to reset the state of the mapped buffer which will trigger the next iteration to get - a fresh buffer from WASAPI. - */ - pDevice->wasapi.pMappedBufferCapture = NULL; - pDevice->wasapi.mappedBufferCaptureCap = 0; - pDevice->wasapi.mappedBufferCaptureLen = 0; - - if (hr == MA_AUDCLNT_S_BUFFER_EMPTY) { - if ((flags & MA_AUDCLNT_BUFFERFLAGS_DATA_DISCONTINUITY) != 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Data discontinuity recovery: Buffer emptied, and data discontinuity still reported.\n"); - } else { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Data discontinuity recovery: Buffer emptied.\n"); - } - } - - if (FAILED(hr)) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[WASAPI] Data discontinuity recovery: IAudioCaptureClient_GetBuffer() failed with %ld.\n", hr); - } - - break; - } - } - - /* If at this point we have a valid buffer mapped, make sure the buffer length is set appropriately. */ - if (pDevice->wasapi.pMappedBufferCapture != NULL) { - pDevice->wasapi.mappedBufferCaptureLen = pDevice->wasapi.mappedBufferCaptureCap; - } - } - } - - continue; - } else { - if (hr == MA_AUDCLNT_S_BUFFER_EMPTY || hr == MA_AUDCLNT_E_BUFFER_ERROR) { - /* - No data is available. We need to wait for more. There's two situations to consider - here. The first is normal capture mode. If this times out it probably means the - microphone isn't delivering data for whatever reason. In this case we'll just - abort the read and return whatever we were able to get. The other situations is - loopback mode, in which case a timeout probably just means the nothing is playing - through the speakers. - */ - - /* Experiment: Use a shorter timeout for loopback mode. */ - DWORD timeoutInMilliseconds = MA_WASAPI_WAIT_TIMEOUT_MILLISECONDS; - if (pDevice->type == ma_device_type_loopback) { - timeoutInMilliseconds = 10; - } - - if (WaitForSingleObject((HANDLE)pDevice->wasapi.hEventCapture, timeoutInMilliseconds) != WAIT_OBJECT_0) { - if (pDevice->type == ma_device_type_loopback) { - continue; /* Keep waiting in loopback mode. */ - } else { - result = MA_ERROR; - break; /* Wait failed. */ - } - } - - /* At this point we should be able to loop back to the start of the loop and try retrieving a data buffer again. */ - } else { - /* An error occured and we need to abort. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to retrieve internal buffer from capture device in preparation for reading from the device. HRESULT = %d. Stopping device.\n", (int)hr); - result = ma_result_from_HRESULT(hr); - break; - } - } - } - } - - /* - If we were unable to process the entire requested frame count, but we still have a mapped buffer, - there's a good chance either an error occurred or the device was stopped mid-read. In this case - we'll need to make sure the buffer is released. - */ - if (totalFramesProcessed < frameCount && pDevice->wasapi.pMappedBufferCapture != NULL) { - ma_IAudioCaptureClient_ReleaseBuffer((ma_IAudioCaptureClient*)pDevice->wasapi.pCaptureClient, pDevice->wasapi.mappedBufferCaptureCap); - pDevice->wasapi.pMappedBufferCapture = NULL; - pDevice->wasapi.mappedBufferCaptureCap = 0; - pDevice->wasapi.mappedBufferCaptureLen = 0; - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesProcessed; - } - - return result; -} - -static ma_result ma_device_write__wasapi(ma_device* pDevice, const void* pFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - ma_result result = MA_SUCCESS; - ma_uint32 totalFramesProcessed = 0; - - /* Keep writing to the device until it's stopped or we've consumed all of our input. */ - while (ma_device_get_state(pDevice) == ma_device_state_started && totalFramesProcessed < frameCount) { - ma_uint32 framesRemaining = frameCount - totalFramesProcessed; - - /* - We're going to do this in a similar way to capture. We'll first check if the cached data pointer - is valid, and if so, read from that. Otherwise We will call IAudioRenderClient_GetBuffer() with - a requested buffer size equal to our actual period size. If it returns AUDCLNT_E_BUFFER_TOO_LARGE - it means we need to wait for some data to become available. - */ - if (pDevice->wasapi.pMappedBufferPlayback != NULL) { - /* We still have some space available in the mapped data buffer. Write to it. */ - ma_uint32 framesToProcessNow = framesRemaining; - if (framesToProcessNow > (pDevice->wasapi.mappedBufferPlaybackCap - pDevice->wasapi.mappedBufferPlaybackLen)) { - framesToProcessNow = (pDevice->wasapi.mappedBufferPlaybackCap - pDevice->wasapi.mappedBufferPlaybackLen); - } - - /* Now just copy the data over to the output buffer. */ - ma_copy_pcm_frames( - ma_offset_pcm_frames_ptr(pDevice->wasapi.pMappedBufferPlayback, pDevice->wasapi.mappedBufferPlaybackLen, pDevice->playback.internalFormat, pDevice->playback.internalChannels), - ma_offset_pcm_frames_const_ptr(pFrames, totalFramesProcessed, pDevice->playback.internalFormat, pDevice->playback.internalChannels), - framesToProcessNow, - pDevice->playback.internalFormat, pDevice->playback.internalChannels - ); - - totalFramesProcessed += framesToProcessNow; - pDevice->wasapi.mappedBufferPlaybackLen += framesToProcessNow; - - /* If the data buffer has been fully consumed we need to release it. */ - if (pDevice->wasapi.mappedBufferPlaybackLen == pDevice->wasapi.mappedBufferPlaybackCap) { - ma_IAudioRenderClient_ReleaseBuffer((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient, pDevice->wasapi.mappedBufferPlaybackCap, 0); - pDevice->wasapi.pMappedBufferPlayback = NULL; - pDevice->wasapi.mappedBufferPlaybackCap = 0; - pDevice->wasapi.mappedBufferPlaybackLen = 0; - - /* - In exclusive mode we need to wait here. Exclusive mode is weird because GetBuffer() never - seems to return AUDCLNT_E_BUFFER_TOO_LARGE, which is what we normally use to determine - whether or not we need to wait for more data. - */ - if (pDevice->playback.shareMode == ma_share_mode_exclusive) { - if (WaitForSingleObject((HANDLE)pDevice->wasapi.hEventPlayback, MA_WASAPI_WAIT_TIMEOUT_MILLISECONDS) != WAIT_OBJECT_0) { - result = MA_ERROR; - break; /* Wait failed. Probably timed out. */ - } - } - } - } else { - /* We don't have a mapped data buffer so we'll need to get one. */ - HRESULT hr; - ma_uint32 bufferSizeInFrames; - - /* Special rules for exclusive mode. */ - if (pDevice->playback.shareMode == ma_share_mode_exclusive) { - bufferSizeInFrames = pDevice->wasapi.actualBufferSizeInFramesPlayback; - } else { - bufferSizeInFrames = pDevice->wasapi.periodSizeInFramesPlayback; - } - - hr = ma_IAudioRenderClient_GetBuffer((ma_IAudioRenderClient*)pDevice->wasapi.pRenderClient, bufferSizeInFrames, (BYTE**)&pDevice->wasapi.pMappedBufferPlayback); - if (hr == S_OK) { - /* We have data available. */ - pDevice->wasapi.mappedBufferPlaybackCap = bufferSizeInFrames; - pDevice->wasapi.mappedBufferPlaybackLen = 0; - } else { - if (hr == MA_AUDCLNT_E_BUFFER_TOO_LARGE || hr == MA_AUDCLNT_E_BUFFER_ERROR) { - /* Not enough data available. We need to wait for more. */ - if (WaitForSingleObject((HANDLE)pDevice->wasapi.hEventPlayback, MA_WASAPI_WAIT_TIMEOUT_MILLISECONDS) != WAIT_OBJECT_0) { - result = MA_ERROR; - break; /* Wait failed. Probably timed out. */ - } - } else { - /* Some error occurred. We'll need to abort. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WASAPI] Failed to retrieve internal buffer from playback device in preparation for writing to the device. HRESULT = %d. Stopping device.\n", (int)hr); - result = ma_result_from_HRESULT(hr); - break; - } - } - } - } - - if (pFramesWritten != NULL) { - *pFramesWritten = totalFramesProcessed; - } - - return result; -} - -static ma_result ma_device_data_loop_wakeup__wasapi(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex || pDevice->type == ma_device_type_loopback) { - SetEvent((HANDLE)pDevice->wasapi.hEventCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - SetEvent((HANDLE)pDevice->wasapi.hEventPlayback); - } - - return MA_SUCCESS; -} - - -static ma_result ma_context_uninit__wasapi(ma_context* pContext) -{ - ma_context_command__wasapi cmd = ma_context_init_command__wasapi(MA_CONTEXT_COMMAND_QUIT__WASAPI); - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_wasapi); - - ma_context_post_command__wasapi(pContext, &cmd); - ma_thread_wait(&pContext->wasapi.commandThread); - - if (pContext->wasapi.hAvrt) { - ma_dlclose(pContext, pContext->wasapi.hAvrt); - pContext->wasapi.hAvrt = NULL; - } - - #if defined(MA_WIN32_UWP) - { - if (pContext->wasapi.hMMDevapi) { - ma_dlclose(pContext, pContext->wasapi.hMMDevapi); - pContext->wasapi.hMMDevapi = NULL; - } - } - #endif - - /* Only after the thread has been terminated can we uninitialize the sync objects for the command thread. */ - ma_semaphore_uninit(&pContext->wasapi.commandSem); - ma_mutex_uninit(&pContext->wasapi.commandLock); - - return MA_SUCCESS; -} - -static ma_result ma_context_init__wasapi(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - ma_result result = MA_SUCCESS; - - MA_ASSERT(pContext != NULL); - - (void)pConfig; - -#ifdef MA_WIN32_DESKTOP - /* - WASAPI is only supported in Vista SP1 and newer. The reason for SP1 and not the base version of Vista is that event-driven - exclusive mode does not work until SP1. - - Unfortunately older compilers don't define these functions so we need to dynamically load them in order to avoid a link error. - */ - { - ma_OSVERSIONINFOEXW osvi; - ma_handle kernel32DLL; - ma_PFNVerifyVersionInfoW _VerifyVersionInfoW; - ma_PFNVerSetConditionMask _VerSetConditionMask; - - kernel32DLL = ma_dlopen(pContext, "kernel32.dll"); - if (kernel32DLL == NULL) { - return MA_NO_BACKEND; - } - - _VerifyVersionInfoW = (ma_PFNVerifyVersionInfoW )ma_dlsym(pContext, kernel32DLL, "VerifyVersionInfoW"); - _VerSetConditionMask = (ma_PFNVerSetConditionMask)ma_dlsym(pContext, kernel32DLL, "VerSetConditionMask"); - if (_VerifyVersionInfoW == NULL || _VerSetConditionMask == NULL) { - ma_dlclose(pContext, kernel32DLL); - return MA_NO_BACKEND; - } - - MA_ZERO_OBJECT(&osvi); - osvi.dwOSVersionInfoSize = sizeof(osvi); - osvi.dwMajorVersion = ((MA_WIN32_WINNT_VISTA >> 8) & 0xFF); - osvi.dwMinorVersion = ((MA_WIN32_WINNT_VISTA >> 0) & 0xFF); - osvi.wServicePackMajor = 1; - if (_VerifyVersionInfoW(&osvi, MA_VER_MAJORVERSION | MA_VER_MINORVERSION | MA_VER_SERVICEPACKMAJOR, _VerSetConditionMask(_VerSetConditionMask(_VerSetConditionMask(0, MA_VER_MAJORVERSION, MA_VER_GREATER_EQUAL), MA_VER_MINORVERSION, MA_VER_GREATER_EQUAL), MA_VER_SERVICEPACKMAJOR, MA_VER_GREATER_EQUAL))) { - result = MA_SUCCESS; - } else { - result = MA_NO_BACKEND; - } - - ma_dlclose(pContext, kernel32DLL); - } -#endif - - if (result != MA_SUCCESS) { - return result; - } - - MA_ZERO_OBJECT(&pContext->wasapi); - - /* - Annoyingly, WASAPI does not allow you to release an IAudioClient object from a different thread - than the one that retrieved it with GetService(). This can result in a deadlock in two - situations: - - 1) When calling ma_device_uninit() from a different thread to ma_device_init(); and - 2) When uninitializing and reinitializing the internal IAudioClient object in response to - automatic stream routing. - - We could define ma_device_uninit() such that it must be called on the same thread as - ma_device_init(). We could also just not release the IAudioClient when performing automatic - stream routing to avoid the deadlock. Neither of these are acceptable solutions in my view so - we're going to have to work around this with a worker thread. This is not ideal, but I can't - think of a better way to do this. - - More information about this can be found here: - - https://docs.microsoft.com/en-us/windows/win32/api/audioclient/nn-audioclient-iaudiorenderclient - - Note this section: - - When releasing an IAudioRenderClient interface instance, the client must call the interface's - Release method from the same thread as the call to IAudioClient::GetService that created the - object. - */ - { - result = ma_mutex_init(&pContext->wasapi.commandLock); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_semaphore_init(0, &pContext->wasapi.commandSem); - if (result != MA_SUCCESS) { - ma_mutex_uninit(&pContext->wasapi.commandLock); - return result; - } - - result = ma_thread_create(&pContext->wasapi.commandThread, ma_thread_priority_normal, 0, ma_context_command_thread__wasapi, pContext, &pContext->allocationCallbacks); - if (result != MA_SUCCESS) { - ma_semaphore_uninit(&pContext->wasapi.commandSem); - ma_mutex_uninit(&pContext->wasapi.commandLock); - return result; - } - - #if defined(MA_WIN32_UWP) - { - /* Link to mmdevapi so we can get access to ActivateAudioInterfaceAsync(). */ - pContext->wasapi.hMMDevapi = ma_dlopen(pContext, "mmdevapi.dll"); - if (pContext->wasapi.hMMDevapi) { - pContext->wasapi.ActivateAudioInterfaceAsync = ma_dlsym(pContext, pContext->wasapi.hMMDevapi, "ActivateAudioInterfaceAsync"); - if (pContext->wasapi.ActivateAudioInterfaceAsync == NULL) { - ma_semaphore_uninit(&pContext->wasapi.commandSem); - ma_mutex_uninit(&pContext->wasapi.commandLock); - ma_dlclose(pContext, pContext->wasapi.hMMDevapi); - return MA_NO_BACKEND; /* ActivateAudioInterfaceAsync() could not be loaded. */ - } - } else { - ma_semaphore_uninit(&pContext->wasapi.commandSem); - ma_mutex_uninit(&pContext->wasapi.commandLock); - return MA_NO_BACKEND; /* Failed to load mmdevapi.dll which is required for ActivateAudioInterfaceAsync() */ - } - } - #endif - - /* Optionally use the Avrt API to specify the audio thread's latency sensitivity requirements */ - pContext->wasapi.hAvrt = ma_dlopen(pContext, "avrt.dll"); - if (pContext->wasapi.hAvrt) { - pContext->wasapi.AvSetMmThreadCharacteristicsA = ma_dlsym(pContext, pContext->wasapi.hAvrt, "AvSetMmThreadCharacteristicsA"); - pContext->wasapi.AvRevertMmThreadcharacteristics = ma_dlsym(pContext, pContext->wasapi.hAvrt, "AvRevertMmThreadCharacteristics"); - - /* If either function could not be found, disable use of avrt entirely. */ - if (!pContext->wasapi.AvSetMmThreadCharacteristicsA || !pContext->wasapi.AvRevertMmThreadcharacteristics) { - pContext->wasapi.AvSetMmThreadCharacteristicsA = NULL; - pContext->wasapi.AvRevertMmThreadcharacteristics = NULL; - ma_dlclose(pContext, pContext->wasapi.hAvrt); - pContext->wasapi.hAvrt = NULL; - } - } - } - - - pCallbacks->onContextInit = ma_context_init__wasapi; - pCallbacks->onContextUninit = ma_context_uninit__wasapi; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__wasapi; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__wasapi; - pCallbacks->onDeviceInit = ma_device_init__wasapi; - pCallbacks->onDeviceUninit = ma_device_uninit__wasapi; - pCallbacks->onDeviceStart = ma_device_start__wasapi; - pCallbacks->onDeviceStop = ma_device_stop__wasapi; - pCallbacks->onDeviceRead = ma_device_read__wasapi; - pCallbacks->onDeviceWrite = ma_device_write__wasapi; - pCallbacks->onDeviceDataLoop = NULL; - pCallbacks->onDeviceDataLoopWakeup = ma_device_data_loop_wakeup__wasapi; - - return MA_SUCCESS; -} -#endif - -/****************************************************************************** - -DirectSound Backend - -******************************************************************************/ -#ifdef MA_HAS_DSOUND -/*#include */ - -/*static const GUID MA_GUID_IID_DirectSoundNotify = {0xb0210783, 0x89cd, 0x11d0, {0xaf, 0x08, 0x00, 0xa0, 0xc9, 0x25, 0xcd, 0x16}};*/ - -/* miniaudio only uses priority or exclusive modes. */ -#define MA_DSSCL_NORMAL 1 -#define MA_DSSCL_PRIORITY 2 -#define MA_DSSCL_EXCLUSIVE 3 -#define MA_DSSCL_WRITEPRIMARY 4 - -#define MA_DSCAPS_PRIMARYMONO 0x00000001 -#define MA_DSCAPS_PRIMARYSTEREO 0x00000002 -#define MA_DSCAPS_PRIMARY8BIT 0x00000004 -#define MA_DSCAPS_PRIMARY16BIT 0x00000008 -#define MA_DSCAPS_CONTINUOUSRATE 0x00000010 -#define MA_DSCAPS_EMULDRIVER 0x00000020 -#define MA_DSCAPS_CERTIFIED 0x00000040 -#define MA_DSCAPS_SECONDARYMONO 0x00000100 -#define MA_DSCAPS_SECONDARYSTEREO 0x00000200 -#define MA_DSCAPS_SECONDARY8BIT 0x00000400 -#define MA_DSCAPS_SECONDARY16BIT 0x00000800 - -#define MA_DSBCAPS_PRIMARYBUFFER 0x00000001 -#define MA_DSBCAPS_STATIC 0x00000002 -#define MA_DSBCAPS_LOCHARDWARE 0x00000004 -#define MA_DSBCAPS_LOCSOFTWARE 0x00000008 -#define MA_DSBCAPS_CTRL3D 0x00000010 -#define MA_DSBCAPS_CTRLFREQUENCY 0x00000020 -#define MA_DSBCAPS_CTRLPAN 0x00000040 -#define MA_DSBCAPS_CTRLVOLUME 0x00000080 -#define MA_DSBCAPS_CTRLPOSITIONNOTIFY 0x00000100 -#define MA_DSBCAPS_CTRLFX 0x00000200 -#define MA_DSBCAPS_STICKYFOCUS 0x00004000 -#define MA_DSBCAPS_GLOBALFOCUS 0x00008000 -#define MA_DSBCAPS_GETCURRENTPOSITION2 0x00010000 -#define MA_DSBCAPS_MUTE3DATMAXDISTANCE 0x00020000 -#define MA_DSBCAPS_LOCDEFER 0x00040000 -#define MA_DSBCAPS_TRUEPLAYPOSITION 0x00080000 - -#define MA_DSBPLAY_LOOPING 0x00000001 -#define MA_DSBPLAY_LOCHARDWARE 0x00000002 -#define MA_DSBPLAY_LOCSOFTWARE 0x00000004 -#define MA_DSBPLAY_TERMINATEBY_TIME 0x00000008 -#define MA_DSBPLAY_TERMINATEBY_DISTANCE 0x00000010 -#define MA_DSBPLAY_TERMINATEBY_PRIORITY 0x00000020 - -#define MA_DSCBSTART_LOOPING 0x00000001 - -typedef struct -{ - DWORD dwSize; - DWORD dwFlags; - DWORD dwBufferBytes; - DWORD dwReserved; - MA_WAVEFORMATEX* lpwfxFormat; - GUID guid3DAlgorithm; -} MA_DSBUFFERDESC; - -typedef struct -{ - DWORD dwSize; - DWORD dwFlags; - DWORD dwBufferBytes; - DWORD dwReserved; - MA_WAVEFORMATEX* lpwfxFormat; - DWORD dwFXCount; - void* lpDSCFXDesc; /* <-- miniaudio doesn't use this, so set to void*. */ -} MA_DSCBUFFERDESC; - -typedef struct -{ - DWORD dwSize; - DWORD dwFlags; - DWORD dwMinSecondarySampleRate; - DWORD dwMaxSecondarySampleRate; - DWORD dwPrimaryBuffers; - DWORD dwMaxHwMixingAllBuffers; - DWORD dwMaxHwMixingStaticBuffers; - DWORD dwMaxHwMixingStreamingBuffers; - DWORD dwFreeHwMixingAllBuffers; - DWORD dwFreeHwMixingStaticBuffers; - DWORD dwFreeHwMixingStreamingBuffers; - DWORD dwMaxHw3DAllBuffers; - DWORD dwMaxHw3DStaticBuffers; - DWORD dwMaxHw3DStreamingBuffers; - DWORD dwFreeHw3DAllBuffers; - DWORD dwFreeHw3DStaticBuffers; - DWORD dwFreeHw3DStreamingBuffers; - DWORD dwTotalHwMemBytes; - DWORD dwFreeHwMemBytes; - DWORD dwMaxContigFreeHwMemBytes; - DWORD dwUnlockTransferRateHwBuffers; - DWORD dwPlayCpuOverheadSwBuffers; - DWORD dwReserved1; - DWORD dwReserved2; -} MA_DSCAPS; - -typedef struct -{ - DWORD dwSize; - DWORD dwFlags; - DWORD dwBufferBytes; - DWORD dwUnlockTransferRate; - DWORD dwPlayCpuOverhead; -} MA_DSBCAPS; - -typedef struct -{ - DWORD dwSize; - DWORD dwFlags; - DWORD dwFormats; - DWORD dwChannels; -} MA_DSCCAPS; - -typedef struct -{ - DWORD dwSize; - DWORD dwFlags; - DWORD dwBufferBytes; - DWORD dwReserved; -} MA_DSCBCAPS; - -typedef struct -{ - DWORD dwOffset; - HANDLE hEventNotify; -} MA_DSBPOSITIONNOTIFY; - -typedef struct ma_IDirectSound ma_IDirectSound; -typedef struct ma_IDirectSoundBuffer ma_IDirectSoundBuffer; -typedef struct ma_IDirectSoundCapture ma_IDirectSoundCapture; -typedef struct ma_IDirectSoundCaptureBuffer ma_IDirectSoundCaptureBuffer; -typedef struct ma_IDirectSoundNotify ma_IDirectSoundNotify; - - -/* -COM objects. The way these work is that you have a vtable (a list of function pointers, kind of -like how C++ works internally), and then you have a structure with a single member, which is a -pointer to the vtable. The vtable is where the methods of the object are defined. Methods need -to be in a specific order, and parent classes need to have their methods declared first. -*/ - -/* IDirectSound */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IDirectSound* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IDirectSound* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IDirectSound* pThis); - - /* IDirectSound */ - HRESULT (STDMETHODCALLTYPE * CreateSoundBuffer) (ma_IDirectSound* pThis, const MA_DSBUFFERDESC* pDSBufferDesc, ma_IDirectSoundBuffer** ppDSBuffer, void* pUnkOuter); - HRESULT (STDMETHODCALLTYPE * GetCaps) (ma_IDirectSound* pThis, MA_DSCAPS* pDSCaps); - HRESULT (STDMETHODCALLTYPE * DuplicateSoundBuffer)(ma_IDirectSound* pThis, ma_IDirectSoundBuffer* pDSBufferOriginal, ma_IDirectSoundBuffer** ppDSBufferDuplicate); - HRESULT (STDMETHODCALLTYPE * SetCooperativeLevel) (ma_IDirectSound* pThis, HWND hwnd, DWORD dwLevel); - HRESULT (STDMETHODCALLTYPE * Compact) (ma_IDirectSound* pThis); - HRESULT (STDMETHODCALLTYPE * GetSpeakerConfig) (ma_IDirectSound* pThis, DWORD* pSpeakerConfig); - HRESULT (STDMETHODCALLTYPE * SetSpeakerConfig) (ma_IDirectSound* pThis, DWORD dwSpeakerConfig); - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IDirectSound* pThis, const GUID* pGuidDevice); -} ma_IDirectSoundVtbl; -struct ma_IDirectSound -{ - ma_IDirectSoundVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IDirectSound_QueryInterface(ma_IDirectSound* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IDirectSound_AddRef(ma_IDirectSound* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IDirectSound_Release(ma_IDirectSound* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IDirectSound_CreateSoundBuffer(ma_IDirectSound* pThis, const MA_DSBUFFERDESC* pDSBufferDesc, ma_IDirectSoundBuffer** ppDSBuffer, void* pUnkOuter) { return pThis->lpVtbl->CreateSoundBuffer(pThis, pDSBufferDesc, ppDSBuffer, pUnkOuter); } -static MA_INLINE HRESULT ma_IDirectSound_GetCaps(ma_IDirectSound* pThis, MA_DSCAPS* pDSCaps) { return pThis->lpVtbl->GetCaps(pThis, pDSCaps); } -static MA_INLINE HRESULT ma_IDirectSound_DuplicateSoundBuffer(ma_IDirectSound* pThis, ma_IDirectSoundBuffer* pDSBufferOriginal, ma_IDirectSoundBuffer** ppDSBufferDuplicate) { return pThis->lpVtbl->DuplicateSoundBuffer(pThis, pDSBufferOriginal, ppDSBufferDuplicate); } -static MA_INLINE HRESULT ma_IDirectSound_SetCooperativeLevel(ma_IDirectSound* pThis, HWND hwnd, DWORD dwLevel) { return pThis->lpVtbl->SetCooperativeLevel(pThis, hwnd, dwLevel); } -static MA_INLINE HRESULT ma_IDirectSound_Compact(ma_IDirectSound* pThis) { return pThis->lpVtbl->Compact(pThis); } -static MA_INLINE HRESULT ma_IDirectSound_GetSpeakerConfig(ma_IDirectSound* pThis, DWORD* pSpeakerConfig) { return pThis->lpVtbl->GetSpeakerConfig(pThis, pSpeakerConfig); } -static MA_INLINE HRESULT ma_IDirectSound_SetSpeakerConfig(ma_IDirectSound* pThis, DWORD dwSpeakerConfig) { return pThis->lpVtbl->SetSpeakerConfig(pThis, dwSpeakerConfig); } -static MA_INLINE HRESULT ma_IDirectSound_Initialize(ma_IDirectSound* pThis, const GUID* pGuidDevice) { return pThis->lpVtbl->Initialize(pThis, pGuidDevice); } - - -/* IDirectSoundBuffer */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IDirectSoundBuffer* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IDirectSoundBuffer* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IDirectSoundBuffer* pThis); - - /* IDirectSoundBuffer */ - HRESULT (STDMETHODCALLTYPE * GetCaps) (ma_IDirectSoundBuffer* pThis, MA_DSBCAPS* pDSBufferCaps); - HRESULT (STDMETHODCALLTYPE * GetCurrentPosition)(ma_IDirectSoundBuffer* pThis, DWORD* pCurrentPlayCursor, DWORD* pCurrentWriteCursor); - HRESULT (STDMETHODCALLTYPE * GetFormat) (ma_IDirectSoundBuffer* pThis, MA_WAVEFORMATEX* pFormat, DWORD dwSizeAllocated, DWORD* pSizeWritten); - HRESULT (STDMETHODCALLTYPE * GetVolume) (ma_IDirectSoundBuffer* pThis, LONG* pVolume); - HRESULT (STDMETHODCALLTYPE * GetPan) (ma_IDirectSoundBuffer* pThis, LONG* pPan); - HRESULT (STDMETHODCALLTYPE * GetFrequency) (ma_IDirectSoundBuffer* pThis, DWORD* pFrequency); - HRESULT (STDMETHODCALLTYPE * GetStatus) (ma_IDirectSoundBuffer* pThis, DWORD* pStatus); - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IDirectSoundBuffer* pThis, ma_IDirectSound* pDirectSound, const MA_DSBUFFERDESC* pDSBufferDesc); - HRESULT (STDMETHODCALLTYPE * Lock) (ma_IDirectSoundBuffer* pThis, DWORD dwOffset, DWORD dwBytes, void** ppAudioPtr1, DWORD* pAudioBytes1, void** ppAudioPtr2, DWORD* pAudioBytes2, DWORD dwFlags); - HRESULT (STDMETHODCALLTYPE * Play) (ma_IDirectSoundBuffer* pThis, DWORD dwReserved1, DWORD dwPriority, DWORD dwFlags); - HRESULT (STDMETHODCALLTYPE * SetCurrentPosition)(ma_IDirectSoundBuffer* pThis, DWORD dwNewPosition); - HRESULT (STDMETHODCALLTYPE * SetFormat) (ma_IDirectSoundBuffer* pThis, const MA_WAVEFORMATEX* pFormat); - HRESULT (STDMETHODCALLTYPE * SetVolume) (ma_IDirectSoundBuffer* pThis, LONG volume); - HRESULT (STDMETHODCALLTYPE * SetPan) (ma_IDirectSoundBuffer* pThis, LONG pan); - HRESULT (STDMETHODCALLTYPE * SetFrequency) (ma_IDirectSoundBuffer* pThis, DWORD dwFrequency); - HRESULT (STDMETHODCALLTYPE * Stop) (ma_IDirectSoundBuffer* pThis); - HRESULT (STDMETHODCALLTYPE * Unlock) (ma_IDirectSoundBuffer* pThis, void* pAudioPtr1, DWORD dwAudioBytes1, void* pAudioPtr2, DWORD dwAudioBytes2); - HRESULT (STDMETHODCALLTYPE * Restore) (ma_IDirectSoundBuffer* pThis); -} ma_IDirectSoundBufferVtbl; -struct ma_IDirectSoundBuffer -{ - ma_IDirectSoundBufferVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IDirectSoundBuffer_QueryInterface(ma_IDirectSoundBuffer* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IDirectSoundBuffer_AddRef(ma_IDirectSoundBuffer* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IDirectSoundBuffer_Release(ma_IDirectSoundBuffer* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetCaps(ma_IDirectSoundBuffer* pThis, MA_DSBCAPS* pDSBufferCaps) { return pThis->lpVtbl->GetCaps(pThis, pDSBufferCaps); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetCurrentPosition(ma_IDirectSoundBuffer* pThis, DWORD* pCurrentPlayCursor, DWORD* pCurrentWriteCursor) { return pThis->lpVtbl->GetCurrentPosition(pThis, pCurrentPlayCursor, pCurrentWriteCursor); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetFormat(ma_IDirectSoundBuffer* pThis, MA_WAVEFORMATEX* pFormat, DWORD dwSizeAllocated, DWORD* pSizeWritten) { return pThis->lpVtbl->GetFormat(pThis, pFormat, dwSizeAllocated, pSizeWritten); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetVolume(ma_IDirectSoundBuffer* pThis, LONG* pVolume) { return pThis->lpVtbl->GetVolume(pThis, pVolume); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetPan(ma_IDirectSoundBuffer* pThis, LONG* pPan) { return pThis->lpVtbl->GetPan(pThis, pPan); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetFrequency(ma_IDirectSoundBuffer* pThis, DWORD* pFrequency) { return pThis->lpVtbl->GetFrequency(pThis, pFrequency); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_GetStatus(ma_IDirectSoundBuffer* pThis, DWORD* pStatus) { return pThis->lpVtbl->GetStatus(pThis, pStatus); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_Initialize(ma_IDirectSoundBuffer* pThis, ma_IDirectSound* pDirectSound, const MA_DSBUFFERDESC* pDSBufferDesc) { return pThis->lpVtbl->Initialize(pThis, pDirectSound, pDSBufferDesc); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_Lock(ma_IDirectSoundBuffer* pThis, DWORD dwOffset, DWORD dwBytes, void** ppAudioPtr1, DWORD* pAudioBytes1, void** ppAudioPtr2, DWORD* pAudioBytes2, DWORD dwFlags) { return pThis->lpVtbl->Lock(pThis, dwOffset, dwBytes, ppAudioPtr1, pAudioBytes1, ppAudioPtr2, pAudioBytes2, dwFlags); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_Play(ma_IDirectSoundBuffer* pThis, DWORD dwReserved1, DWORD dwPriority, DWORD dwFlags) { return pThis->lpVtbl->Play(pThis, dwReserved1, dwPriority, dwFlags); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_SetCurrentPosition(ma_IDirectSoundBuffer* pThis, DWORD dwNewPosition) { return pThis->lpVtbl->SetCurrentPosition(pThis, dwNewPosition); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_SetFormat(ma_IDirectSoundBuffer* pThis, const MA_WAVEFORMATEX* pFormat) { return pThis->lpVtbl->SetFormat(pThis, pFormat); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_SetVolume(ma_IDirectSoundBuffer* pThis, LONG volume) { return pThis->lpVtbl->SetVolume(pThis, volume); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_SetPan(ma_IDirectSoundBuffer* pThis, LONG pan) { return pThis->lpVtbl->SetPan(pThis, pan); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_SetFrequency(ma_IDirectSoundBuffer* pThis, DWORD dwFrequency) { return pThis->lpVtbl->SetFrequency(pThis, dwFrequency); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_Stop(ma_IDirectSoundBuffer* pThis) { return pThis->lpVtbl->Stop(pThis); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_Unlock(ma_IDirectSoundBuffer* pThis, void* pAudioPtr1, DWORD dwAudioBytes1, void* pAudioPtr2, DWORD dwAudioBytes2) { return pThis->lpVtbl->Unlock(pThis, pAudioPtr1, dwAudioBytes1, pAudioPtr2, dwAudioBytes2); } -static MA_INLINE HRESULT ma_IDirectSoundBuffer_Restore(ma_IDirectSoundBuffer* pThis) { return pThis->lpVtbl->Restore(pThis); } - - -/* IDirectSoundCapture */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IDirectSoundCapture* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IDirectSoundCapture* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IDirectSoundCapture* pThis); - - /* IDirectSoundCapture */ - HRESULT (STDMETHODCALLTYPE * CreateCaptureBuffer)(ma_IDirectSoundCapture* pThis, const MA_DSCBUFFERDESC* pDSCBufferDesc, ma_IDirectSoundCaptureBuffer** ppDSCBuffer, void* pUnkOuter); - HRESULT (STDMETHODCALLTYPE * GetCaps) (ma_IDirectSoundCapture* pThis, MA_DSCCAPS* pDSCCaps); - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IDirectSoundCapture* pThis, const GUID* pGuidDevice); -} ma_IDirectSoundCaptureVtbl; -struct ma_IDirectSoundCapture -{ - ma_IDirectSoundCaptureVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IDirectSoundCapture_QueryInterface (ma_IDirectSoundCapture* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IDirectSoundCapture_AddRef (ma_IDirectSoundCapture* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IDirectSoundCapture_Release (ma_IDirectSoundCapture* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IDirectSoundCapture_CreateCaptureBuffer(ma_IDirectSoundCapture* pThis, const MA_DSCBUFFERDESC* pDSCBufferDesc, ma_IDirectSoundCaptureBuffer** ppDSCBuffer, void* pUnkOuter) { return pThis->lpVtbl->CreateCaptureBuffer(pThis, pDSCBufferDesc, ppDSCBuffer, pUnkOuter); } -static MA_INLINE HRESULT ma_IDirectSoundCapture_GetCaps (ma_IDirectSoundCapture* pThis, MA_DSCCAPS* pDSCCaps) { return pThis->lpVtbl->GetCaps(pThis, pDSCCaps); } -static MA_INLINE HRESULT ma_IDirectSoundCapture_Initialize (ma_IDirectSoundCapture* pThis, const GUID* pGuidDevice) { return pThis->lpVtbl->Initialize(pThis, pGuidDevice); } - - -/* IDirectSoundCaptureBuffer */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IDirectSoundCaptureBuffer* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IDirectSoundCaptureBuffer* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IDirectSoundCaptureBuffer* pThis); - - /* IDirectSoundCaptureBuffer */ - HRESULT (STDMETHODCALLTYPE * GetCaps) (ma_IDirectSoundCaptureBuffer* pThis, MA_DSCBCAPS* pDSCBCaps); - HRESULT (STDMETHODCALLTYPE * GetCurrentPosition)(ma_IDirectSoundCaptureBuffer* pThis, DWORD* pCapturePosition, DWORD* pReadPosition); - HRESULT (STDMETHODCALLTYPE * GetFormat) (ma_IDirectSoundCaptureBuffer* pThis, MA_WAVEFORMATEX* pFormat, DWORD dwSizeAllocated, DWORD* pSizeWritten); - HRESULT (STDMETHODCALLTYPE * GetStatus) (ma_IDirectSoundCaptureBuffer* pThis, DWORD* pStatus); - HRESULT (STDMETHODCALLTYPE * Initialize) (ma_IDirectSoundCaptureBuffer* pThis, ma_IDirectSoundCapture* pDirectSoundCapture, const MA_DSCBUFFERDESC* pDSCBufferDesc); - HRESULT (STDMETHODCALLTYPE * Lock) (ma_IDirectSoundCaptureBuffer* pThis, DWORD dwOffset, DWORD dwBytes, void** ppAudioPtr1, DWORD* pAudioBytes1, void** ppAudioPtr2, DWORD* pAudioBytes2, DWORD dwFlags); - HRESULT (STDMETHODCALLTYPE * Start) (ma_IDirectSoundCaptureBuffer* pThis, DWORD dwFlags); - HRESULT (STDMETHODCALLTYPE * Stop) (ma_IDirectSoundCaptureBuffer* pThis); - HRESULT (STDMETHODCALLTYPE * Unlock) (ma_IDirectSoundCaptureBuffer* pThis, void* pAudioPtr1, DWORD dwAudioBytes1, void* pAudioPtr2, DWORD dwAudioBytes2); -} ma_IDirectSoundCaptureBufferVtbl; -struct ma_IDirectSoundCaptureBuffer -{ - ma_IDirectSoundCaptureBufferVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_QueryInterface(ma_IDirectSoundCaptureBuffer* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IDirectSoundCaptureBuffer_AddRef(ma_IDirectSoundCaptureBuffer* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IDirectSoundCaptureBuffer_Release(ma_IDirectSoundCaptureBuffer* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_GetCaps(ma_IDirectSoundCaptureBuffer* pThis, MA_DSCBCAPS* pDSCBCaps) { return pThis->lpVtbl->GetCaps(pThis, pDSCBCaps); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_GetCurrentPosition(ma_IDirectSoundCaptureBuffer* pThis, DWORD* pCapturePosition, DWORD* pReadPosition) { return pThis->lpVtbl->GetCurrentPosition(pThis, pCapturePosition, pReadPosition); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_GetFormat(ma_IDirectSoundCaptureBuffer* pThis, MA_WAVEFORMATEX* pFormat, DWORD dwSizeAllocated, DWORD* pSizeWritten) { return pThis->lpVtbl->GetFormat(pThis, pFormat, dwSizeAllocated, pSizeWritten); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_GetStatus(ma_IDirectSoundCaptureBuffer* pThis, DWORD* pStatus) { return pThis->lpVtbl->GetStatus(pThis, pStatus); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_Initialize(ma_IDirectSoundCaptureBuffer* pThis, ma_IDirectSoundCapture* pDirectSoundCapture, const MA_DSCBUFFERDESC* pDSCBufferDesc) { return pThis->lpVtbl->Initialize(pThis, pDirectSoundCapture, pDSCBufferDesc); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_Lock(ma_IDirectSoundCaptureBuffer* pThis, DWORD dwOffset, DWORD dwBytes, void** ppAudioPtr1, DWORD* pAudioBytes1, void** ppAudioPtr2, DWORD* pAudioBytes2, DWORD dwFlags) { return pThis->lpVtbl->Lock(pThis, dwOffset, dwBytes, ppAudioPtr1, pAudioBytes1, ppAudioPtr2, pAudioBytes2, dwFlags); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_Start(ma_IDirectSoundCaptureBuffer* pThis, DWORD dwFlags) { return pThis->lpVtbl->Start(pThis, dwFlags); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_Stop(ma_IDirectSoundCaptureBuffer* pThis) { return pThis->lpVtbl->Stop(pThis); } -static MA_INLINE HRESULT ma_IDirectSoundCaptureBuffer_Unlock(ma_IDirectSoundCaptureBuffer* pThis, void* pAudioPtr1, DWORD dwAudioBytes1, void* pAudioPtr2, DWORD dwAudioBytes2) { return pThis->lpVtbl->Unlock(pThis, pAudioPtr1, dwAudioBytes1, pAudioPtr2, dwAudioBytes2); } - - -/* IDirectSoundNotify */ -typedef struct -{ - /* IUnknown */ - HRESULT (STDMETHODCALLTYPE * QueryInterface)(ma_IDirectSoundNotify* pThis, const IID* const riid, void** ppObject); - ULONG (STDMETHODCALLTYPE * AddRef) (ma_IDirectSoundNotify* pThis); - ULONG (STDMETHODCALLTYPE * Release) (ma_IDirectSoundNotify* pThis); - - /* IDirectSoundNotify */ - HRESULT (STDMETHODCALLTYPE * SetNotificationPositions)(ma_IDirectSoundNotify* pThis, DWORD dwPositionNotifies, const MA_DSBPOSITIONNOTIFY* pPositionNotifies); -} ma_IDirectSoundNotifyVtbl; -struct ma_IDirectSoundNotify -{ - ma_IDirectSoundNotifyVtbl* lpVtbl; -}; -static MA_INLINE HRESULT ma_IDirectSoundNotify_QueryInterface(ma_IDirectSoundNotify* pThis, const IID* const riid, void** ppObject) { return pThis->lpVtbl->QueryInterface(pThis, riid, ppObject); } -static MA_INLINE ULONG ma_IDirectSoundNotify_AddRef(ma_IDirectSoundNotify* pThis) { return pThis->lpVtbl->AddRef(pThis); } -static MA_INLINE ULONG ma_IDirectSoundNotify_Release(ma_IDirectSoundNotify* pThis) { return pThis->lpVtbl->Release(pThis); } -static MA_INLINE HRESULT ma_IDirectSoundNotify_SetNotificationPositions(ma_IDirectSoundNotify* pThis, DWORD dwPositionNotifies, const MA_DSBPOSITIONNOTIFY* pPositionNotifies) { return pThis->lpVtbl->SetNotificationPositions(pThis, dwPositionNotifies, pPositionNotifies); } - - -typedef BOOL (CALLBACK * ma_DSEnumCallbackAProc) (GUID* pDeviceGUID, const char* pDeviceDescription, const char* pModule, void* pContext); -typedef HRESULT (WINAPI * ma_DirectSoundCreateProc) (const GUID* pcGuidDevice, ma_IDirectSound** ppDS8, ma_IUnknown* pUnkOuter); -typedef HRESULT (WINAPI * ma_DirectSoundEnumerateAProc) (ma_DSEnumCallbackAProc pDSEnumCallback, void* pContext); -typedef HRESULT (WINAPI * ma_DirectSoundCaptureCreateProc) (const GUID* pcGuidDevice, ma_IDirectSoundCapture** ppDSC8, ma_IUnknown* pUnkOuter); -typedef HRESULT (WINAPI * ma_DirectSoundCaptureEnumerateAProc)(ma_DSEnumCallbackAProc pDSEnumCallback, void* pContext); - -static ma_uint32 ma_get_best_sample_rate_within_range(ma_uint32 sampleRateMin, ma_uint32 sampleRateMax) -{ - /* Normalize the range in case we were given something stupid. */ - if (sampleRateMin < (ma_uint32)ma_standard_sample_rate_min) { - sampleRateMin = (ma_uint32)ma_standard_sample_rate_min; - } - if (sampleRateMax > (ma_uint32)ma_standard_sample_rate_max) { - sampleRateMax = (ma_uint32)ma_standard_sample_rate_max; - } - if (sampleRateMin > sampleRateMax) { - sampleRateMin = sampleRateMax; - } - - if (sampleRateMin == sampleRateMax) { - return sampleRateMax; - } else { - size_t iStandardRate; - for (iStandardRate = 0; iStandardRate < ma_countof(g_maStandardSampleRatePriorities); ++iStandardRate) { - ma_uint32 standardRate = g_maStandardSampleRatePriorities[iStandardRate]; - if (standardRate >= sampleRateMin && standardRate <= sampleRateMax) { - return standardRate; - } - } - } - - /* Should never get here. */ - MA_ASSERT(MA_FALSE); - return 0; -} - -/* -Retrieves the channel count and channel map for the given speaker configuration. If the speaker configuration is unknown, -the channel count and channel map will be left unmodified. -*/ -static void ma_get_channels_from_speaker_config__dsound(DWORD speakerConfig, WORD* pChannelsOut, DWORD* pChannelMapOut) -{ - WORD channels; - DWORD channelMap; - - channels = 0; - if (pChannelsOut != NULL) { - channels = *pChannelsOut; - } - - channelMap = 0; - if (pChannelMapOut != NULL) { - channelMap = *pChannelMapOut; - } - - /* - The speaker configuration is a combination of speaker config and speaker geometry. The lower 8 bits is what we care about. The upper - 16 bits is for the geometry. - */ - switch ((BYTE)(speakerConfig)) { - case 1 /*DSSPEAKER_HEADPHONE*/: channels = 2; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT; break; - case 2 /*DSSPEAKER_MONO*/: channels = 1; channelMap = SPEAKER_FRONT_CENTER; break; - case 3 /*DSSPEAKER_QUAD*/: channels = 4; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT | SPEAKER_BACK_LEFT | SPEAKER_BACK_RIGHT; break; - case 4 /*DSSPEAKER_STEREO*/: channels = 2; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT; break; - case 5 /*DSSPEAKER_SURROUND*/: channels = 4; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT | SPEAKER_FRONT_CENTER | SPEAKER_BACK_CENTER; break; - case 6 /*DSSPEAKER_5POINT1_BACK*/ /*DSSPEAKER_5POINT1*/: channels = 6; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT | SPEAKER_FRONT_CENTER | SPEAKER_LOW_FREQUENCY | SPEAKER_BACK_LEFT | SPEAKER_BACK_RIGHT; break; - case 7 /*DSSPEAKER_7POINT1_WIDE*/ /*DSSPEAKER_7POINT1*/: channels = 8; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT | SPEAKER_FRONT_CENTER | SPEAKER_LOW_FREQUENCY | SPEAKER_BACK_LEFT | SPEAKER_BACK_RIGHT | SPEAKER_FRONT_LEFT_OF_CENTER | SPEAKER_FRONT_RIGHT_OF_CENTER; break; - case 8 /*DSSPEAKER_7POINT1_SURROUND*/: channels = 8; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT | SPEAKER_FRONT_CENTER | SPEAKER_LOW_FREQUENCY | SPEAKER_BACK_LEFT | SPEAKER_BACK_RIGHT | SPEAKER_SIDE_LEFT | SPEAKER_SIDE_RIGHT; break; - case 9 /*DSSPEAKER_5POINT1_SURROUND*/: channels = 6; channelMap = SPEAKER_FRONT_LEFT | SPEAKER_FRONT_RIGHT | SPEAKER_FRONT_CENTER | SPEAKER_LOW_FREQUENCY | SPEAKER_SIDE_LEFT | SPEAKER_SIDE_RIGHT; break; - default: break; - } - - if (pChannelsOut != NULL) { - *pChannelsOut = channels; - } - - if (pChannelMapOut != NULL) { - *pChannelMapOut = channelMap; - } -} - - -static ma_result ma_context_create_IDirectSound__dsound(ma_context* pContext, ma_share_mode shareMode, const ma_device_id* pDeviceID, ma_IDirectSound** ppDirectSound) -{ - ma_IDirectSound* pDirectSound; - HWND hWnd; - HRESULT hr; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppDirectSound != NULL); - - *ppDirectSound = NULL; - pDirectSound = NULL; - - if (FAILED(((ma_DirectSoundCreateProc)pContext->dsound.DirectSoundCreate)((pDeviceID == NULL) ? NULL : (const GUID*)pDeviceID->dsound, &pDirectSound, NULL))) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[DirectSound] DirectSoundCreate() failed for playback device."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - /* The cooperative level must be set before doing anything else. */ - hWnd = ((MA_PFN_GetForegroundWindow)pContext->win32.GetForegroundWindow)(); - if (hWnd == 0) { - hWnd = ((MA_PFN_GetDesktopWindow)pContext->win32.GetDesktopWindow)(); - } - - hr = ma_IDirectSound_SetCooperativeLevel(pDirectSound, hWnd, (shareMode == ma_share_mode_exclusive) ? MA_DSSCL_EXCLUSIVE : MA_DSSCL_PRIORITY); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSound_SetCooperateiveLevel() failed for playback device."); - return ma_result_from_HRESULT(hr); - } - - *ppDirectSound = pDirectSound; - return MA_SUCCESS; -} - -static ma_result ma_context_create_IDirectSoundCapture__dsound(ma_context* pContext, ma_share_mode shareMode, const ma_device_id* pDeviceID, ma_IDirectSoundCapture** ppDirectSoundCapture) -{ - ma_IDirectSoundCapture* pDirectSoundCapture; - HRESULT hr; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppDirectSoundCapture != NULL); - - /* DirectSound does not support exclusive mode for capture. */ - if (shareMode == ma_share_mode_exclusive) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - *ppDirectSoundCapture = NULL; - pDirectSoundCapture = NULL; - - hr = ((ma_DirectSoundCaptureCreateProc)pContext->dsound.DirectSoundCaptureCreate)((pDeviceID == NULL) ? NULL : (const GUID*)pDeviceID->dsound, &pDirectSoundCapture, NULL); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[DirectSound] DirectSoundCaptureCreate() failed for capture device."); - return ma_result_from_HRESULT(hr); - } - - *ppDirectSoundCapture = pDirectSoundCapture; - return MA_SUCCESS; -} - -static ma_result ma_context_get_format_info_for_IDirectSoundCapture__dsound(ma_context* pContext, ma_IDirectSoundCapture* pDirectSoundCapture, WORD* pChannels, WORD* pBitsPerSample, DWORD* pSampleRate) -{ - HRESULT hr; - MA_DSCCAPS caps; - WORD bitsPerSample; - DWORD sampleRate; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDirectSoundCapture != NULL); - - if (pChannels) { - *pChannels = 0; - } - if (pBitsPerSample) { - *pBitsPerSample = 0; - } - if (pSampleRate) { - *pSampleRate = 0; - } - - MA_ZERO_OBJECT(&caps); - caps.dwSize = sizeof(caps); - hr = ma_IDirectSoundCapture_GetCaps(pDirectSoundCapture, &caps); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundCapture_GetCaps() failed for capture device."); - return ma_result_from_HRESULT(hr); - } - - if (pChannels) { - *pChannels = (WORD)caps.dwChannels; - } - - /* The device can support multiple formats. We just go through the different formats in order of priority and pick the first one. This the same type of system as the WinMM backend. */ - bitsPerSample = 16; - sampleRate = 48000; - - if (caps.dwChannels == 1) { - if ((caps.dwFormats & WAVE_FORMAT_48M16) != 0) { - sampleRate = 48000; - } else if ((caps.dwFormats & WAVE_FORMAT_44M16) != 0) { - sampleRate = 44100; - } else if ((caps.dwFormats & WAVE_FORMAT_2M16) != 0) { - sampleRate = 22050; - } else if ((caps.dwFormats & WAVE_FORMAT_1M16) != 0) { - sampleRate = 11025; - } else if ((caps.dwFormats & WAVE_FORMAT_96M16) != 0) { - sampleRate = 96000; - } else { - bitsPerSample = 8; - if ((caps.dwFormats & WAVE_FORMAT_48M08) != 0) { - sampleRate = 48000; - } else if ((caps.dwFormats & WAVE_FORMAT_44M08) != 0) { - sampleRate = 44100; - } else if ((caps.dwFormats & WAVE_FORMAT_2M08) != 0) { - sampleRate = 22050; - } else if ((caps.dwFormats & WAVE_FORMAT_1M08) != 0) { - sampleRate = 11025; - } else if ((caps.dwFormats & WAVE_FORMAT_96M08) != 0) { - sampleRate = 96000; - } else { - bitsPerSample = 16; /* Didn't find it. Just fall back to 16-bit. */ - } - } - } else if (caps.dwChannels == 2) { - if ((caps.dwFormats & WAVE_FORMAT_48S16) != 0) { - sampleRate = 48000; - } else if ((caps.dwFormats & WAVE_FORMAT_44S16) != 0) { - sampleRate = 44100; - } else if ((caps.dwFormats & WAVE_FORMAT_2S16) != 0) { - sampleRate = 22050; - } else if ((caps.dwFormats & WAVE_FORMAT_1S16) != 0) { - sampleRate = 11025; - } else if ((caps.dwFormats & WAVE_FORMAT_96S16) != 0) { - sampleRate = 96000; - } else { - bitsPerSample = 8; - if ((caps.dwFormats & WAVE_FORMAT_48S08) != 0) { - sampleRate = 48000; - } else if ((caps.dwFormats & WAVE_FORMAT_44S08) != 0) { - sampleRate = 44100; - } else if ((caps.dwFormats & WAVE_FORMAT_2S08) != 0) { - sampleRate = 22050; - } else if ((caps.dwFormats & WAVE_FORMAT_1S08) != 0) { - sampleRate = 11025; - } else if ((caps.dwFormats & WAVE_FORMAT_96S08) != 0) { - sampleRate = 96000; - } else { - bitsPerSample = 16; /* Didn't find it. Just fall back to 16-bit. */ - } - } - } - - if (pBitsPerSample) { - *pBitsPerSample = bitsPerSample; - } - if (pSampleRate) { - *pSampleRate = sampleRate; - } - - return MA_SUCCESS; -} - - -typedef struct -{ - ma_context* pContext; - ma_device_type deviceType; - ma_enum_devices_callback_proc callback; - void* pUserData; - ma_bool32 terminated; -} ma_context_enumerate_devices_callback_data__dsound; - -static BOOL CALLBACK ma_context_enumerate_devices_callback__dsound(GUID* lpGuid, const char* lpcstrDescription, const char* lpcstrModule, void* lpContext) -{ - ma_context_enumerate_devices_callback_data__dsound* pData = (ma_context_enumerate_devices_callback_data__dsound*)lpContext; - ma_device_info deviceInfo; - - (void)lpcstrModule; - - MA_ZERO_OBJECT(&deviceInfo); - - /* ID. */ - if (lpGuid != NULL) { - MA_COPY_MEMORY(deviceInfo.id.dsound, lpGuid, 16); - } else { - MA_ZERO_MEMORY(deviceInfo.id.dsound, 16); - deviceInfo.isDefault = MA_TRUE; - } - - /* Name / Description */ - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), lpcstrDescription, (size_t)-1); - - - /* Call the callback function, but make sure we stop enumerating if the callee requested so. */ - MA_ASSERT(pData != NULL); - pData->terminated = !pData->callback(pData->pContext, pData->deviceType, &deviceInfo, pData->pUserData); - if (pData->terminated) { - return FALSE; /* Stop enumeration. */ - } else { - return TRUE; /* Continue enumeration. */ - } -} - -static ma_result ma_context_enumerate_devices__dsound(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_context_enumerate_devices_callback_data__dsound data; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - data.pContext = pContext; - data.callback = callback; - data.pUserData = pUserData; - data.terminated = MA_FALSE; - - /* Playback. */ - if (!data.terminated) { - data.deviceType = ma_device_type_playback; - ((ma_DirectSoundEnumerateAProc)pContext->dsound.DirectSoundEnumerateA)(ma_context_enumerate_devices_callback__dsound, &data); - } - - /* Capture. */ - if (!data.terminated) { - data.deviceType = ma_device_type_capture; - ((ma_DirectSoundCaptureEnumerateAProc)pContext->dsound.DirectSoundCaptureEnumerateA)(ma_context_enumerate_devices_callback__dsound, &data); - } - - return MA_SUCCESS; -} - - -typedef struct -{ - const ma_device_id* pDeviceID; - ma_device_info* pDeviceInfo; - ma_bool32 found; -} ma_context_get_device_info_callback_data__dsound; - -static BOOL CALLBACK ma_context_get_device_info_callback__dsound(GUID* lpGuid, const char* lpcstrDescription, const char* lpcstrModule, void* lpContext) -{ - ma_context_get_device_info_callback_data__dsound* pData = (ma_context_get_device_info_callback_data__dsound*)lpContext; - MA_ASSERT(pData != NULL); - - if ((pData->pDeviceID == NULL || ma_is_guid_null(pData->pDeviceID->dsound)) && (lpGuid == NULL || ma_is_guid_null(lpGuid))) { - /* Default device. */ - ma_strncpy_s(pData->pDeviceInfo->name, sizeof(pData->pDeviceInfo->name), lpcstrDescription, (size_t)-1); - pData->pDeviceInfo->isDefault = MA_TRUE; - pData->found = MA_TRUE; - return FALSE; /* Stop enumeration. */ - } else { - /* Not the default device. */ - if (lpGuid != NULL && pData->pDeviceID != NULL) { - if (memcmp(pData->pDeviceID->dsound, lpGuid, sizeof(pData->pDeviceID->dsound)) == 0) { - ma_strncpy_s(pData->pDeviceInfo->name, sizeof(pData->pDeviceInfo->name), lpcstrDescription, (size_t)-1); - pData->found = MA_TRUE; - return FALSE; /* Stop enumeration. */ - } - } - } - - (void)lpcstrModule; - return TRUE; -} - -static ma_result ma_context_get_device_info__dsound(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_result result; - HRESULT hr; - - if (pDeviceID != NULL) { - ma_context_get_device_info_callback_data__dsound data; - - /* ID. */ - MA_COPY_MEMORY(pDeviceInfo->id.dsound, pDeviceID->dsound, 16); - - /* Name / Description. This is retrieved by enumerating over each device until we find that one that matches the input ID. */ - data.pDeviceID = pDeviceID; - data.pDeviceInfo = pDeviceInfo; - data.found = MA_FALSE; - if (deviceType == ma_device_type_playback) { - ((ma_DirectSoundEnumerateAProc)pContext->dsound.DirectSoundEnumerateA)(ma_context_get_device_info_callback__dsound, &data); - } else { - ((ma_DirectSoundCaptureEnumerateAProc)pContext->dsound.DirectSoundCaptureEnumerateA)(ma_context_get_device_info_callback__dsound, &data); - } - - if (!data.found) { - return MA_NO_DEVICE; - } - } else { - /* I don't think there's a way to get the name of the default device with DirectSound. In this case we just need to use defaults. */ - - /* ID */ - MA_ZERO_MEMORY(pDeviceInfo->id.dsound, 16); - - /* Name / Description */ - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - pDeviceInfo->isDefault = MA_TRUE; - } - - /* Retrieving detailed information is slightly different depending on the device type. */ - if (deviceType == ma_device_type_playback) { - /* Playback. */ - ma_IDirectSound* pDirectSound; - MA_DSCAPS caps; - WORD channels; - - result = ma_context_create_IDirectSound__dsound(pContext, ma_share_mode_shared, pDeviceID, &pDirectSound); - if (result != MA_SUCCESS) { - return result; - } - - MA_ZERO_OBJECT(&caps); - caps.dwSize = sizeof(caps); - hr = ma_IDirectSound_GetCaps(pDirectSound, &caps); - if (FAILED(hr)) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSound_GetCaps() failed for playback device."); - return ma_result_from_HRESULT(hr); - } - - - /* Channels. Only a single channel count is reported for DirectSound. */ - if ((caps.dwFlags & MA_DSCAPS_PRIMARYSTEREO) != 0) { - /* It supports at least stereo, but could support more. */ - DWORD speakerConfig; - - channels = 2; - - /* Look at the speaker configuration to get a better idea on the channel count. */ - hr = ma_IDirectSound_GetSpeakerConfig(pDirectSound, &speakerConfig); - if (SUCCEEDED(hr)) { - ma_get_channels_from_speaker_config__dsound(speakerConfig, &channels, NULL); - } - } else { - /* It does not support stereo, which means we are stuck with mono. */ - channels = 1; - } - - - /* - In DirectSound, our native formats are centered around sample rates. All formats are supported, and we're only reporting a single channel - count. However, DirectSound can report a range of supported sample rates. We're only going to include standard rates known by miniaudio - in order to keep the size of this within reason. - */ - if ((caps.dwFlags & MA_DSCAPS_CONTINUOUSRATE) != 0) { - /* Multiple sample rates are supported. We'll report in order of our preferred sample rates. */ - size_t iStandardSampleRate; - for (iStandardSampleRate = 0; iStandardSampleRate < ma_countof(g_maStandardSampleRatePriorities); iStandardSampleRate += 1) { - ma_uint32 sampleRate = g_maStandardSampleRatePriorities[iStandardSampleRate]; - if (sampleRate >= caps.dwMinSecondarySampleRate && sampleRate <= caps.dwMaxSecondarySampleRate) { - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = ma_format_unknown; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = sampleRate; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = 0; - pDeviceInfo->nativeDataFormatCount += 1; - } - } - } else { - /* Only a single sample rate is supported. */ - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = ma_format_unknown; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = caps.dwMaxSecondarySampleRate; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = 0; - pDeviceInfo->nativeDataFormatCount += 1; - } - - ma_IDirectSound_Release(pDirectSound); - } else { - /* - Capture. This is a little different to playback due to the say the supported formats are reported. Technically capture - devices can support a number of different formats, but for simplicity and consistency with ma_device_init() I'm just - reporting the best format. - */ - ma_IDirectSoundCapture* pDirectSoundCapture; - WORD channels; - WORD bitsPerSample; - DWORD sampleRate; - - result = ma_context_create_IDirectSoundCapture__dsound(pContext, ma_share_mode_shared, pDeviceID, &pDirectSoundCapture); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_context_get_format_info_for_IDirectSoundCapture__dsound(pContext, pDirectSoundCapture, &channels, &bitsPerSample, &sampleRate); - if (result != MA_SUCCESS) { - ma_IDirectSoundCapture_Release(pDirectSoundCapture); - return result; - } - - ma_IDirectSoundCapture_Release(pDirectSoundCapture); - - /* The format is always an integer format and is based on the bits per sample. */ - if (bitsPerSample == 8) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_u8; - } else if (bitsPerSample == 16) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_s16; - } else if (bitsPerSample == 24) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_s24; - } else if (bitsPerSample == 32) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_s32; - } else { - return MA_FORMAT_NOT_SUPPORTED; - } - - pDeviceInfo->nativeDataFormats[0].channels = channels; - pDeviceInfo->nativeDataFormats[0].sampleRate = sampleRate; - pDeviceInfo->nativeDataFormats[0].flags = 0; - pDeviceInfo->nativeDataFormatCount = 1; - } - - return MA_SUCCESS; -} - - - -static ma_result ma_device_uninit__dsound(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->dsound.pCaptureBuffer != NULL) { - ma_IDirectSoundCaptureBuffer_Release((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer); - } - if (pDevice->dsound.pCapture != NULL) { - ma_IDirectSoundCapture_Release((ma_IDirectSoundCapture*)pDevice->dsound.pCapture); - } - - if (pDevice->dsound.pPlaybackBuffer != NULL) { - ma_IDirectSoundBuffer_Release((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer); - } - if (pDevice->dsound.pPlaybackPrimaryBuffer != NULL) { - ma_IDirectSoundBuffer_Release((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackPrimaryBuffer); - } - if (pDevice->dsound.pPlayback != NULL) { - ma_IDirectSound_Release((ma_IDirectSound*)pDevice->dsound.pPlayback); - } - - return MA_SUCCESS; -} - -static ma_result ma_config_to_WAVEFORMATEXTENSIBLE(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, const ma_channel* pChannelMap, MA_WAVEFORMATEXTENSIBLE* pWF) -{ - GUID subformat; - - if (format == ma_format_unknown) { - format = MA_DEFAULT_FORMAT; - } - - if (channels == 0) { - channels = MA_DEFAULT_CHANNELS; - } - - if (sampleRate == 0) { - sampleRate = MA_DEFAULT_SAMPLE_RATE; - } - - switch (format) - { - case ma_format_u8: - case ma_format_s16: - case ma_format_s24: - /*case ma_format_s24_32:*/ - case ma_format_s32: - { - subformat = MA_GUID_KSDATAFORMAT_SUBTYPE_PCM; - } break; - - case ma_format_f32: - { - subformat = MA_GUID_KSDATAFORMAT_SUBTYPE_IEEE_FLOAT; - } break; - - default: - return MA_FORMAT_NOT_SUPPORTED; - } - - MA_ZERO_OBJECT(pWF); - pWF->cbSize = sizeof(*pWF); - pWF->wFormatTag = WAVE_FORMAT_EXTENSIBLE; - pWF->nChannels = (WORD)channels; - pWF->nSamplesPerSec = (DWORD)sampleRate; - pWF->wBitsPerSample = (WORD)(ma_get_bytes_per_sample(format)*8); - pWF->nBlockAlign = (WORD)(pWF->nChannels * pWF->wBitsPerSample / 8); - pWF->nAvgBytesPerSec = pWF->nBlockAlign * pWF->nSamplesPerSec; - pWF->Samples.wValidBitsPerSample = pWF->wBitsPerSample; - pWF->dwChannelMask = ma_channel_map_to_channel_mask__win32(pChannelMap, channels); - pWF->SubFormat = subformat; - - return MA_SUCCESS; -} - -static ma_uint32 ma_calculate_period_size_in_frames_from_descriptor__dsound(const ma_device_descriptor* pDescriptor, ma_uint32 nativeSampleRate, ma_performance_profile performanceProfile) -{ - /* - DirectSound has a minimum period size of 20ms. In practice, this doesn't seem to be enough for - reliable glitch-free processing so going to use 30ms instead. - */ - ma_uint32 minPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(30, nativeSampleRate); - ma_uint32 periodSizeInFrames; - - periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, nativeSampleRate, performanceProfile); - if (periodSizeInFrames < minPeriodSizeInFrames) { - periodSizeInFrames = minPeriodSizeInFrames; - } - - return periodSizeInFrames; -} - -static ma_result ma_device_init__dsound(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - HRESULT hr; - - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->dsound); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* - Unfortunately DirectSound uses different APIs and data structures for playback and catpure devices. We need to initialize - the capture device first because we'll want to match it's buffer size and period count on the playback side if we're using - full-duplex mode. - */ - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - MA_WAVEFORMATEXTENSIBLE wf; - MA_DSCBUFFERDESC descDS; - ma_uint32 periodSizeInFrames; - ma_uint32 periodCount; - char rawdata[1024]; /* <-- Ugly hack to avoid a malloc() due to a crappy DirectSound API. */ - MA_WAVEFORMATEXTENSIBLE* pActualFormat; - - result = ma_config_to_WAVEFORMATEXTENSIBLE(pDescriptorCapture->format, pDescriptorCapture->channels, pDescriptorCapture->sampleRate, pDescriptorCapture->channelMap, &wf); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_context_create_IDirectSoundCapture__dsound(pDevice->pContext, pDescriptorCapture->shareMode, pDescriptorCapture->pDeviceID, (ma_IDirectSoundCapture**)&pDevice->dsound.pCapture); - if (result != MA_SUCCESS) { - ma_device_uninit__dsound(pDevice); - return result; - } - - result = ma_context_get_format_info_for_IDirectSoundCapture__dsound(pDevice->pContext, (ma_IDirectSoundCapture*)pDevice->dsound.pCapture, &wf.nChannels, &wf.wBitsPerSample, &wf.nSamplesPerSec); - if (result != MA_SUCCESS) { - ma_device_uninit__dsound(pDevice); - return result; - } - - wf.nBlockAlign = (WORD)(wf.nChannels * wf.wBitsPerSample / 8); - wf.nAvgBytesPerSec = wf.nBlockAlign * wf.nSamplesPerSec; - wf.Samples.wValidBitsPerSample = wf.wBitsPerSample; - wf.SubFormat = MA_GUID_KSDATAFORMAT_SUBTYPE_PCM; - - /* The size of the buffer must be a clean multiple of the period count. */ - periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__dsound(pDescriptorCapture, wf.nSamplesPerSec, pConfig->performanceProfile); - periodCount = (pDescriptorCapture->periodCount > 0) ? pDescriptorCapture->periodCount : MA_DEFAULT_PERIODS; - - MA_ZERO_OBJECT(&descDS); - descDS.dwSize = sizeof(descDS); - descDS.dwFlags = 0; - descDS.dwBufferBytes = periodSizeInFrames * periodCount * wf.nBlockAlign; - descDS.lpwfxFormat = (MA_WAVEFORMATEX*)&wf; - hr = ma_IDirectSoundCapture_CreateCaptureBuffer((ma_IDirectSoundCapture*)pDevice->dsound.pCapture, &descDS, (ma_IDirectSoundCaptureBuffer**)&pDevice->dsound.pCaptureBuffer, NULL); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundCapture_CreateCaptureBuffer() failed for capture device."); - return ma_result_from_HRESULT(hr); - } - - /* Get the _actual_ properties of the buffer. */ - pActualFormat = (MA_WAVEFORMATEXTENSIBLE*)rawdata; - hr = ma_IDirectSoundCaptureBuffer_GetFormat((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, (MA_WAVEFORMATEX*)pActualFormat, sizeof(rawdata), NULL); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to retrieve the actual format of the capture device's buffer."); - return ma_result_from_HRESULT(hr); - } - - /* We can now start setting the output data formats. */ - pDescriptorCapture->format = ma_format_from_WAVEFORMATEX((MA_WAVEFORMATEX*)pActualFormat); - pDescriptorCapture->channels = pActualFormat->nChannels; - pDescriptorCapture->sampleRate = pActualFormat->nSamplesPerSec; - - /* Get the native channel map based on the channel mask. */ - if (pActualFormat->wFormatTag == WAVE_FORMAT_EXTENSIBLE) { - ma_channel_mask_to_channel_map__win32(pActualFormat->dwChannelMask, pDescriptorCapture->channels, pDescriptorCapture->channelMap); - } else { - ma_channel_mask_to_channel_map__win32(wf.dwChannelMask, pDescriptorCapture->channels, pDescriptorCapture->channelMap); - } - - /* - After getting the actual format the size of the buffer in frames may have actually changed. However, we want this to be as close to what the - user has asked for as possible, so let's go ahead and release the old capture buffer and create a new one in this case. - */ - if (periodSizeInFrames != (descDS.dwBufferBytes / ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels) / periodCount)) { - descDS.dwBufferBytes = periodSizeInFrames * ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels) * periodCount; - ma_IDirectSoundCaptureBuffer_Release((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer); - - hr = ma_IDirectSoundCapture_CreateCaptureBuffer((ma_IDirectSoundCapture*)pDevice->dsound.pCapture, &descDS, (ma_IDirectSoundCaptureBuffer**)&pDevice->dsound.pCaptureBuffer, NULL); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Second attempt at IDirectSoundCapture_CreateCaptureBuffer() failed for capture device."); - return ma_result_from_HRESULT(hr); - } - } - - /* DirectSound should give us a buffer exactly the size we asked for. */ - pDescriptorCapture->periodSizeInFrames = periodSizeInFrames; - pDescriptorCapture->periodCount = periodCount; - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - MA_WAVEFORMATEXTENSIBLE wf; - MA_DSBUFFERDESC descDSPrimary; - MA_DSCAPS caps; - char rawdata[1024]; /* <-- Ugly hack to avoid a malloc() due to a crappy DirectSound API. */ - MA_WAVEFORMATEXTENSIBLE* pActualFormat; - ma_uint32 periodSizeInFrames; - ma_uint32 periodCount; - MA_DSBUFFERDESC descDS; - WORD nativeChannelCount; - DWORD nativeChannelMask = 0; - - result = ma_config_to_WAVEFORMATEXTENSIBLE(pDescriptorPlayback->format, pDescriptorPlayback->channels, pDescriptorPlayback->sampleRate, pDescriptorPlayback->channelMap, &wf); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_context_create_IDirectSound__dsound(pDevice->pContext, pDescriptorPlayback->shareMode, pDescriptorPlayback->pDeviceID, (ma_IDirectSound**)&pDevice->dsound.pPlayback); - if (result != MA_SUCCESS) { - ma_device_uninit__dsound(pDevice); - return result; - } - - MA_ZERO_OBJECT(&descDSPrimary); - descDSPrimary.dwSize = sizeof(MA_DSBUFFERDESC); - descDSPrimary.dwFlags = MA_DSBCAPS_PRIMARYBUFFER | MA_DSBCAPS_CTRLVOLUME; - hr = ma_IDirectSound_CreateSoundBuffer((ma_IDirectSound*)pDevice->dsound.pPlayback, &descDSPrimary, (ma_IDirectSoundBuffer**)&pDevice->dsound.pPlaybackPrimaryBuffer, NULL); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSound_CreateSoundBuffer() failed for playback device's primary buffer."); - return ma_result_from_HRESULT(hr); - } - - - /* We may want to make some adjustments to the format if we are using defaults. */ - MA_ZERO_OBJECT(&caps); - caps.dwSize = sizeof(caps); - hr = ma_IDirectSound_GetCaps((ma_IDirectSound*)pDevice->dsound.pPlayback, &caps); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSound_GetCaps() failed for playback device."); - return ma_result_from_HRESULT(hr); - } - - if ((caps.dwFlags & MA_DSCAPS_PRIMARYSTEREO) != 0) { - DWORD speakerConfig; - - /* It supports at least stereo, but could support more. */ - nativeChannelCount = 2; - - /* Look at the speaker configuration to get a better idea on the channel count. */ - if (SUCCEEDED(ma_IDirectSound_GetSpeakerConfig((ma_IDirectSound*)pDevice->dsound.pPlayback, &speakerConfig))) { - ma_get_channels_from_speaker_config__dsound(speakerConfig, &nativeChannelCount, &nativeChannelMask); - } - } else { - /* It does not support stereo, which means we are stuck with mono. */ - nativeChannelCount = 1; - nativeChannelMask = 0x00000001; - } - - if (pDescriptorPlayback->channels == 0) { - wf.nChannels = nativeChannelCount; - wf.dwChannelMask = nativeChannelMask; - } - - if (pDescriptorPlayback->sampleRate == 0) { - /* We base the sample rate on the values returned by GetCaps(). */ - if ((caps.dwFlags & MA_DSCAPS_CONTINUOUSRATE) != 0) { - wf.nSamplesPerSec = ma_get_best_sample_rate_within_range(caps.dwMinSecondarySampleRate, caps.dwMaxSecondarySampleRate); - } else { - wf.nSamplesPerSec = caps.dwMaxSecondarySampleRate; - } - } - - wf.nBlockAlign = (WORD)(wf.nChannels * wf.wBitsPerSample / 8); - wf.nAvgBytesPerSec = wf.nBlockAlign * wf.nSamplesPerSec; - - /* - From MSDN: - - The method succeeds even if the hardware does not support the requested format; DirectSound sets the buffer to the closest - supported format. To determine whether this has happened, an application can call the GetFormat method for the primary buffer - and compare the result with the format that was requested with the SetFormat method. - */ - hr = ma_IDirectSoundBuffer_SetFormat((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackPrimaryBuffer, (MA_WAVEFORMATEX*)&wf); - if (FAILED(hr)) { - /* - If setting of the format failed we'll try again with some fallback settings. On Windows 98 I have - observed that IEEE_FLOAT does not work. We'll therefore enforce PCM. I also had issues where a - sample rate of 48000 did not work correctly. Not sure if it was a driver issue or not, but will - use 44100 for the sample rate. - */ - wf.cbSize = 18; /* NOTE: Don't use sizeof(MA_WAVEFORMATEX) here because it's got an extra 2 bytes due to padding. */ - wf.wFormatTag = WAVE_FORMAT_PCM; - wf.wBitsPerSample = 16; - wf.nChannels = nativeChannelCount; - wf.nSamplesPerSec = 44100; - wf.nBlockAlign = wf.nChannels * (wf.wBitsPerSample / 8); - wf.nAvgBytesPerSec = wf.nSamplesPerSec * wf.nBlockAlign; - - hr = ma_IDirectSoundBuffer_SetFormat((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackPrimaryBuffer, (MA_WAVEFORMATEX*)&wf); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to set format of playback device's primary buffer."); - return ma_result_from_HRESULT(hr); - } - } - - /* Get the _actual_ properties of the buffer. */ - pActualFormat = (MA_WAVEFORMATEXTENSIBLE*)rawdata; - hr = ma_IDirectSoundBuffer_GetFormat((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackPrimaryBuffer, (MA_WAVEFORMATEX*)pActualFormat, sizeof(rawdata), NULL); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to retrieve the actual format of the playback device's primary buffer."); - return ma_result_from_HRESULT(hr); - } - - /* We now have enough information to start setting some output properties. */ - pDescriptorPlayback->format = ma_format_from_WAVEFORMATEX((MA_WAVEFORMATEX*)pActualFormat); - pDescriptorPlayback->channels = pActualFormat->nChannels; - pDescriptorPlayback->sampleRate = pActualFormat->nSamplesPerSec; - - /* Get the internal channel map based on the channel mask. */ - if (pActualFormat->wFormatTag == WAVE_FORMAT_EXTENSIBLE) { - ma_channel_mask_to_channel_map__win32(pActualFormat->dwChannelMask, pDescriptorPlayback->channels, pDescriptorPlayback->channelMap); - } else { - ma_channel_mask_to_channel_map__win32(wf.dwChannelMask, pDescriptorPlayback->channels, pDescriptorPlayback->channelMap); - } - - /* The size of the buffer must be a clean multiple of the period count. */ - periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__dsound(pDescriptorPlayback, pDescriptorPlayback->sampleRate, pConfig->performanceProfile); - periodCount = (pDescriptorPlayback->periodCount > 0) ? pDescriptorPlayback->periodCount : MA_DEFAULT_PERIODS; - - /* - Meaning of dwFlags (from MSDN): - - DSBCAPS_CTRLPOSITIONNOTIFY - The buffer has position notification capability. - - DSBCAPS_GLOBALFOCUS - With this flag set, an application using DirectSound can continue to play its buffers if the user switches focus to - another application, even if the new application uses DirectSound. - - DSBCAPS_GETCURRENTPOSITION2 - In the first version of DirectSound, the play cursor was significantly ahead of the actual playing sound on emulated - sound cards; it was directly behind the write cursor. Now, if the DSBCAPS_GETCURRENTPOSITION2 flag is specified, the - application can get a more accurate play cursor. - */ - MA_ZERO_OBJECT(&descDS); - descDS.dwSize = sizeof(descDS); - descDS.dwFlags = MA_DSBCAPS_CTRLPOSITIONNOTIFY | MA_DSBCAPS_GLOBALFOCUS | MA_DSBCAPS_GETCURRENTPOSITION2; - descDS.dwBufferBytes = periodSizeInFrames * periodCount * ma_get_bytes_per_frame(pDescriptorPlayback->format, pDescriptorPlayback->channels); - descDS.lpwfxFormat = (MA_WAVEFORMATEX*)pActualFormat; - hr = ma_IDirectSound_CreateSoundBuffer((ma_IDirectSound*)pDevice->dsound.pPlayback, &descDS, (ma_IDirectSoundBuffer**)&pDevice->dsound.pPlaybackBuffer, NULL); - if (FAILED(hr)) { - ma_device_uninit__dsound(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSound_CreateSoundBuffer() failed for playback device's secondary buffer."); - return ma_result_from_HRESULT(hr); - } - - /* DirectSound should give us a buffer exactly the size we asked for. */ - pDescriptorPlayback->periodSizeInFrames = periodSizeInFrames; - pDescriptorPlayback->periodCount = periodCount; - } - - return MA_SUCCESS; -} - - -static ma_result ma_device_data_loop__dsound(ma_device* pDevice) -{ - ma_result result = MA_SUCCESS; - ma_uint32 bpfDeviceCapture = ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - ma_uint32 bpfDevicePlayback = ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - HRESULT hr; - DWORD lockOffsetInBytesCapture; - DWORD lockSizeInBytesCapture; - DWORD mappedSizeInBytesCapture; - DWORD mappedDeviceFramesProcessedCapture; - void* pMappedDeviceBufferCapture; - DWORD lockOffsetInBytesPlayback; - DWORD lockSizeInBytesPlayback; - DWORD mappedSizeInBytesPlayback; - void* pMappedDeviceBufferPlayback; - DWORD prevReadCursorInBytesCapture = 0; - DWORD prevPlayCursorInBytesPlayback = 0; - ma_bool32 physicalPlayCursorLoopFlagPlayback = 0; - DWORD virtualWriteCursorInBytesPlayback = 0; - ma_bool32 virtualWriteCursorLoopFlagPlayback = 0; - ma_bool32 isPlaybackDeviceStarted = MA_FALSE; - ma_uint32 framesWrittenToPlaybackDevice = 0; /* For knowing whether or not the playback device needs to be started. */ - ma_uint32 waitTimeInMilliseconds = 1; - - MA_ASSERT(pDevice != NULL); - - /* The first thing to do is start the capture device. The playback device is only started after the first period is written. */ - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - hr = ma_IDirectSoundCaptureBuffer_Start((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, MA_DSCBSTART_LOOPING); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundCaptureBuffer_Start() failed."); - return ma_result_from_HRESULT(hr); - } - } - - while (ma_device_get_state(pDevice) == ma_device_state_started) { - switch (pDevice->type) - { - case ma_device_type_duplex: - { - DWORD physicalCaptureCursorInBytes; - DWORD physicalReadCursorInBytes; - hr = ma_IDirectSoundCaptureBuffer_GetCurrentPosition((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, &physicalCaptureCursorInBytes, &physicalReadCursorInBytes); - if (FAILED(hr)) { - return ma_result_from_HRESULT(hr); - } - - /* If nothing is available we just sleep for a bit and return from this iteration. */ - if (physicalReadCursorInBytes == prevReadCursorInBytesCapture) { - ma_sleep(waitTimeInMilliseconds); - continue; /* Nothing is available in the capture buffer. */ - } - - /* - The current position has moved. We need to map all of the captured samples and write them to the playback device, making sure - we don't return until every frame has been copied over. - */ - if (prevReadCursorInBytesCapture < physicalReadCursorInBytes) { - /* The capture position has not looped. This is the simple case. */ - lockOffsetInBytesCapture = prevReadCursorInBytesCapture; - lockSizeInBytesCapture = (physicalReadCursorInBytes - prevReadCursorInBytesCapture); - } else { - /* - The capture position has looped. This is the more complex case. Map to the end of the buffer. If this does not return anything, - do it again from the start. - */ - if (prevReadCursorInBytesCapture < pDevice->capture.internalPeriodSizeInFrames*pDevice->capture.internalPeriods*bpfDeviceCapture) { - /* Lock up to the end of the buffer. */ - lockOffsetInBytesCapture = prevReadCursorInBytesCapture; - lockSizeInBytesCapture = (pDevice->capture.internalPeriodSizeInFrames*pDevice->capture.internalPeriods*bpfDeviceCapture) - prevReadCursorInBytesCapture; - } else { - /* Lock starting from the start of the buffer. */ - lockOffsetInBytesCapture = 0; - lockSizeInBytesCapture = physicalReadCursorInBytes; - } - } - - if (lockSizeInBytesCapture == 0) { - ma_sleep(waitTimeInMilliseconds); - continue; /* Nothing is available in the capture buffer. */ - } - - hr = ma_IDirectSoundCaptureBuffer_Lock((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, lockOffsetInBytesCapture, lockSizeInBytesCapture, &pMappedDeviceBufferCapture, &mappedSizeInBytesCapture, NULL, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to map buffer from capture device in preparation for writing to the device."); - return ma_result_from_HRESULT(hr); - } - - - /* At this point we have some input data that we need to output. We do not return until every mapped frame of the input data is written to the playback device. */ - mappedDeviceFramesProcessedCapture = 0; - - for (;;) { /* Keep writing to the playback device. */ - ma_uint8 inputFramesInClientFormat[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 inputFramesInClientFormatCap = sizeof(inputFramesInClientFormat) / ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels); - ma_uint8 outputFramesInClientFormat[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 outputFramesInClientFormatCap = sizeof(outputFramesInClientFormat) / ma_get_bytes_per_frame(pDevice->playback.format, pDevice->playback.channels); - ma_uint32 outputFramesInClientFormatCount; - ma_uint32 outputFramesInClientFormatConsumed = 0; - ma_uint64 clientCapturedFramesToProcess = ma_min(inputFramesInClientFormatCap, outputFramesInClientFormatCap); - ma_uint64 deviceCapturedFramesToProcess = (mappedSizeInBytesCapture / bpfDeviceCapture) - mappedDeviceFramesProcessedCapture; - void* pRunningMappedDeviceBufferCapture = ma_offset_ptr(pMappedDeviceBufferCapture, mappedDeviceFramesProcessedCapture * bpfDeviceCapture); - - result = ma_data_converter_process_pcm_frames(&pDevice->capture.converter, pRunningMappedDeviceBufferCapture, &deviceCapturedFramesToProcess, inputFramesInClientFormat, &clientCapturedFramesToProcess); - if (result != MA_SUCCESS) { - break; - } - - outputFramesInClientFormatCount = (ma_uint32)clientCapturedFramesToProcess; - mappedDeviceFramesProcessedCapture += (ma_uint32)deviceCapturedFramesToProcess; - - ma_device__handle_data_callback(pDevice, outputFramesInClientFormat, inputFramesInClientFormat, (ma_uint32)clientCapturedFramesToProcess); - - /* At this point we have input and output data in client format. All we need to do now is convert it to the output device format. This may take a few passes. */ - for (;;) { - ma_uint32 framesWrittenThisIteration; - DWORD physicalPlayCursorInBytes; - DWORD physicalWriteCursorInBytes; - DWORD availableBytesPlayback; - DWORD silentPaddingInBytes = 0; /* <-- Must be initialized to 0. */ - - /* We need the physical play and write cursors. */ - if (FAILED(ma_IDirectSoundBuffer_GetCurrentPosition((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, &physicalPlayCursorInBytes, &physicalWriteCursorInBytes))) { - break; - } - - if (physicalPlayCursorInBytes < prevPlayCursorInBytesPlayback) { - physicalPlayCursorLoopFlagPlayback = !physicalPlayCursorLoopFlagPlayback; - } - prevPlayCursorInBytesPlayback = physicalPlayCursorInBytes; - - /* If there's any bytes available for writing we can do that now. The space between the virtual cursor position and play cursor. */ - if (physicalPlayCursorLoopFlagPlayback == virtualWriteCursorLoopFlagPlayback) { - /* Same loop iteration. The available bytes wraps all the way around from the virtual write cursor to the physical play cursor. */ - if (physicalPlayCursorInBytes <= virtualWriteCursorInBytesPlayback) { - availableBytesPlayback = (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) - virtualWriteCursorInBytesPlayback; - availableBytesPlayback += physicalPlayCursorInBytes; /* Wrap around. */ - } else { - /* This is an error. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[DirectSound] (Duplex/Playback): Play cursor has moved in front of the write cursor (same loop iteration). physicalPlayCursorInBytes=%ld, virtualWriteCursorInBytes=%ld.\n", physicalPlayCursorInBytes, virtualWriteCursorInBytesPlayback); - availableBytesPlayback = 0; - } - } else { - /* Different loop iterations. The available bytes only goes from the virtual write cursor to the physical play cursor. */ - if (physicalPlayCursorInBytes >= virtualWriteCursorInBytesPlayback) { - availableBytesPlayback = physicalPlayCursorInBytes - virtualWriteCursorInBytesPlayback; - } else { - /* This is an error. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[DirectSound] (Duplex/Playback): Write cursor has moved behind the play cursor (different loop iterations). physicalPlayCursorInBytes=%ld, virtualWriteCursorInBytes=%ld.\n", physicalPlayCursorInBytes, virtualWriteCursorInBytesPlayback); - availableBytesPlayback = 0; - } - } - - /* If there's no room available for writing we need to wait for more. */ - if (availableBytesPlayback == 0) { - /* If we haven't started the device yet, this will never get beyond 0. In this case we need to get the device started. */ - if (!isPlaybackDeviceStarted) { - hr = ma_IDirectSoundBuffer_Play((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, 0, 0, MA_DSBPLAY_LOOPING); - if (FAILED(hr)) { - ma_IDirectSoundCaptureBuffer_Stop((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundBuffer_Play() failed."); - return ma_result_from_HRESULT(hr); - } - isPlaybackDeviceStarted = MA_TRUE; - } else { - ma_sleep(waitTimeInMilliseconds); - continue; - } - } - - - /* Getting here means there room available somewhere. We limit this to either the end of the buffer or the physical play cursor, whichever is closest. */ - lockOffsetInBytesPlayback = virtualWriteCursorInBytesPlayback; - if (physicalPlayCursorLoopFlagPlayback == virtualWriteCursorLoopFlagPlayback) { - /* Same loop iteration. Go up to the end of the buffer. */ - lockSizeInBytesPlayback = (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) - virtualWriteCursorInBytesPlayback; - } else { - /* Different loop iterations. Go up to the physical play cursor. */ - lockSizeInBytesPlayback = physicalPlayCursorInBytes - virtualWriteCursorInBytesPlayback; - } - - hr = ma_IDirectSoundBuffer_Lock((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, lockOffsetInBytesPlayback, lockSizeInBytesPlayback, &pMappedDeviceBufferPlayback, &mappedSizeInBytesPlayback, NULL, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to map buffer from playback device in preparation for writing to the device."); - result = ma_result_from_HRESULT(hr); - break; - } - - /* - Experiment: If the playback buffer is being starved, pad it with some silence to get it back in sync. This will cause a glitch, but it may prevent - endless glitching due to it constantly running out of data. - */ - if (isPlaybackDeviceStarted) { - DWORD bytesQueuedForPlayback = (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) - availableBytesPlayback; - if (bytesQueuedForPlayback < (pDevice->playback.internalPeriodSizeInFrames*bpfDevicePlayback)) { - silentPaddingInBytes = (pDevice->playback.internalPeriodSizeInFrames*2*bpfDevicePlayback) - bytesQueuedForPlayback; - if (silentPaddingInBytes > lockSizeInBytesPlayback) { - silentPaddingInBytes = lockSizeInBytesPlayback; - } - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[DirectSound] (Duplex/Playback) Playback buffer starved. availableBytesPlayback=%ld, silentPaddingInBytes=%ld\n", availableBytesPlayback, silentPaddingInBytes); - } - } - - /* At this point we have a buffer for output. */ - if (silentPaddingInBytes > 0) { - MA_ZERO_MEMORY(pMappedDeviceBufferPlayback, silentPaddingInBytes); - framesWrittenThisIteration = silentPaddingInBytes/bpfDevicePlayback; - } else { - ma_uint64 convertedFrameCountIn = (outputFramesInClientFormatCount - outputFramesInClientFormatConsumed); - ma_uint64 convertedFrameCountOut = mappedSizeInBytesPlayback/bpfDevicePlayback; - void* pConvertedFramesIn = ma_offset_ptr(outputFramesInClientFormat, outputFramesInClientFormatConsumed * bpfDevicePlayback); - void* pConvertedFramesOut = pMappedDeviceBufferPlayback; - - result = ma_data_converter_process_pcm_frames(&pDevice->playback.converter, pConvertedFramesIn, &convertedFrameCountIn, pConvertedFramesOut, &convertedFrameCountOut); - if (result != MA_SUCCESS) { - break; - } - - outputFramesInClientFormatConsumed += (ma_uint32)convertedFrameCountOut; - framesWrittenThisIteration = (ma_uint32)convertedFrameCountOut; - } - - - hr = ma_IDirectSoundBuffer_Unlock((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, pMappedDeviceBufferPlayback, framesWrittenThisIteration*bpfDevicePlayback, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to unlock internal buffer from playback device after writing to the device."); - result = ma_result_from_HRESULT(hr); - break; - } - - virtualWriteCursorInBytesPlayback += framesWrittenThisIteration*bpfDevicePlayback; - if ((virtualWriteCursorInBytesPlayback/bpfDevicePlayback) == pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods) { - virtualWriteCursorInBytesPlayback = 0; - virtualWriteCursorLoopFlagPlayback = !virtualWriteCursorLoopFlagPlayback; - } - - /* - We may need to start the device. We want two full periods to be written before starting the playback device. Having an extra period adds - a bit of a buffer to prevent the playback buffer from getting starved. - */ - framesWrittenToPlaybackDevice += framesWrittenThisIteration; - if (!isPlaybackDeviceStarted && framesWrittenToPlaybackDevice >= (pDevice->playback.internalPeriodSizeInFrames*2)) { - hr = ma_IDirectSoundBuffer_Play((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, 0, 0, MA_DSBPLAY_LOOPING); - if (FAILED(hr)) { - ma_IDirectSoundCaptureBuffer_Stop((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundBuffer_Play() failed."); - return ma_result_from_HRESULT(hr); - } - isPlaybackDeviceStarted = MA_TRUE; - } - - if (framesWrittenThisIteration < mappedSizeInBytesPlayback/bpfDevicePlayback) { - break; /* We're finished with the output data.*/ - } - } - - if (clientCapturedFramesToProcess == 0) { - break; /* We just consumed every input sample. */ - } - } - - - /* At this point we're done with the mapped portion of the capture buffer. */ - hr = ma_IDirectSoundCaptureBuffer_Unlock((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, pMappedDeviceBufferCapture, mappedSizeInBytesCapture, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to unlock internal buffer from capture device after reading from the device."); - return ma_result_from_HRESULT(hr); - } - prevReadCursorInBytesCapture = (lockOffsetInBytesCapture + mappedSizeInBytesCapture); - } break; - - - - case ma_device_type_capture: - { - DWORD physicalCaptureCursorInBytes; - DWORD physicalReadCursorInBytes; - hr = ma_IDirectSoundCaptureBuffer_GetCurrentPosition((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, &physicalCaptureCursorInBytes, &physicalReadCursorInBytes); - if (FAILED(hr)) { - return MA_ERROR; - } - - /* If the previous capture position is the same as the current position we need to wait a bit longer. */ - if (prevReadCursorInBytesCapture == physicalReadCursorInBytes) { - ma_sleep(waitTimeInMilliseconds); - continue; - } - - /* Getting here means we have capture data available. */ - if (prevReadCursorInBytesCapture < physicalReadCursorInBytes) { - /* The capture position has not looped. This is the simple case. */ - lockOffsetInBytesCapture = prevReadCursorInBytesCapture; - lockSizeInBytesCapture = (physicalReadCursorInBytes - prevReadCursorInBytesCapture); - } else { - /* - The capture position has looped. This is the more complex case. Map to the end of the buffer. If this does not return anything, - do it again from the start. - */ - if (prevReadCursorInBytesCapture < pDevice->capture.internalPeriodSizeInFrames*pDevice->capture.internalPeriods*bpfDeviceCapture) { - /* Lock up to the end of the buffer. */ - lockOffsetInBytesCapture = prevReadCursorInBytesCapture; - lockSizeInBytesCapture = (pDevice->capture.internalPeriodSizeInFrames*pDevice->capture.internalPeriods*bpfDeviceCapture) - prevReadCursorInBytesCapture; - } else { - /* Lock starting from the start of the buffer. */ - lockOffsetInBytesCapture = 0; - lockSizeInBytesCapture = physicalReadCursorInBytes; - } - } - - if (lockSizeInBytesCapture < pDevice->capture.internalPeriodSizeInFrames) { - ma_sleep(waitTimeInMilliseconds); - continue; /* Nothing is available in the capture buffer. */ - } - - hr = ma_IDirectSoundCaptureBuffer_Lock((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, lockOffsetInBytesCapture, lockSizeInBytesCapture, &pMappedDeviceBufferCapture, &mappedSizeInBytesCapture, NULL, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to map buffer from capture device in preparation for writing to the device."); - result = ma_result_from_HRESULT(hr); - } - - if (lockSizeInBytesCapture != mappedSizeInBytesCapture) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[DirectSound] (Capture) lockSizeInBytesCapture=%ld != mappedSizeInBytesCapture=%ld\n", lockSizeInBytesCapture, mappedSizeInBytesCapture); - } - - ma_device__send_frames_to_client(pDevice, mappedSizeInBytesCapture/bpfDeviceCapture, pMappedDeviceBufferCapture); - - hr = ma_IDirectSoundCaptureBuffer_Unlock((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer, pMappedDeviceBufferCapture, mappedSizeInBytesCapture, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to unlock internal buffer from capture device after reading from the device."); - return ma_result_from_HRESULT(hr); - } - prevReadCursorInBytesCapture = lockOffsetInBytesCapture + mappedSizeInBytesCapture; - - if (prevReadCursorInBytesCapture == (pDevice->capture.internalPeriodSizeInFrames*pDevice->capture.internalPeriods*bpfDeviceCapture)) { - prevReadCursorInBytesCapture = 0; - } - } break; - - - - case ma_device_type_playback: - { - DWORD availableBytesPlayback; - DWORD physicalPlayCursorInBytes; - DWORD physicalWriteCursorInBytes; - hr = ma_IDirectSoundBuffer_GetCurrentPosition((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, &physicalPlayCursorInBytes, &physicalWriteCursorInBytes); - if (FAILED(hr)) { - break; - } - - if (physicalPlayCursorInBytes < prevPlayCursorInBytesPlayback) { - physicalPlayCursorLoopFlagPlayback = !physicalPlayCursorLoopFlagPlayback; - } - prevPlayCursorInBytesPlayback = physicalPlayCursorInBytes; - - /* If there's any bytes available for writing we can do that now. The space between the virtual cursor position and play cursor. */ - if (physicalPlayCursorLoopFlagPlayback == virtualWriteCursorLoopFlagPlayback) { - /* Same loop iteration. The available bytes wraps all the way around from the virtual write cursor to the physical play cursor. */ - if (physicalPlayCursorInBytes <= virtualWriteCursorInBytesPlayback) { - availableBytesPlayback = (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) - virtualWriteCursorInBytesPlayback; - availableBytesPlayback += physicalPlayCursorInBytes; /* Wrap around. */ - } else { - /* This is an error. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[DirectSound] (Playback): Play cursor has moved in front of the write cursor (same loop iterations). physicalPlayCursorInBytes=%ld, virtualWriteCursorInBytes=%ld.\n", physicalPlayCursorInBytes, virtualWriteCursorInBytesPlayback); - availableBytesPlayback = 0; - } - } else { - /* Different loop iterations. The available bytes only goes from the virtual write cursor to the physical play cursor. */ - if (physicalPlayCursorInBytes >= virtualWriteCursorInBytesPlayback) { - availableBytesPlayback = physicalPlayCursorInBytes - virtualWriteCursorInBytesPlayback; - } else { - /* This is an error. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[DirectSound] (Playback): Write cursor has moved behind the play cursor (different loop iterations). physicalPlayCursorInBytes=%ld, virtualWriteCursorInBytes=%ld.\n", physicalPlayCursorInBytes, virtualWriteCursorInBytesPlayback); - availableBytesPlayback = 0; - } - } - - /* If there's no room available for writing we need to wait for more. */ - if (availableBytesPlayback < pDevice->playback.internalPeriodSizeInFrames) { - /* If we haven't started the device yet, this will never get beyond 0. In this case we need to get the device started. */ - if (availableBytesPlayback == 0 && !isPlaybackDeviceStarted) { - hr = ma_IDirectSoundBuffer_Play((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, 0, 0, MA_DSBPLAY_LOOPING); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundBuffer_Play() failed."); - return ma_result_from_HRESULT(hr); - } - isPlaybackDeviceStarted = MA_TRUE; - } else { - ma_sleep(waitTimeInMilliseconds); - continue; - } - } - - /* Getting here means there room available somewhere. We limit this to either the end of the buffer or the physical play cursor, whichever is closest. */ - lockOffsetInBytesPlayback = virtualWriteCursorInBytesPlayback; - if (physicalPlayCursorLoopFlagPlayback == virtualWriteCursorLoopFlagPlayback) { - /* Same loop iteration. Go up to the end of the buffer. */ - lockSizeInBytesPlayback = (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) - virtualWriteCursorInBytesPlayback; - } else { - /* Different loop iterations. Go up to the physical play cursor. */ - lockSizeInBytesPlayback = physicalPlayCursorInBytes - virtualWriteCursorInBytesPlayback; - } - - hr = ma_IDirectSoundBuffer_Lock((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, lockOffsetInBytesPlayback, lockSizeInBytesPlayback, &pMappedDeviceBufferPlayback, &mappedSizeInBytesPlayback, NULL, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to map buffer from playback device in preparation for writing to the device."); - result = ma_result_from_HRESULT(hr); - break; - } - - /* At this point we have a buffer for output. */ - ma_device__read_frames_from_client(pDevice, (mappedSizeInBytesPlayback/bpfDevicePlayback), pMappedDeviceBufferPlayback); - - hr = ma_IDirectSoundBuffer_Unlock((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, pMappedDeviceBufferPlayback, mappedSizeInBytesPlayback, NULL, 0); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] Failed to unlock internal buffer from playback device after writing to the device."); - result = ma_result_from_HRESULT(hr); - break; - } - - virtualWriteCursorInBytesPlayback += mappedSizeInBytesPlayback; - if (virtualWriteCursorInBytesPlayback == pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) { - virtualWriteCursorInBytesPlayback = 0; - virtualWriteCursorLoopFlagPlayback = !virtualWriteCursorLoopFlagPlayback; - } - - /* - We may need to start the device. We want two full periods to be written before starting the playback device. Having an extra period adds - a bit of a buffer to prevent the playback buffer from getting starved. - */ - framesWrittenToPlaybackDevice += mappedSizeInBytesPlayback/bpfDevicePlayback; - if (!isPlaybackDeviceStarted && framesWrittenToPlaybackDevice >= pDevice->playback.internalPeriodSizeInFrames) { - hr = ma_IDirectSoundBuffer_Play((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, 0, 0, MA_DSBPLAY_LOOPING); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundBuffer_Play() failed."); - return ma_result_from_HRESULT(hr); - } - isPlaybackDeviceStarted = MA_TRUE; - } - } break; - - - default: return MA_INVALID_ARGS; /* Invalid device type. */ - } - - if (result != MA_SUCCESS) { - return result; - } - } - - /* Getting here means the device is being stopped. */ - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - hr = ma_IDirectSoundCaptureBuffer_Stop((ma_IDirectSoundCaptureBuffer*)pDevice->dsound.pCaptureBuffer); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundCaptureBuffer_Stop() failed."); - return ma_result_from_HRESULT(hr); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - /* The playback device should be drained before stopping. All we do is wait until the available bytes is equal to the size of the buffer. */ - if (isPlaybackDeviceStarted) { - for (;;) { - DWORD availableBytesPlayback = 0; - DWORD physicalPlayCursorInBytes; - DWORD physicalWriteCursorInBytes; - hr = ma_IDirectSoundBuffer_GetCurrentPosition((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, &physicalPlayCursorInBytes, &physicalWriteCursorInBytes); - if (FAILED(hr)) { - break; - } - - if (physicalPlayCursorInBytes < prevPlayCursorInBytesPlayback) { - physicalPlayCursorLoopFlagPlayback = !physicalPlayCursorLoopFlagPlayback; - } - prevPlayCursorInBytesPlayback = physicalPlayCursorInBytes; - - if (physicalPlayCursorLoopFlagPlayback == virtualWriteCursorLoopFlagPlayback) { - /* Same loop iteration. The available bytes wraps all the way around from the virtual write cursor to the physical play cursor. */ - if (physicalPlayCursorInBytes <= virtualWriteCursorInBytesPlayback) { - availableBytesPlayback = (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback) - virtualWriteCursorInBytesPlayback; - availableBytesPlayback += physicalPlayCursorInBytes; /* Wrap around. */ - } else { - break; - } - } else { - /* Different loop iterations. The available bytes only goes from the virtual write cursor to the physical play cursor. */ - if (physicalPlayCursorInBytes >= virtualWriteCursorInBytesPlayback) { - availableBytesPlayback = physicalPlayCursorInBytes - virtualWriteCursorInBytesPlayback; - } else { - break; - } - } - - if (availableBytesPlayback >= (pDevice->playback.internalPeriodSizeInFrames*pDevice->playback.internalPeriods*bpfDevicePlayback)) { - break; - } - - ma_sleep(waitTimeInMilliseconds); - } - } - - hr = ma_IDirectSoundBuffer_Stop((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer); - if (FAILED(hr)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[DirectSound] IDirectSoundBuffer_Stop() failed."); - return ma_result_from_HRESULT(hr); - } - - ma_IDirectSoundBuffer_SetCurrentPosition((ma_IDirectSoundBuffer*)pDevice->dsound.pPlaybackBuffer, 0); - } - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__dsound(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_dsound); - - ma_dlclose(pContext, pContext->dsound.hDSoundDLL); - - return MA_SUCCESS; -} - -static ma_result ma_context_init__dsound(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - MA_ASSERT(pContext != NULL); - - (void)pConfig; - - pContext->dsound.hDSoundDLL = ma_dlopen(pContext, "dsound.dll"); - if (pContext->dsound.hDSoundDLL == NULL) { - return MA_API_NOT_FOUND; - } - - pContext->dsound.DirectSoundCreate = ma_dlsym(pContext, pContext->dsound.hDSoundDLL, "DirectSoundCreate"); - pContext->dsound.DirectSoundEnumerateA = ma_dlsym(pContext, pContext->dsound.hDSoundDLL, "DirectSoundEnumerateA"); - pContext->dsound.DirectSoundCaptureCreate = ma_dlsym(pContext, pContext->dsound.hDSoundDLL, "DirectSoundCaptureCreate"); - pContext->dsound.DirectSoundCaptureEnumerateA = ma_dlsym(pContext, pContext->dsound.hDSoundDLL, "DirectSoundCaptureEnumerateA"); - - /* - We need to support all functions or nothing. DirectSound with Windows 95 seems to not work too - well in my testing. For example, it's missing DirectSoundCaptureEnumerateA(). This is a convenient - place to just disable the DirectSound backend for Windows 95. - */ - if (pContext->dsound.DirectSoundCreate == NULL || - pContext->dsound.DirectSoundEnumerateA == NULL || - pContext->dsound.DirectSoundCaptureCreate == NULL || - pContext->dsound.DirectSoundCaptureEnumerateA == NULL) { - return MA_API_NOT_FOUND; - } - - pCallbacks->onContextInit = ma_context_init__dsound; - pCallbacks->onContextUninit = ma_context_uninit__dsound; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__dsound; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__dsound; - pCallbacks->onDeviceInit = ma_device_init__dsound; - pCallbacks->onDeviceUninit = ma_device_uninit__dsound; - pCallbacks->onDeviceStart = NULL; /* Not used. Started in onDeviceDataLoop. */ - pCallbacks->onDeviceStop = NULL; /* Not used. Stopped in onDeviceDataLoop. */ - pCallbacks->onDeviceRead = NULL; /* Not used. Data is read directly in onDeviceDataLoop. */ - pCallbacks->onDeviceWrite = NULL; /* Not used. Data is written directly in onDeviceDataLoop. */ - pCallbacks->onDeviceDataLoop = ma_device_data_loop__dsound; - - return MA_SUCCESS; -} -#endif - - - -/****************************************************************************** - -WinMM Backend - -******************************************************************************/ -#ifdef MA_HAS_WINMM - -/* -Some older compilers don't have WAVEOUTCAPS2A and WAVEINCAPS2A, so we'll need to write this ourselves. These structures -are exactly the same as the older ones but they have a few GUIDs for manufacturer/product/name identification. I'm keeping -the names the same as the Win32 library for consistency, but namespaced to avoid naming conflicts with the Win32 version. -*/ -typedef struct -{ - WORD wMid; - WORD wPid; - MMVERSION vDriverVersion; - CHAR szPname[MAXPNAMELEN]; - DWORD dwFormats; - WORD wChannels; - WORD wReserved1; - DWORD dwSupport; - GUID ManufacturerGuid; - GUID ProductGuid; - GUID NameGuid; -} MA_WAVEOUTCAPS2A; -typedef struct -{ - WORD wMid; - WORD wPid; - MMVERSION vDriverVersion; - CHAR szPname[MAXPNAMELEN]; - DWORD dwFormats; - WORD wChannels; - WORD wReserved1; - GUID ManufacturerGuid; - GUID ProductGuid; - GUID NameGuid; -} MA_WAVEINCAPS2A; - -typedef UINT (WINAPI * MA_PFN_waveOutGetNumDevs)(void); -typedef MMRESULT (WINAPI * MA_PFN_waveOutGetDevCapsA)(ma_uintptr uDeviceID, WAVEOUTCAPSA* pwoc, UINT cbwoc); -typedef MMRESULT (WINAPI * MA_PFN_waveOutOpen)(HWAVEOUT* phwo, UINT uDeviceID, const MA_WAVEFORMATEX* pwfx, DWORD_PTR dwCallback, DWORD_PTR dwInstance, DWORD fdwOpen); -typedef MMRESULT (WINAPI * MA_PFN_waveOutClose)(HWAVEOUT hwo); -typedef MMRESULT (WINAPI * MA_PFN_waveOutPrepareHeader)(HWAVEOUT hwo, WAVEHDR* pwh, UINT cbwh); -typedef MMRESULT (WINAPI * MA_PFN_waveOutUnprepareHeader)(HWAVEOUT hwo, WAVEHDR* pwh, UINT cbwh); -typedef MMRESULT (WINAPI * MA_PFN_waveOutWrite)(HWAVEOUT hwo, WAVEHDR* pwh, UINT cbwh); -typedef MMRESULT (WINAPI * MA_PFN_waveOutReset)(HWAVEOUT hwo); -typedef UINT (WINAPI * MA_PFN_waveInGetNumDevs)(void); -typedef MMRESULT (WINAPI * MA_PFN_waveInGetDevCapsA)(ma_uintptr uDeviceID, WAVEINCAPSA* pwic, UINT cbwic); -typedef MMRESULT (WINAPI * MA_PFN_waveInOpen)(HWAVEIN* phwi, UINT uDeviceID, const MA_WAVEFORMATEX* pwfx, DWORD_PTR dwCallback, DWORD_PTR dwInstance, DWORD fdwOpen); -typedef MMRESULT (WINAPI * MA_PFN_waveInClose)(HWAVEIN hwi); -typedef MMRESULT (WINAPI * MA_PFN_waveInPrepareHeader)(HWAVEIN hwi, WAVEHDR* pwh, UINT cbwh); -typedef MMRESULT (WINAPI * MA_PFN_waveInUnprepareHeader)(HWAVEIN hwi, WAVEHDR* pwh, UINT cbwh); -typedef MMRESULT (WINAPI * MA_PFN_waveInAddBuffer)(HWAVEIN hwi, WAVEHDR* pwh, UINT cbwh); -typedef MMRESULT (WINAPI * MA_PFN_waveInStart)(HWAVEIN hwi); -typedef MMRESULT (WINAPI * MA_PFN_waveInReset)(HWAVEIN hwi); - -static ma_result ma_result_from_MMRESULT(MMRESULT resultMM) -{ - switch (resultMM) - { - case MMSYSERR_NOERROR: return MA_SUCCESS; - case MMSYSERR_BADDEVICEID: return MA_INVALID_ARGS; - case MMSYSERR_INVALHANDLE: return MA_INVALID_ARGS; - case MMSYSERR_NOMEM: return MA_OUT_OF_MEMORY; - case MMSYSERR_INVALFLAG: return MA_INVALID_ARGS; - case MMSYSERR_INVALPARAM: return MA_INVALID_ARGS; - case MMSYSERR_HANDLEBUSY: return MA_BUSY; - case MMSYSERR_ERROR: return MA_ERROR; - default: return MA_ERROR; - } -} - -static char* ma_find_last_character(char* str, char ch) -{ - char* last; - - if (str == NULL) { - return NULL; - } - - last = NULL; - while (*str != '\0') { - if (*str == ch) { - last = str; - } - - str += 1; - } - - return last; -} - -static ma_uint32 ma_get_period_size_in_bytes(ma_uint32 periodSizeInFrames, ma_format format, ma_uint32 channels) -{ - return periodSizeInFrames * ma_get_bytes_per_frame(format, channels); -} - - -/* -Our own "WAVECAPS" structure that contains generic information shared between WAVEOUTCAPS2 and WAVEINCAPS2 so -we can do things generically and typesafely. Names are being kept the same for consistency. -*/ -typedef struct -{ - CHAR szPname[MAXPNAMELEN]; - DWORD dwFormats; - WORD wChannels; - GUID NameGuid; -} MA_WAVECAPSA; - -static ma_result ma_get_best_info_from_formats_flags__winmm(DWORD dwFormats, WORD channels, WORD* pBitsPerSample, DWORD* pSampleRate) -{ - WORD bitsPerSample = 0; - DWORD sampleRate = 0; - - if (pBitsPerSample) { - *pBitsPerSample = 0; - } - if (pSampleRate) { - *pSampleRate = 0; - } - - if (channels == 1) { - bitsPerSample = 16; - if ((dwFormats & WAVE_FORMAT_48M16) != 0) { - sampleRate = 48000; - } else if ((dwFormats & WAVE_FORMAT_44M16) != 0) { - sampleRate = 44100; - } else if ((dwFormats & WAVE_FORMAT_2M16) != 0) { - sampleRate = 22050; - } else if ((dwFormats & WAVE_FORMAT_1M16) != 0) { - sampleRate = 11025; - } else if ((dwFormats & WAVE_FORMAT_96M16) != 0) { - sampleRate = 96000; - } else { - bitsPerSample = 8; - if ((dwFormats & WAVE_FORMAT_48M08) != 0) { - sampleRate = 48000; - } else if ((dwFormats & WAVE_FORMAT_44M08) != 0) { - sampleRate = 44100; - } else if ((dwFormats & WAVE_FORMAT_2M08) != 0) { - sampleRate = 22050; - } else if ((dwFormats & WAVE_FORMAT_1M08) != 0) { - sampleRate = 11025; - } else if ((dwFormats & WAVE_FORMAT_96M08) != 0) { - sampleRate = 96000; - } else { - return MA_FORMAT_NOT_SUPPORTED; - } - } - } else { - bitsPerSample = 16; - if ((dwFormats & WAVE_FORMAT_48S16) != 0) { - sampleRate = 48000; - } else if ((dwFormats & WAVE_FORMAT_44S16) != 0) { - sampleRate = 44100; - } else if ((dwFormats & WAVE_FORMAT_2S16) != 0) { - sampleRate = 22050; - } else if ((dwFormats & WAVE_FORMAT_1S16) != 0) { - sampleRate = 11025; - } else if ((dwFormats & WAVE_FORMAT_96S16) != 0) { - sampleRate = 96000; - } else { - bitsPerSample = 8; - if ((dwFormats & WAVE_FORMAT_48S08) != 0) { - sampleRate = 48000; - } else if ((dwFormats & WAVE_FORMAT_44S08) != 0) { - sampleRate = 44100; - } else if ((dwFormats & WAVE_FORMAT_2S08) != 0) { - sampleRate = 22050; - } else if ((dwFormats & WAVE_FORMAT_1S08) != 0) { - sampleRate = 11025; - } else if ((dwFormats & WAVE_FORMAT_96S08) != 0) { - sampleRate = 96000; - } else { - return MA_FORMAT_NOT_SUPPORTED; - } - } - } - - if (pBitsPerSample) { - *pBitsPerSample = bitsPerSample; - } - if (pSampleRate) { - *pSampleRate = sampleRate; - } - - return MA_SUCCESS; -} - -static ma_result ma_formats_flags_to_WAVEFORMATEX__winmm(DWORD dwFormats, WORD channels, MA_WAVEFORMATEX* pWF) -{ - ma_result result; - - MA_ASSERT(pWF != NULL); - - MA_ZERO_OBJECT(pWF); - pWF->cbSize = sizeof(*pWF); - pWF->wFormatTag = WAVE_FORMAT_PCM; - pWF->nChannels = (WORD)channels; - if (pWF->nChannels > 2) { - pWF->nChannels = 2; - } - - result = ma_get_best_info_from_formats_flags__winmm(dwFormats, channels, &pWF->wBitsPerSample, &pWF->nSamplesPerSec); - if (result != MA_SUCCESS) { - return result; - } - - pWF->nBlockAlign = (WORD)(pWF->nChannels * pWF->wBitsPerSample / 8); - pWF->nAvgBytesPerSec = pWF->nBlockAlign * pWF->nSamplesPerSec; - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info_from_WAVECAPS(ma_context* pContext, MA_WAVECAPSA* pCaps, ma_device_info* pDeviceInfo) -{ - WORD bitsPerSample; - DWORD sampleRate; - ma_result result; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pCaps != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - /* - Name / Description - - Unfortunately the name specified in WAVE(OUT/IN)CAPS2 is limited to 31 characters. This results in an unprofessional looking - situation where the names of the devices are truncated. To help work around this, we need to look at the name GUID and try - looking in the registry for the full name. If we can't find it there, we need to just fall back to the default name. - */ - - /* Set the default to begin with. */ - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), pCaps->szPname, (size_t)-1); - - /* - Now try the registry. There's a few things to consider here: - - The name GUID can be null, in which we case we just need to stick to the original 31 characters. - - If the name GUID is not present in the registry we'll also need to stick to the original 31 characters. - - I like consistency, so I want the returned device names to be consistent with those returned by WASAPI and DirectSound. The - problem, however is that WASAPI and DirectSound use " ()" format (such as "Speakers (High Definition Audio)"), - but WinMM does not specificy the component name. From my admittedly limited testing, I've notice the component name seems to - usually fit within the 31 characters of the fixed sized buffer, so what I'm going to do is parse that string for the component - name, and then concatenate the name from the registry. - */ - if (!ma_is_guid_null(&pCaps->NameGuid)) { - WCHAR guidStrW[256]; - if (((MA_PFN_StringFromGUID2)pContext->win32.StringFromGUID2)(&pCaps->NameGuid, guidStrW, ma_countof(guidStrW)) > 0) { - char guidStr[256]; - char keyStr[1024]; - HKEY hKey; - - WideCharToMultiByte(CP_UTF8, 0, guidStrW, -1, guidStr, sizeof(guidStr), 0, FALSE); - - ma_strcpy_s(keyStr, sizeof(keyStr), "SYSTEM\\CurrentControlSet\\Control\\MediaCategories\\"); - ma_strcat_s(keyStr, sizeof(keyStr), guidStr); - - if (((MA_PFN_RegOpenKeyExA)pContext->win32.RegOpenKeyExA)(HKEY_LOCAL_MACHINE, keyStr, 0, KEY_READ, &hKey) == ERROR_SUCCESS) { - BYTE nameFromReg[512]; - DWORD nameFromRegSize = sizeof(nameFromReg); - LONG resultWin32 = ((MA_PFN_RegQueryValueExA)pContext->win32.RegQueryValueExA)(hKey, "Name", 0, NULL, (BYTE*)nameFromReg, (DWORD*)&nameFromRegSize); - ((MA_PFN_RegCloseKey)pContext->win32.RegCloseKey)(hKey); - - if (resultWin32 == ERROR_SUCCESS) { - /* We have the value from the registry, so now we need to construct the name string. */ - char name[1024]; - if (ma_strcpy_s(name, sizeof(name), pDeviceInfo->name) == 0) { - char* nameBeg = ma_find_last_character(name, '('); - if (nameBeg != NULL) { - size_t leadingLen = (nameBeg - name); - ma_strncpy_s(nameBeg + 1, sizeof(name) - leadingLen, (const char*)nameFromReg, (size_t)-1); - - /* The closing ")", if it can fit. */ - if (leadingLen + nameFromRegSize < sizeof(name)-1) { - ma_strcat_s(name, sizeof(name), ")"); - } - - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), name, (size_t)-1); - } - } - } - } - } - } - - - result = ma_get_best_info_from_formats_flags__winmm(pCaps->dwFormats, pCaps->wChannels, &bitsPerSample, &sampleRate); - if (result != MA_SUCCESS) { - return result; - } - - if (bitsPerSample == 8) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_u8; - } else if (bitsPerSample == 16) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_s16; - } else if (bitsPerSample == 24) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_s24; - } else if (bitsPerSample == 32) { - pDeviceInfo->nativeDataFormats[0].format = ma_format_s32; - } else { - return MA_FORMAT_NOT_SUPPORTED; - } - pDeviceInfo->nativeDataFormats[0].channels = pCaps->wChannels; - pDeviceInfo->nativeDataFormats[0].sampleRate = sampleRate; - pDeviceInfo->nativeDataFormats[0].flags = 0; - pDeviceInfo->nativeDataFormatCount = 1; - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info_from_WAVEOUTCAPS2(ma_context* pContext, MA_WAVEOUTCAPS2A* pCaps, ma_device_info* pDeviceInfo) -{ - MA_WAVECAPSA caps; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pCaps != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - MA_COPY_MEMORY(caps.szPname, pCaps->szPname, sizeof(caps.szPname)); - caps.dwFormats = pCaps->dwFormats; - caps.wChannels = pCaps->wChannels; - caps.NameGuid = pCaps->NameGuid; - return ma_context_get_device_info_from_WAVECAPS(pContext, &caps, pDeviceInfo); -} - -static ma_result ma_context_get_device_info_from_WAVEINCAPS2(ma_context* pContext, MA_WAVEINCAPS2A* pCaps, ma_device_info* pDeviceInfo) -{ - MA_WAVECAPSA caps; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pCaps != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - MA_COPY_MEMORY(caps.szPname, pCaps->szPname, sizeof(caps.szPname)); - caps.dwFormats = pCaps->dwFormats; - caps.wChannels = pCaps->wChannels; - caps.NameGuid = pCaps->NameGuid; - return ma_context_get_device_info_from_WAVECAPS(pContext, &caps, pDeviceInfo); -} - - -static ma_result ma_context_enumerate_devices__winmm(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - UINT playbackDeviceCount; - UINT captureDeviceCount; - UINT iPlaybackDevice; - UINT iCaptureDevice; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* Playback. */ - playbackDeviceCount = ((MA_PFN_waveOutGetNumDevs)pContext->winmm.waveOutGetNumDevs)(); - for (iPlaybackDevice = 0; iPlaybackDevice < playbackDeviceCount; ++iPlaybackDevice) { - MMRESULT result; - MA_WAVEOUTCAPS2A caps; - - MA_ZERO_OBJECT(&caps); - - result = ((MA_PFN_waveOutGetDevCapsA)pContext->winmm.waveOutGetDevCapsA)(iPlaybackDevice, (WAVEOUTCAPSA*)&caps, sizeof(caps)); - if (result == MMSYSERR_NOERROR) { - ma_device_info deviceInfo; - - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.winmm = iPlaybackDevice; - - /* The first enumerated device is the default device. */ - if (iPlaybackDevice == 0) { - deviceInfo.isDefault = MA_TRUE; - } - - if (ma_context_get_device_info_from_WAVEOUTCAPS2(pContext, &caps, &deviceInfo) == MA_SUCCESS) { - ma_bool32 cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - if (cbResult == MA_FALSE) { - return MA_SUCCESS; /* Enumeration was stopped. */ - } - } - } - } - - /* Capture. */ - captureDeviceCount = ((MA_PFN_waveInGetNumDevs)pContext->winmm.waveInGetNumDevs)(); - for (iCaptureDevice = 0; iCaptureDevice < captureDeviceCount; ++iCaptureDevice) { - MMRESULT result; - MA_WAVEINCAPS2A caps; - - MA_ZERO_OBJECT(&caps); - - result = ((MA_PFN_waveInGetDevCapsA)pContext->winmm.waveInGetDevCapsA)(iCaptureDevice, (WAVEINCAPSA*)&caps, sizeof(caps)); - if (result == MMSYSERR_NOERROR) { - ma_device_info deviceInfo; - - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.winmm = iCaptureDevice; - - /* The first enumerated device is the default device. */ - if (iCaptureDevice == 0) { - deviceInfo.isDefault = MA_TRUE; - } - - if (ma_context_get_device_info_from_WAVEINCAPS2(pContext, &caps, &deviceInfo) == MA_SUCCESS) { - ma_bool32 cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - if (cbResult == MA_FALSE) { - return MA_SUCCESS; /* Enumeration was stopped. */ - } - } - } - } - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__winmm(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - UINT winMMDeviceID; - - MA_ASSERT(pContext != NULL); - - winMMDeviceID = 0; - if (pDeviceID != NULL) { - winMMDeviceID = (UINT)pDeviceID->winmm; - } - - pDeviceInfo->id.winmm = winMMDeviceID; - - /* The first ID is the default device. */ - if (winMMDeviceID == 0) { - pDeviceInfo->isDefault = MA_TRUE; - } - - if (deviceType == ma_device_type_playback) { - MMRESULT result; - MA_WAVEOUTCAPS2A caps; - - MA_ZERO_OBJECT(&caps); - - result = ((MA_PFN_waveOutGetDevCapsA)pContext->winmm.waveOutGetDevCapsA)(winMMDeviceID, (WAVEOUTCAPSA*)&caps, sizeof(caps)); - if (result == MMSYSERR_NOERROR) { - return ma_context_get_device_info_from_WAVEOUTCAPS2(pContext, &caps, pDeviceInfo); - } - } else { - MMRESULT result; - MA_WAVEINCAPS2A caps; - - MA_ZERO_OBJECT(&caps); - - result = ((MA_PFN_waveInGetDevCapsA)pContext->winmm.waveInGetDevCapsA)(winMMDeviceID, (WAVEINCAPSA*)&caps, sizeof(caps)); - if (result == MMSYSERR_NOERROR) { - return ma_context_get_device_info_from_WAVEINCAPS2(pContext, &caps, pDeviceInfo); - } - } - - return MA_NO_DEVICE; -} - - -static ma_result ma_device_uninit__winmm(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ((MA_PFN_waveInClose)pDevice->pContext->winmm.waveInClose)((HWAVEIN)pDevice->winmm.hDeviceCapture); - CloseHandle((HANDLE)pDevice->winmm.hEventCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ((MA_PFN_waveOutReset)pDevice->pContext->winmm.waveOutReset)((HWAVEOUT)pDevice->winmm.hDevicePlayback); - ((MA_PFN_waveOutClose)pDevice->pContext->winmm.waveOutClose)((HWAVEOUT)pDevice->winmm.hDevicePlayback); - CloseHandle((HANDLE)pDevice->winmm.hEventPlayback); - } - - ma_free(pDevice->winmm._pHeapData, &pDevice->pContext->allocationCallbacks); - - MA_ZERO_OBJECT(&pDevice->winmm); /* Safety. */ - - return MA_SUCCESS; -} - -static ma_uint32 ma_calculate_period_size_in_frames_from_descriptor__winmm(const ma_device_descriptor* pDescriptor, ma_uint32 nativeSampleRate, ma_performance_profile performanceProfile) -{ - /* WinMM has a minimum period size of 40ms. */ - ma_uint32 minPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(40, nativeSampleRate); - ma_uint32 periodSizeInFrames; - - periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, nativeSampleRate, performanceProfile); - if (periodSizeInFrames < minPeriodSizeInFrames) { - periodSizeInFrames = minPeriodSizeInFrames; - } - - return periodSizeInFrames; -} - -static ma_result ma_device_init__winmm(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - const char* errorMsg = ""; - ma_result errorCode = MA_ERROR; - ma_result result = MA_SUCCESS; - ma_uint32 heapSize; - UINT winMMDeviceIDPlayback = 0; - UINT winMMDeviceIDCapture = 0; - - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->winmm); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* No exlusive mode with WinMM. */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->shareMode == ma_share_mode_exclusive)) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - if (pDescriptorPlayback->pDeviceID != NULL) { - winMMDeviceIDPlayback = (UINT)pDescriptorPlayback->pDeviceID->winmm; - } - if (pDescriptorCapture->pDeviceID != NULL) { - winMMDeviceIDCapture = (UINT)pDescriptorCapture->pDeviceID->winmm; - } - - /* The capture device needs to be initialized first. */ - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - WAVEINCAPSA caps; - MA_WAVEFORMATEX wf; - MMRESULT resultMM; - - /* We use an event to know when a new fragment needs to be enqueued. */ - pDevice->winmm.hEventCapture = (ma_handle)CreateEventA(NULL, TRUE, TRUE, NULL); - if (pDevice->winmm.hEventCapture == NULL) { - errorMsg = "[WinMM] Failed to create event for fragment enqueing for the capture device.", errorCode = ma_result_from_GetLastError(GetLastError()); - goto on_error; - } - - /* The format should be based on the device's actual format. */ - if (((MA_PFN_waveInGetDevCapsA)pDevice->pContext->winmm.waveInGetDevCapsA)(winMMDeviceIDCapture, &caps, sizeof(caps)) != MMSYSERR_NOERROR) { - errorMsg = "[WinMM] Failed to retrieve internal device caps.", errorCode = MA_FORMAT_NOT_SUPPORTED; - goto on_error; - } - - result = ma_formats_flags_to_WAVEFORMATEX__winmm(caps.dwFormats, caps.wChannels, &wf); - if (result != MA_SUCCESS) { - errorMsg = "[WinMM] Could not find appropriate format for internal device.", errorCode = result; - goto on_error; - } - - resultMM = ((MA_PFN_waveInOpen)pDevice->pContext->winmm.waveInOpen)((HWAVEIN*)&pDevice->winmm.hDeviceCapture, winMMDeviceIDCapture, &wf, (DWORD_PTR)pDevice->winmm.hEventCapture, (DWORD_PTR)pDevice, CALLBACK_EVENT | WAVE_ALLOWSYNC); - if (resultMM != MMSYSERR_NOERROR) { - errorMsg = "[WinMM] Failed to open capture device.", errorCode = MA_FAILED_TO_OPEN_BACKEND_DEVICE; - goto on_error; - } - - pDescriptorCapture->format = ma_format_from_WAVEFORMATEX(&wf); - pDescriptorCapture->channels = wf.nChannels; - pDescriptorCapture->sampleRate = wf.nSamplesPerSec; - ma_channel_map_init_standard(ma_standard_channel_map_microsoft, pDescriptorCapture->channelMap, ma_countof(pDescriptorCapture->channelMap), pDescriptorCapture->channels); - pDescriptorCapture->periodCount = pDescriptorCapture->periodCount; - pDescriptorCapture->periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__winmm(pDescriptorCapture, pDescriptorCapture->sampleRate, pConfig->performanceProfile); - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - WAVEOUTCAPSA caps; - MA_WAVEFORMATEX wf; - MMRESULT resultMM; - - /* We use an event to know when a new fragment needs to be enqueued. */ - pDevice->winmm.hEventPlayback = (ma_handle)CreateEventA(NULL, TRUE, TRUE, NULL); - if (pDevice->winmm.hEventPlayback == NULL) { - errorMsg = "[WinMM] Failed to create event for fragment enqueing for the playback device.", errorCode = ma_result_from_GetLastError(GetLastError()); - goto on_error; - } - - /* The format should be based on the device's actual format. */ - if (((MA_PFN_waveOutGetDevCapsA)pDevice->pContext->winmm.waveOutGetDevCapsA)(winMMDeviceIDPlayback, &caps, sizeof(caps)) != MMSYSERR_NOERROR) { - errorMsg = "[WinMM] Failed to retrieve internal device caps.", errorCode = MA_FORMAT_NOT_SUPPORTED; - goto on_error; - } - - result = ma_formats_flags_to_WAVEFORMATEX__winmm(caps.dwFormats, caps.wChannels, &wf); - if (result != MA_SUCCESS) { - errorMsg = "[WinMM] Could not find appropriate format for internal device.", errorCode = result; - goto on_error; - } - - resultMM = ((MA_PFN_waveOutOpen)pDevice->pContext->winmm.waveOutOpen)((HWAVEOUT*)&pDevice->winmm.hDevicePlayback, winMMDeviceIDPlayback, &wf, (DWORD_PTR)pDevice->winmm.hEventPlayback, (DWORD_PTR)pDevice, CALLBACK_EVENT | WAVE_ALLOWSYNC); - if (resultMM != MMSYSERR_NOERROR) { - errorMsg = "[WinMM] Failed to open playback device.", errorCode = MA_FAILED_TO_OPEN_BACKEND_DEVICE; - goto on_error; - } - - pDescriptorPlayback->format = ma_format_from_WAVEFORMATEX(&wf); - pDescriptorPlayback->channels = wf.nChannels; - pDescriptorPlayback->sampleRate = wf.nSamplesPerSec; - ma_channel_map_init_standard(ma_standard_channel_map_microsoft, pDescriptorPlayback->channelMap, ma_countof(pDescriptorPlayback->channelMap), pDescriptorPlayback->channels); - pDescriptorPlayback->periodCount = pDescriptorPlayback->periodCount; - pDescriptorPlayback->periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__winmm(pDescriptorPlayback, pDescriptorPlayback->sampleRate, pConfig->performanceProfile); - } - - /* - The heap allocated data is allocated like so: - - [Capture WAVEHDRs][Playback WAVEHDRs][Capture Intermediary Buffer][Playback Intermediary Buffer] - */ - heapSize = 0; - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - heapSize += sizeof(WAVEHDR)*pDescriptorCapture->periodCount + (pDescriptorCapture->periodSizeInFrames * pDescriptorCapture->periodCount * ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels)); - } - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - heapSize += sizeof(WAVEHDR)*pDescriptorPlayback->periodCount + (pDescriptorPlayback->periodSizeInFrames * pDescriptorPlayback->periodCount * ma_get_bytes_per_frame(pDescriptorPlayback->format, pDescriptorPlayback->channels)); - } - - pDevice->winmm._pHeapData = (ma_uint8*)ma_calloc(heapSize, &pDevice->pContext->allocationCallbacks); - if (pDevice->winmm._pHeapData == NULL) { - errorMsg = "[WinMM] Failed to allocate memory for the intermediary buffer.", errorCode = MA_OUT_OF_MEMORY; - goto on_error; - } - - MA_ZERO_MEMORY(pDevice->winmm._pHeapData, heapSize); - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_uint32 iPeriod; - - if (pConfig->deviceType == ma_device_type_capture) { - pDevice->winmm.pWAVEHDRCapture = pDevice->winmm._pHeapData; - pDevice->winmm.pIntermediaryBufferCapture = pDevice->winmm._pHeapData + (sizeof(WAVEHDR)*(pDescriptorCapture->periodCount)); - } else { - pDevice->winmm.pWAVEHDRCapture = pDevice->winmm._pHeapData; - pDevice->winmm.pIntermediaryBufferCapture = pDevice->winmm._pHeapData + (sizeof(WAVEHDR)*(pDescriptorCapture->periodCount + pDescriptorPlayback->periodCount)); - } - - /* Prepare headers. */ - for (iPeriod = 0; iPeriod < pDescriptorCapture->periodCount; ++iPeriod) { - ma_uint32 periodSizeInBytes = ma_get_period_size_in_bytes(pDescriptorCapture->periodSizeInFrames, pDescriptorCapture->format, pDescriptorCapture->channels); - - ((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod].lpData = (char*)(pDevice->winmm.pIntermediaryBufferCapture + (periodSizeInBytes*iPeriod)); - ((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod].dwBufferLength = periodSizeInBytes; - ((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod].dwFlags = 0L; - ((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod].dwLoops = 0L; - ((MA_PFN_waveInPrepareHeader)pDevice->pContext->winmm.waveInPrepareHeader)((HWAVEIN)pDevice->winmm.hDeviceCapture, &((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod], sizeof(WAVEHDR)); - - /* - The user data of the WAVEHDR structure is a single flag the controls whether or not it is ready for writing. Consider it to be named "isLocked". A value of 0 means - it's unlocked and available for writing. A value of 1 means it's locked. - */ - ((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod].dwUser = 0; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_uint32 iPeriod; - - if (pConfig->deviceType == ma_device_type_playback) { - pDevice->winmm.pWAVEHDRPlayback = pDevice->winmm._pHeapData; - pDevice->winmm.pIntermediaryBufferPlayback = pDevice->winmm._pHeapData + (sizeof(WAVEHDR)*pDescriptorPlayback->periodCount); - } else { - pDevice->winmm.pWAVEHDRPlayback = pDevice->winmm._pHeapData + (sizeof(WAVEHDR)*(pDescriptorCapture->periodCount)); - pDevice->winmm.pIntermediaryBufferPlayback = pDevice->winmm._pHeapData + (sizeof(WAVEHDR)*(pDescriptorCapture->periodCount + pDescriptorPlayback->periodCount)) + (pDescriptorCapture->periodSizeInFrames*pDescriptorCapture->periodCount*ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels)); - } - - /* Prepare headers. */ - for (iPeriod = 0; iPeriod < pDescriptorPlayback->periodCount; ++iPeriod) { - ma_uint32 periodSizeInBytes = ma_get_period_size_in_bytes(pDescriptorPlayback->periodSizeInFrames, pDescriptorPlayback->format, pDescriptorPlayback->channels); - - ((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod].lpData = (char*)(pDevice->winmm.pIntermediaryBufferPlayback + (periodSizeInBytes*iPeriod)); - ((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod].dwBufferLength = periodSizeInBytes; - ((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod].dwFlags = 0L; - ((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod].dwLoops = 0L; - ((MA_PFN_waveOutPrepareHeader)pDevice->pContext->winmm.waveOutPrepareHeader)((HWAVEOUT)pDevice->winmm.hDevicePlayback, &((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod], sizeof(WAVEHDR)); - - /* - The user data of the WAVEHDR structure is a single flag the controls whether or not it is ready for writing. Consider it to be named "isLocked". A value of 0 means - it's unlocked and available for writing. A value of 1 means it's locked. - */ - ((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod].dwUser = 0; - } - } - - return MA_SUCCESS; - -on_error: - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - if (pDevice->winmm.pWAVEHDRCapture != NULL) { - ma_uint32 iPeriod; - for (iPeriod = 0; iPeriod < pDescriptorCapture->periodCount; ++iPeriod) { - ((MA_PFN_waveInUnprepareHeader)pDevice->pContext->winmm.waveInUnprepareHeader)((HWAVEIN)pDevice->winmm.hDeviceCapture, &((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod], sizeof(WAVEHDR)); - } - } - - ((MA_PFN_waveInClose)pDevice->pContext->winmm.waveInClose)((HWAVEIN)pDevice->winmm.hDeviceCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - if (pDevice->winmm.pWAVEHDRCapture != NULL) { - ma_uint32 iPeriod; - for (iPeriod = 0; iPeriod < pDescriptorPlayback->periodCount; ++iPeriod) { - ((MA_PFN_waveOutUnprepareHeader)pDevice->pContext->winmm.waveOutUnprepareHeader)((HWAVEOUT)pDevice->winmm.hDevicePlayback, &((WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback)[iPeriod], sizeof(WAVEHDR)); - } - } - - ((MA_PFN_waveOutClose)pDevice->pContext->winmm.waveOutClose)((HWAVEOUT)pDevice->winmm.hDevicePlayback); - } - - ma_free(pDevice->winmm._pHeapData, &pDevice->pContext->allocationCallbacks); - - if (errorMsg != NULL && errorMsg[0] != '\0') { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "%s", errorMsg); - } - - return errorCode; -} - -static ma_result ma_device_start__winmm(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - MMRESULT resultMM; - WAVEHDR* pWAVEHDR; - ma_uint32 iPeriod; - - pWAVEHDR = (WAVEHDR*)pDevice->winmm.pWAVEHDRCapture; - - /* Make sure the event is reset to a non-signaled state to ensure we don't prematurely return from WaitForSingleObject(). */ - ResetEvent((HANDLE)pDevice->winmm.hEventCapture); - - /* To start the device we attach all of the buffers and then start it. As the buffers are filled with data we will get notifications. */ - for (iPeriod = 0; iPeriod < pDevice->capture.internalPeriods; ++iPeriod) { - resultMM = ((MA_PFN_waveInAddBuffer)pDevice->pContext->winmm.waveInAddBuffer)((HWAVEIN)pDevice->winmm.hDeviceCapture, &((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[iPeriod], sizeof(WAVEHDR)); - if (resultMM != MMSYSERR_NOERROR) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WinMM] Failed to attach input buffers to capture device in preparation for capture."); - return ma_result_from_MMRESULT(resultMM); - } - - /* Make sure all of the buffers start out locked. We don't want to access them until the backend tells us we can. */ - pWAVEHDR[iPeriod].dwUser = 1; /* 1 = locked. */ - } - - /* Capture devices need to be explicitly started, unlike playback devices. */ - resultMM = ((MA_PFN_waveInStart)pDevice->pContext->winmm.waveInStart)((HWAVEIN)pDevice->winmm.hDeviceCapture); - if (resultMM != MMSYSERR_NOERROR) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WinMM] Failed to start backend device."); - return ma_result_from_MMRESULT(resultMM); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - /* Don't need to do anything for playback. It'll be started automatically in ma_device_start__winmm(). */ - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__winmm(ma_device* pDevice) -{ - MMRESULT resultMM; - - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - if (pDevice->winmm.hDeviceCapture == NULL) { - return MA_INVALID_ARGS; - } - - resultMM = ((MA_PFN_waveInReset)pDevice->pContext->winmm.waveInReset)((HWAVEIN)pDevice->winmm.hDeviceCapture); - if (resultMM != MMSYSERR_NOERROR) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[WinMM] WARNING: Failed to reset capture device."); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_uint32 iPeriod; - WAVEHDR* pWAVEHDR; - - if (pDevice->winmm.hDevicePlayback == NULL) { - return MA_INVALID_ARGS; - } - - /* We need to drain the device. To do this we just loop over each header and if it's locked just wait for the event. */ - pWAVEHDR = (WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback; - for (iPeriod = 0; iPeriod < pDevice->playback.internalPeriods; iPeriod += 1) { - if (pWAVEHDR[iPeriod].dwUser == 1) { /* 1 = locked. */ - if (WaitForSingleObject((HANDLE)pDevice->winmm.hEventPlayback, INFINITE) != WAIT_OBJECT_0) { - break; /* An error occurred so just abandon ship and stop the device without draining. */ - } - - pWAVEHDR[iPeriod].dwUser = 0; - } - } - - resultMM = ((MA_PFN_waveOutReset)pDevice->pContext->winmm.waveOutReset)((HWAVEOUT)pDevice->winmm.hDevicePlayback); - if (resultMM != MMSYSERR_NOERROR) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_WARNING, "[WinMM] WARNING: Failed to reset playback device."); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_write__winmm(ma_device* pDevice, const void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - ma_result result = MA_SUCCESS; - MMRESULT resultMM; - ma_uint32 totalFramesWritten; - WAVEHDR* pWAVEHDR; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pPCMFrames != NULL); - - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - pWAVEHDR = (WAVEHDR*)pDevice->winmm.pWAVEHDRPlayback; - - /* Keep processing as much data as possible. */ - totalFramesWritten = 0; - while (totalFramesWritten < frameCount) { - /* If the current header has some space available we need to write part of it. */ - if (pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwUser == 0) { /* 0 = unlocked. */ - /* - This header has room in it. We copy as much of it as we can. If we end up fully consuming the buffer we need to - write it out and move on to the next iteration. - */ - ma_uint32 bpf = ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - ma_uint32 framesRemainingInHeader = (pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwBufferLength/bpf) - pDevice->winmm.headerFramesConsumedPlayback; - - ma_uint32 framesToCopy = ma_min(framesRemainingInHeader, (frameCount - totalFramesWritten)); - const void* pSrc = ma_offset_ptr(pPCMFrames, totalFramesWritten*bpf); - void* pDst = ma_offset_ptr(pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].lpData, pDevice->winmm.headerFramesConsumedPlayback*bpf); - MA_COPY_MEMORY(pDst, pSrc, framesToCopy*bpf); - - pDevice->winmm.headerFramesConsumedPlayback += framesToCopy; - totalFramesWritten += framesToCopy; - - /* If we've consumed the buffer entirely we need to write it out to the device. */ - if (pDevice->winmm.headerFramesConsumedPlayback == (pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwBufferLength/bpf)) { - pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwUser = 1; /* 1 = locked. */ - pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwFlags &= ~WHDR_DONE; /* <-- Need to make sure the WHDR_DONE flag is unset. */ - - /* Make sure the event is reset to a non-signaled state to ensure we don't prematurely return from WaitForSingleObject(). */ - ResetEvent((HANDLE)pDevice->winmm.hEventPlayback); - - /* The device will be started here. */ - resultMM = ((MA_PFN_waveOutWrite)pDevice->pContext->winmm.waveOutWrite)((HWAVEOUT)pDevice->winmm.hDevicePlayback, &pWAVEHDR[pDevice->winmm.iNextHeaderPlayback], sizeof(WAVEHDR)); - if (resultMM != MMSYSERR_NOERROR) { - result = ma_result_from_MMRESULT(resultMM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WinMM] waveOutWrite() failed."); - break; - } - - /* Make sure we move to the next header. */ - pDevice->winmm.iNextHeaderPlayback = (pDevice->winmm.iNextHeaderPlayback + 1) % pDevice->playback.internalPeriods; - pDevice->winmm.headerFramesConsumedPlayback = 0; - } - - /* If at this point we have consumed the entire input buffer we can return. */ - MA_ASSERT(totalFramesWritten <= frameCount); - if (totalFramesWritten == frameCount) { - break; - } - - /* Getting here means there's more to process. */ - continue; - } - - /* Getting here means there isn't enough room in the buffer and we need to wait for one to become available. */ - if (WaitForSingleObject((HANDLE)pDevice->winmm.hEventPlayback, INFINITE) != WAIT_OBJECT_0) { - result = MA_ERROR; - break; - } - - /* Something happened. If the next buffer has been marked as done we need to reset a bit of state. */ - if ((pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwFlags & WHDR_DONE) != 0) { - pWAVEHDR[pDevice->winmm.iNextHeaderPlayback].dwUser = 0; /* 0 = unlocked (make it available for writing). */ - pDevice->winmm.headerFramesConsumedPlayback = 0; - } - - /* If the device has been stopped we need to break. */ - if (ma_device_get_state(pDevice) != ma_device_state_started) { - break; - } - } - - if (pFramesWritten != NULL) { - *pFramesWritten = totalFramesWritten; - } - - return result; -} - -static ma_result ma_device_read__winmm(ma_device* pDevice, void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - ma_result result = MA_SUCCESS; - MMRESULT resultMM; - ma_uint32 totalFramesRead; - WAVEHDR* pWAVEHDR; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pPCMFrames != NULL); - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - pWAVEHDR = (WAVEHDR*)pDevice->winmm.pWAVEHDRCapture; - - /* Keep processing as much data as possible. */ - totalFramesRead = 0; - while (totalFramesRead < frameCount) { - /* If the current header has some space available we need to write part of it. */ - if (pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwUser == 0) { /* 0 = unlocked. */ - /* The buffer is available for reading. If we fully consume it we need to add it back to the buffer. */ - ma_uint32 bpf = ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - ma_uint32 framesRemainingInHeader = (pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwBufferLength/bpf) - pDevice->winmm.headerFramesConsumedCapture; - - ma_uint32 framesToCopy = ma_min(framesRemainingInHeader, (frameCount - totalFramesRead)); - const void* pSrc = ma_offset_ptr(pWAVEHDR[pDevice->winmm.iNextHeaderCapture].lpData, pDevice->winmm.headerFramesConsumedCapture*bpf); - void* pDst = ma_offset_ptr(pPCMFrames, totalFramesRead*bpf); - MA_COPY_MEMORY(pDst, pSrc, framesToCopy*bpf); - - pDevice->winmm.headerFramesConsumedCapture += framesToCopy; - totalFramesRead += framesToCopy; - - /* If we've consumed the buffer entirely we need to add it back to the device. */ - if (pDevice->winmm.headerFramesConsumedCapture == (pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwBufferLength/bpf)) { - pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwUser = 1; /* 1 = locked. */ - pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwFlags &= ~WHDR_DONE; /* <-- Need to make sure the WHDR_DONE flag is unset. */ - - /* Make sure the event is reset to a non-signaled state to ensure we don't prematurely return from WaitForSingleObject(). */ - ResetEvent((HANDLE)pDevice->winmm.hEventCapture); - - /* The device will be started here. */ - resultMM = ((MA_PFN_waveInAddBuffer)pDevice->pContext->winmm.waveInAddBuffer)((HWAVEIN)pDevice->winmm.hDeviceCapture, &((WAVEHDR*)pDevice->winmm.pWAVEHDRCapture)[pDevice->winmm.iNextHeaderCapture], sizeof(WAVEHDR)); - if (resultMM != MMSYSERR_NOERROR) { - result = ma_result_from_MMRESULT(resultMM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[WinMM] waveInAddBuffer() failed."); - break; - } - - /* Make sure we move to the next header. */ - pDevice->winmm.iNextHeaderCapture = (pDevice->winmm.iNextHeaderCapture + 1) % pDevice->capture.internalPeriods; - pDevice->winmm.headerFramesConsumedCapture = 0; - } - - /* If at this point we have filled the entire input buffer we can return. */ - MA_ASSERT(totalFramesRead <= frameCount); - if (totalFramesRead == frameCount) { - break; - } - - /* Getting here means there's more to process. */ - continue; - } - - /* Getting here means there isn't enough any data left to send to the client which means we need to wait for more. */ - if (WaitForSingleObject((HANDLE)pDevice->winmm.hEventCapture, INFINITE) != WAIT_OBJECT_0) { - result = MA_ERROR; - break; - } - - /* Something happened. If the next buffer has been marked as done we need to reset a bit of state. */ - if ((pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwFlags & WHDR_DONE) != 0) { - pWAVEHDR[pDevice->winmm.iNextHeaderCapture].dwUser = 0; /* 0 = unlocked (make it available for reading). */ - pDevice->winmm.headerFramesConsumedCapture = 0; - } - - /* If the device has been stopped we need to break. */ - if (ma_device_get_state(pDevice) != ma_device_state_started) { - break; - } - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - return result; -} - -static ma_result ma_context_uninit__winmm(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_winmm); - - ma_dlclose(pContext, pContext->winmm.hWinMM); - return MA_SUCCESS; -} - -static ma_result ma_context_init__winmm(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - MA_ASSERT(pContext != NULL); - - (void)pConfig; - - pContext->winmm.hWinMM = ma_dlopen(pContext, "winmm.dll"); - if (pContext->winmm.hWinMM == NULL) { - return MA_NO_BACKEND; - } - - pContext->winmm.waveOutGetNumDevs = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutGetNumDevs"); - pContext->winmm.waveOutGetDevCapsA = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutGetDevCapsA"); - pContext->winmm.waveOutOpen = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutOpen"); - pContext->winmm.waveOutClose = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutClose"); - pContext->winmm.waveOutPrepareHeader = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutPrepareHeader"); - pContext->winmm.waveOutUnprepareHeader = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutUnprepareHeader"); - pContext->winmm.waveOutWrite = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutWrite"); - pContext->winmm.waveOutReset = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveOutReset"); - pContext->winmm.waveInGetNumDevs = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInGetNumDevs"); - pContext->winmm.waveInGetDevCapsA = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInGetDevCapsA"); - pContext->winmm.waveInOpen = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInOpen"); - pContext->winmm.waveInClose = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInClose"); - pContext->winmm.waveInPrepareHeader = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInPrepareHeader"); - pContext->winmm.waveInUnprepareHeader = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInUnprepareHeader"); - pContext->winmm.waveInAddBuffer = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInAddBuffer"); - pContext->winmm.waveInStart = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInStart"); - pContext->winmm.waveInReset = ma_dlsym(pContext, pContext->winmm.hWinMM, "waveInReset"); - - pCallbacks->onContextInit = ma_context_init__winmm; - pCallbacks->onContextUninit = ma_context_uninit__winmm; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__winmm; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__winmm; - pCallbacks->onDeviceInit = ma_device_init__winmm; - pCallbacks->onDeviceUninit = ma_device_uninit__winmm; - pCallbacks->onDeviceStart = ma_device_start__winmm; - pCallbacks->onDeviceStop = ma_device_stop__winmm; - pCallbacks->onDeviceRead = ma_device_read__winmm; - pCallbacks->onDeviceWrite = ma_device_write__winmm; - pCallbacks->onDeviceDataLoop = NULL; /* This is a blocking read-write API, so this can be NULL since miniaudio will manage the audio thread for us. */ - - return MA_SUCCESS; -} -#endif - - - - -/****************************************************************************** - -ALSA Backend - -******************************************************************************/ -#ifdef MA_HAS_ALSA - -#include /* poll(), struct pollfd */ -#include /* eventfd() */ - -#ifdef MA_NO_RUNTIME_LINKING - -/* asoundlib.h marks some functions with "inline" which isn't always supported. Need to emulate it. */ -#if !defined(__cplusplus) - #if defined(__STRICT_ANSI__) - #if !defined(inline) - #define inline __inline__ __attribute__((always_inline)) - #define MA_INLINE_DEFINED - #endif - #endif -#endif -#include -#if defined(MA_INLINE_DEFINED) - #undef inline - #undef MA_INLINE_DEFINED -#endif - -typedef snd_pcm_uframes_t ma_snd_pcm_uframes_t; -typedef snd_pcm_sframes_t ma_snd_pcm_sframes_t; -typedef snd_pcm_stream_t ma_snd_pcm_stream_t; -typedef snd_pcm_format_t ma_snd_pcm_format_t; -typedef snd_pcm_access_t ma_snd_pcm_access_t; -typedef snd_pcm_t ma_snd_pcm_t; -typedef snd_pcm_hw_params_t ma_snd_pcm_hw_params_t; -typedef snd_pcm_sw_params_t ma_snd_pcm_sw_params_t; -typedef snd_pcm_format_mask_t ma_snd_pcm_format_mask_t; -typedef snd_pcm_info_t ma_snd_pcm_info_t; -typedef snd_pcm_channel_area_t ma_snd_pcm_channel_area_t; -typedef snd_pcm_chmap_t ma_snd_pcm_chmap_t; -typedef snd_pcm_state_t ma_snd_pcm_state_t; - -/* snd_pcm_stream_t */ -#define MA_SND_PCM_STREAM_PLAYBACK SND_PCM_STREAM_PLAYBACK -#define MA_SND_PCM_STREAM_CAPTURE SND_PCM_STREAM_CAPTURE - -/* snd_pcm_format_t */ -#define MA_SND_PCM_FORMAT_UNKNOWN SND_PCM_FORMAT_UNKNOWN -#define MA_SND_PCM_FORMAT_U8 SND_PCM_FORMAT_U8 -#define MA_SND_PCM_FORMAT_S16_LE SND_PCM_FORMAT_S16_LE -#define MA_SND_PCM_FORMAT_S16_BE SND_PCM_FORMAT_S16_BE -#define MA_SND_PCM_FORMAT_S24_LE SND_PCM_FORMAT_S24_LE -#define MA_SND_PCM_FORMAT_S24_BE SND_PCM_FORMAT_S24_BE -#define MA_SND_PCM_FORMAT_S32_LE SND_PCM_FORMAT_S32_LE -#define MA_SND_PCM_FORMAT_S32_BE SND_PCM_FORMAT_S32_BE -#define MA_SND_PCM_FORMAT_FLOAT_LE SND_PCM_FORMAT_FLOAT_LE -#define MA_SND_PCM_FORMAT_FLOAT_BE SND_PCM_FORMAT_FLOAT_BE -#define MA_SND_PCM_FORMAT_FLOAT64_LE SND_PCM_FORMAT_FLOAT64_LE -#define MA_SND_PCM_FORMAT_FLOAT64_BE SND_PCM_FORMAT_FLOAT64_BE -#define MA_SND_PCM_FORMAT_MU_LAW SND_PCM_FORMAT_MU_LAW -#define MA_SND_PCM_FORMAT_A_LAW SND_PCM_FORMAT_A_LAW -#define MA_SND_PCM_FORMAT_S24_3LE SND_PCM_FORMAT_S24_3LE -#define MA_SND_PCM_FORMAT_S24_3BE SND_PCM_FORMAT_S24_3BE - -/* ma_snd_pcm_access_t */ -#define MA_SND_PCM_ACCESS_MMAP_INTERLEAVED SND_PCM_ACCESS_MMAP_INTERLEAVED -#define MA_SND_PCM_ACCESS_MMAP_NONINTERLEAVED SND_PCM_ACCESS_MMAP_NONINTERLEAVED -#define MA_SND_PCM_ACCESS_MMAP_COMPLEX SND_PCM_ACCESS_MMAP_COMPLEX -#define MA_SND_PCM_ACCESS_RW_INTERLEAVED SND_PCM_ACCESS_RW_INTERLEAVED -#define MA_SND_PCM_ACCESS_RW_NONINTERLEAVED SND_PCM_ACCESS_RW_NONINTERLEAVED - -/* Channel positions. */ -#define MA_SND_CHMAP_UNKNOWN SND_CHMAP_UNKNOWN -#define MA_SND_CHMAP_NA SND_CHMAP_NA -#define MA_SND_CHMAP_MONO SND_CHMAP_MONO -#define MA_SND_CHMAP_FL SND_CHMAP_FL -#define MA_SND_CHMAP_FR SND_CHMAP_FR -#define MA_SND_CHMAP_RL SND_CHMAP_RL -#define MA_SND_CHMAP_RR SND_CHMAP_RR -#define MA_SND_CHMAP_FC SND_CHMAP_FC -#define MA_SND_CHMAP_LFE SND_CHMAP_LFE -#define MA_SND_CHMAP_SL SND_CHMAP_SL -#define MA_SND_CHMAP_SR SND_CHMAP_SR -#define MA_SND_CHMAP_RC SND_CHMAP_RC -#define MA_SND_CHMAP_FLC SND_CHMAP_FLC -#define MA_SND_CHMAP_FRC SND_CHMAP_FRC -#define MA_SND_CHMAP_RLC SND_CHMAP_RLC -#define MA_SND_CHMAP_RRC SND_CHMAP_RRC -#define MA_SND_CHMAP_FLW SND_CHMAP_FLW -#define MA_SND_CHMAP_FRW SND_CHMAP_FRW -#define MA_SND_CHMAP_FLH SND_CHMAP_FLH -#define MA_SND_CHMAP_FCH SND_CHMAP_FCH -#define MA_SND_CHMAP_FRH SND_CHMAP_FRH -#define MA_SND_CHMAP_TC SND_CHMAP_TC -#define MA_SND_CHMAP_TFL SND_CHMAP_TFL -#define MA_SND_CHMAP_TFR SND_CHMAP_TFR -#define MA_SND_CHMAP_TFC SND_CHMAP_TFC -#define MA_SND_CHMAP_TRL SND_CHMAP_TRL -#define MA_SND_CHMAP_TRR SND_CHMAP_TRR -#define MA_SND_CHMAP_TRC SND_CHMAP_TRC -#define MA_SND_CHMAP_TFLC SND_CHMAP_TFLC -#define MA_SND_CHMAP_TFRC SND_CHMAP_TFRC -#define MA_SND_CHMAP_TSL SND_CHMAP_TSL -#define MA_SND_CHMAP_TSR SND_CHMAP_TSR -#define MA_SND_CHMAP_LLFE SND_CHMAP_LLFE -#define MA_SND_CHMAP_RLFE SND_CHMAP_RLFE -#define MA_SND_CHMAP_BC SND_CHMAP_BC -#define MA_SND_CHMAP_BLC SND_CHMAP_BLC -#define MA_SND_CHMAP_BRC SND_CHMAP_BRC - -/* Open mode flags. */ -#define MA_SND_PCM_NO_AUTO_RESAMPLE SND_PCM_NO_AUTO_RESAMPLE -#define MA_SND_PCM_NO_AUTO_CHANNELS SND_PCM_NO_AUTO_CHANNELS -#define MA_SND_PCM_NO_AUTO_FORMAT SND_PCM_NO_AUTO_FORMAT -#else -#include /* For EPIPE, etc. */ -typedef unsigned long ma_snd_pcm_uframes_t; -typedef long ma_snd_pcm_sframes_t; -typedef int ma_snd_pcm_stream_t; -typedef int ma_snd_pcm_format_t; -typedef int ma_snd_pcm_access_t; -typedef int ma_snd_pcm_state_t; -typedef struct ma_snd_pcm_t ma_snd_pcm_t; -typedef struct ma_snd_pcm_hw_params_t ma_snd_pcm_hw_params_t; -typedef struct ma_snd_pcm_sw_params_t ma_snd_pcm_sw_params_t; -typedef struct ma_snd_pcm_format_mask_t ma_snd_pcm_format_mask_t; -typedef struct ma_snd_pcm_info_t ma_snd_pcm_info_t; -typedef struct -{ - void* addr; - unsigned int first; - unsigned int step; -} ma_snd_pcm_channel_area_t; -typedef struct -{ - unsigned int channels; - unsigned int pos[1]; -} ma_snd_pcm_chmap_t; - -/* snd_pcm_state_t */ -#define MA_SND_PCM_STATE_OPEN 0 -#define MA_SND_PCM_STATE_SETUP 1 -#define MA_SND_PCM_STATE_PREPARED 2 -#define MA_SND_PCM_STATE_RUNNING 3 -#define MA_SND_PCM_STATE_XRUN 4 -#define MA_SND_PCM_STATE_DRAINING 5 -#define MA_SND_PCM_STATE_PAUSED 6 -#define MA_SND_PCM_STATE_SUSPENDED 7 -#define MA_SND_PCM_STATE_DISCONNECTED 8 - -/* snd_pcm_stream_t */ -#define MA_SND_PCM_STREAM_PLAYBACK 0 -#define MA_SND_PCM_STREAM_CAPTURE 1 - -/* snd_pcm_format_t */ -#define MA_SND_PCM_FORMAT_UNKNOWN -1 -#define MA_SND_PCM_FORMAT_U8 1 -#define MA_SND_PCM_FORMAT_S16_LE 2 -#define MA_SND_PCM_FORMAT_S16_BE 3 -#define MA_SND_PCM_FORMAT_S24_LE 6 -#define MA_SND_PCM_FORMAT_S24_BE 7 -#define MA_SND_PCM_FORMAT_S32_LE 10 -#define MA_SND_PCM_FORMAT_S32_BE 11 -#define MA_SND_PCM_FORMAT_FLOAT_LE 14 -#define MA_SND_PCM_FORMAT_FLOAT_BE 15 -#define MA_SND_PCM_FORMAT_FLOAT64_LE 16 -#define MA_SND_PCM_FORMAT_FLOAT64_BE 17 -#define MA_SND_PCM_FORMAT_MU_LAW 20 -#define MA_SND_PCM_FORMAT_A_LAW 21 -#define MA_SND_PCM_FORMAT_S24_3LE 32 -#define MA_SND_PCM_FORMAT_S24_3BE 33 - -/* snd_pcm_access_t */ -#define MA_SND_PCM_ACCESS_MMAP_INTERLEAVED 0 -#define MA_SND_PCM_ACCESS_MMAP_NONINTERLEAVED 1 -#define MA_SND_PCM_ACCESS_MMAP_COMPLEX 2 -#define MA_SND_PCM_ACCESS_RW_INTERLEAVED 3 -#define MA_SND_PCM_ACCESS_RW_NONINTERLEAVED 4 - -/* Channel positions. */ -#define MA_SND_CHMAP_UNKNOWN 0 -#define MA_SND_CHMAP_NA 1 -#define MA_SND_CHMAP_MONO 2 -#define MA_SND_CHMAP_FL 3 -#define MA_SND_CHMAP_FR 4 -#define MA_SND_CHMAP_RL 5 -#define MA_SND_CHMAP_RR 6 -#define MA_SND_CHMAP_FC 7 -#define MA_SND_CHMAP_LFE 8 -#define MA_SND_CHMAP_SL 9 -#define MA_SND_CHMAP_SR 10 -#define MA_SND_CHMAP_RC 11 -#define MA_SND_CHMAP_FLC 12 -#define MA_SND_CHMAP_FRC 13 -#define MA_SND_CHMAP_RLC 14 -#define MA_SND_CHMAP_RRC 15 -#define MA_SND_CHMAP_FLW 16 -#define MA_SND_CHMAP_FRW 17 -#define MA_SND_CHMAP_FLH 18 -#define MA_SND_CHMAP_FCH 19 -#define MA_SND_CHMAP_FRH 20 -#define MA_SND_CHMAP_TC 21 -#define MA_SND_CHMAP_TFL 22 -#define MA_SND_CHMAP_TFR 23 -#define MA_SND_CHMAP_TFC 24 -#define MA_SND_CHMAP_TRL 25 -#define MA_SND_CHMAP_TRR 26 -#define MA_SND_CHMAP_TRC 27 -#define MA_SND_CHMAP_TFLC 28 -#define MA_SND_CHMAP_TFRC 29 -#define MA_SND_CHMAP_TSL 30 -#define MA_SND_CHMAP_TSR 31 -#define MA_SND_CHMAP_LLFE 32 -#define MA_SND_CHMAP_RLFE 33 -#define MA_SND_CHMAP_BC 34 -#define MA_SND_CHMAP_BLC 35 -#define MA_SND_CHMAP_BRC 36 - -/* Open mode flags. */ -#define MA_SND_PCM_NO_AUTO_RESAMPLE 0x00010000 -#define MA_SND_PCM_NO_AUTO_CHANNELS 0x00020000 -#define MA_SND_PCM_NO_AUTO_FORMAT 0x00040000 -#endif - -typedef int (* ma_snd_pcm_open_proc) (ma_snd_pcm_t **pcm, const char *name, ma_snd_pcm_stream_t stream, int mode); -typedef int (* ma_snd_pcm_close_proc) (ma_snd_pcm_t *pcm); -typedef size_t (* ma_snd_pcm_hw_params_sizeof_proc) (void); -typedef int (* ma_snd_pcm_hw_params_any_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params); -typedef int (* ma_snd_pcm_hw_params_set_format_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, ma_snd_pcm_format_t val); -typedef int (* ma_snd_pcm_hw_params_set_format_first_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, ma_snd_pcm_format_t *format); -typedef void (* ma_snd_pcm_hw_params_get_format_mask_proc) (ma_snd_pcm_hw_params_t *params, ma_snd_pcm_format_mask_t *mask); -typedef int (* ma_snd_pcm_hw_params_set_channels_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int val); -typedef int (* ma_snd_pcm_hw_params_set_channels_near_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int *val); -typedef int (* ma_snd_pcm_hw_params_set_channels_minmax_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int *minimum, unsigned int *maximum); -typedef int (* ma_snd_pcm_hw_params_set_rate_resample_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int val); -typedef int (* ma_snd_pcm_hw_params_set_rate_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int val, int dir); -typedef int (* ma_snd_pcm_hw_params_set_rate_near_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int *val, int *dir); -typedef int (* ma_snd_pcm_hw_params_set_buffer_size_near_proc)(ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, ma_snd_pcm_uframes_t *val); -typedef int (* ma_snd_pcm_hw_params_set_periods_near_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int *val, int *dir); -typedef int (* ma_snd_pcm_hw_params_set_access_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, ma_snd_pcm_access_t _access); -typedef int (* ma_snd_pcm_hw_params_get_format_proc) (const ma_snd_pcm_hw_params_t *params, ma_snd_pcm_format_t *format); -typedef int (* ma_snd_pcm_hw_params_get_channels_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *val); -typedef int (* ma_snd_pcm_hw_params_get_channels_min_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *val); -typedef int (* ma_snd_pcm_hw_params_get_channels_max_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *val); -typedef int (* ma_snd_pcm_hw_params_get_rate_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *rate, int *dir); -typedef int (* ma_snd_pcm_hw_params_get_rate_min_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *rate, int *dir); -typedef int (* ma_snd_pcm_hw_params_get_rate_max_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *rate, int *dir); -typedef int (* ma_snd_pcm_hw_params_get_buffer_size_proc) (const ma_snd_pcm_hw_params_t *params, ma_snd_pcm_uframes_t *val); -typedef int (* ma_snd_pcm_hw_params_get_periods_proc) (const ma_snd_pcm_hw_params_t *params, unsigned int *val, int *dir); -typedef int (* ma_snd_pcm_hw_params_get_access_proc) (const ma_snd_pcm_hw_params_t *params, ma_snd_pcm_access_t *_access); -typedef int (* ma_snd_pcm_hw_params_test_format_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, ma_snd_pcm_format_t val); -typedef int (* ma_snd_pcm_hw_params_test_channels_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int val); -typedef int (* ma_snd_pcm_hw_params_test_rate_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params, unsigned int val, int dir); -typedef int (* ma_snd_pcm_hw_params_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_hw_params_t *params); -typedef size_t (* ma_snd_pcm_sw_params_sizeof_proc) (void); -typedef int (* ma_snd_pcm_sw_params_current_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_sw_params_t *params); -typedef int (* ma_snd_pcm_sw_params_get_boundary_proc) (const ma_snd_pcm_sw_params_t *params, ma_snd_pcm_uframes_t* val); -typedef int (* ma_snd_pcm_sw_params_set_avail_min_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_sw_params_t *params, ma_snd_pcm_uframes_t val); -typedef int (* ma_snd_pcm_sw_params_set_start_threshold_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_sw_params_t *params, ma_snd_pcm_uframes_t val); -typedef int (* ma_snd_pcm_sw_params_set_stop_threshold_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_sw_params_t *params, ma_snd_pcm_uframes_t val); -typedef int (* ma_snd_pcm_sw_params_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_sw_params_t *params); -typedef size_t (* ma_snd_pcm_format_mask_sizeof_proc) (void); -typedef int (* ma_snd_pcm_format_mask_test_proc) (const ma_snd_pcm_format_mask_t *mask, ma_snd_pcm_format_t val); -typedef ma_snd_pcm_chmap_t * (* ma_snd_pcm_get_chmap_proc) (ma_snd_pcm_t *pcm); -typedef ma_snd_pcm_state_t (* ma_snd_pcm_state_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_prepare_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_start_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_drop_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_drain_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_reset_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_device_name_hint_proc) (int card, const char *iface, void ***hints); -typedef char * (* ma_snd_device_name_get_hint_proc) (const void *hint, const char *id); -typedef int (* ma_snd_card_get_index_proc) (const char *name); -typedef int (* ma_snd_device_name_free_hint_proc) (void **hints); -typedef int (* ma_snd_pcm_mmap_begin_proc) (ma_snd_pcm_t *pcm, const ma_snd_pcm_channel_area_t **areas, ma_snd_pcm_uframes_t *offset, ma_snd_pcm_uframes_t *frames); -typedef ma_snd_pcm_sframes_t (* ma_snd_pcm_mmap_commit_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_uframes_t offset, ma_snd_pcm_uframes_t frames); -typedef int (* ma_snd_pcm_recover_proc) (ma_snd_pcm_t *pcm, int err, int silent); -typedef ma_snd_pcm_sframes_t (* ma_snd_pcm_readi_proc) (ma_snd_pcm_t *pcm, void *buffer, ma_snd_pcm_uframes_t size); -typedef ma_snd_pcm_sframes_t (* ma_snd_pcm_writei_proc) (ma_snd_pcm_t *pcm, const void *buffer, ma_snd_pcm_uframes_t size); -typedef ma_snd_pcm_sframes_t (* ma_snd_pcm_avail_proc) (ma_snd_pcm_t *pcm); -typedef ma_snd_pcm_sframes_t (* ma_snd_pcm_avail_update_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_wait_proc) (ma_snd_pcm_t *pcm, int timeout); -typedef int (* ma_snd_pcm_nonblock_proc) (ma_snd_pcm_t *pcm, int nonblock); -typedef int (* ma_snd_pcm_info_proc) (ma_snd_pcm_t *pcm, ma_snd_pcm_info_t* info); -typedef size_t (* ma_snd_pcm_info_sizeof_proc) (void); -typedef const char* (* ma_snd_pcm_info_get_name_proc) (const ma_snd_pcm_info_t* info); -typedef int (* ma_snd_pcm_poll_descriptors_proc) (ma_snd_pcm_t *pcm, struct pollfd *pfds, unsigned int space); -typedef int (* ma_snd_pcm_poll_descriptors_count_proc) (ma_snd_pcm_t *pcm); -typedef int (* ma_snd_pcm_poll_descriptors_revents_proc) (ma_snd_pcm_t *pcm, struct pollfd *pfds, unsigned int nfds, unsigned short *revents); -typedef int (* ma_snd_config_update_free_global_proc) (void); - -/* This array specifies each of the common devices that can be used for both playback and capture. */ -static const char* g_maCommonDeviceNamesALSA[] = { - "default", - "null", - "pulse", - "jack" -}; - -/* This array allows us to blacklist specific playback devices. */ -static const char* g_maBlacklistedPlaybackDeviceNamesALSA[] = { - "" -}; - -/* This array allows us to blacklist specific capture devices. */ -static const char* g_maBlacklistedCaptureDeviceNamesALSA[] = { - "" -}; - - -static ma_snd_pcm_format_t ma_convert_ma_format_to_alsa_format(ma_format format) -{ - ma_snd_pcm_format_t ALSAFormats[] = { - MA_SND_PCM_FORMAT_UNKNOWN, /* ma_format_unknown */ - MA_SND_PCM_FORMAT_U8, /* ma_format_u8 */ - MA_SND_PCM_FORMAT_S16_LE, /* ma_format_s16 */ - MA_SND_PCM_FORMAT_S24_3LE, /* ma_format_s24 */ - MA_SND_PCM_FORMAT_S32_LE, /* ma_format_s32 */ - MA_SND_PCM_FORMAT_FLOAT_LE /* ma_format_f32 */ - }; - - if (ma_is_big_endian()) { - ALSAFormats[0] = MA_SND_PCM_FORMAT_UNKNOWN; - ALSAFormats[1] = MA_SND_PCM_FORMAT_U8; - ALSAFormats[2] = MA_SND_PCM_FORMAT_S16_BE; - ALSAFormats[3] = MA_SND_PCM_FORMAT_S24_3BE; - ALSAFormats[4] = MA_SND_PCM_FORMAT_S32_BE; - ALSAFormats[5] = MA_SND_PCM_FORMAT_FLOAT_BE; - } - - return ALSAFormats[format]; -} - -static ma_format ma_format_from_alsa(ma_snd_pcm_format_t formatALSA) -{ - if (ma_is_little_endian()) { - switch (formatALSA) { - case MA_SND_PCM_FORMAT_S16_LE: return ma_format_s16; - case MA_SND_PCM_FORMAT_S24_3LE: return ma_format_s24; - case MA_SND_PCM_FORMAT_S32_LE: return ma_format_s32; - case MA_SND_PCM_FORMAT_FLOAT_LE: return ma_format_f32; - default: break; - } - } else { - switch (formatALSA) { - case MA_SND_PCM_FORMAT_S16_BE: return ma_format_s16; - case MA_SND_PCM_FORMAT_S24_3BE: return ma_format_s24; - case MA_SND_PCM_FORMAT_S32_BE: return ma_format_s32; - case MA_SND_PCM_FORMAT_FLOAT_BE: return ma_format_f32; - default: break; - } - } - - /* Endian agnostic. */ - switch (formatALSA) { - case MA_SND_PCM_FORMAT_U8: return ma_format_u8; - default: return ma_format_unknown; - } -} - -static ma_channel ma_convert_alsa_channel_position_to_ma_channel(unsigned int alsaChannelPos) -{ - switch (alsaChannelPos) - { - case MA_SND_CHMAP_MONO: return MA_CHANNEL_MONO; - case MA_SND_CHMAP_FL: return MA_CHANNEL_FRONT_LEFT; - case MA_SND_CHMAP_FR: return MA_CHANNEL_FRONT_RIGHT; - case MA_SND_CHMAP_RL: return MA_CHANNEL_BACK_LEFT; - case MA_SND_CHMAP_RR: return MA_CHANNEL_BACK_RIGHT; - case MA_SND_CHMAP_FC: return MA_CHANNEL_FRONT_CENTER; - case MA_SND_CHMAP_LFE: return MA_CHANNEL_LFE; - case MA_SND_CHMAP_SL: return MA_CHANNEL_SIDE_LEFT; - case MA_SND_CHMAP_SR: return MA_CHANNEL_SIDE_RIGHT; - case MA_SND_CHMAP_RC: return MA_CHANNEL_BACK_CENTER; - case MA_SND_CHMAP_FLC: return MA_CHANNEL_FRONT_LEFT_CENTER; - case MA_SND_CHMAP_FRC: return MA_CHANNEL_FRONT_RIGHT_CENTER; - case MA_SND_CHMAP_RLC: return 0; - case MA_SND_CHMAP_RRC: return 0; - case MA_SND_CHMAP_FLW: return 0; - case MA_SND_CHMAP_FRW: return 0; - case MA_SND_CHMAP_FLH: return 0; - case MA_SND_CHMAP_FCH: return 0; - case MA_SND_CHMAP_FRH: return 0; - case MA_SND_CHMAP_TC: return MA_CHANNEL_TOP_CENTER; - case MA_SND_CHMAP_TFL: return MA_CHANNEL_TOP_FRONT_LEFT; - case MA_SND_CHMAP_TFR: return MA_CHANNEL_TOP_FRONT_RIGHT; - case MA_SND_CHMAP_TFC: return MA_CHANNEL_TOP_FRONT_CENTER; - case MA_SND_CHMAP_TRL: return MA_CHANNEL_TOP_BACK_LEFT; - case MA_SND_CHMAP_TRR: return MA_CHANNEL_TOP_BACK_RIGHT; - case MA_SND_CHMAP_TRC: return MA_CHANNEL_TOP_BACK_CENTER; - default: break; - } - - return 0; -} - -static ma_bool32 ma_is_common_device_name__alsa(const char* name) -{ - size_t iName; - for (iName = 0; iName < ma_countof(g_maCommonDeviceNamesALSA); ++iName) { - if (ma_strcmp(name, g_maCommonDeviceNamesALSA[iName]) == 0) { - return MA_TRUE; - } - } - - return MA_FALSE; -} - - -static ma_bool32 ma_is_playback_device_blacklisted__alsa(const char* name) -{ - size_t iName; - for (iName = 0; iName < ma_countof(g_maBlacklistedPlaybackDeviceNamesALSA); ++iName) { - if (ma_strcmp(name, g_maBlacklistedPlaybackDeviceNamesALSA[iName]) == 0) { - return MA_TRUE; - } - } - - return MA_FALSE; -} - -static ma_bool32 ma_is_capture_device_blacklisted__alsa(const char* name) -{ - size_t iName; - for (iName = 0; iName < ma_countof(g_maBlacklistedCaptureDeviceNamesALSA); ++iName) { - if (ma_strcmp(name, g_maBlacklistedCaptureDeviceNamesALSA[iName]) == 0) { - return MA_TRUE; - } - } - - return MA_FALSE; -} - -static ma_bool32 ma_is_device_blacklisted__alsa(ma_device_type deviceType, const char* name) -{ - if (deviceType == ma_device_type_playback) { - return ma_is_playback_device_blacklisted__alsa(name); - } else { - return ma_is_capture_device_blacklisted__alsa(name); - } -} - - -static const char* ma_find_char(const char* str, char c, int* index) -{ - int i = 0; - for (;;) { - if (str[i] == '\0') { - if (index) *index = -1; - return NULL; - } - - if (str[i] == c) { - if (index) *index = i; - return str + i; - } - - i += 1; - } - - /* Should never get here, but treat it as though the character was not found to make me feel better inside. */ - if (index) *index = -1; - return NULL; -} - -static ma_bool32 ma_is_device_name_in_hw_format__alsa(const char* hwid) -{ - /* This function is just checking whether or not hwid is in "hw:%d,%d" format. */ - - int commaPos; - const char* dev; - int i; - - if (hwid == NULL) { - return MA_FALSE; - } - - if (hwid[0] != 'h' || hwid[1] != 'w' || hwid[2] != ':') { - return MA_FALSE; - } - - hwid += 3; - - dev = ma_find_char(hwid, ',', &commaPos); - if (dev == NULL) { - return MA_FALSE; - } else { - dev += 1; /* Skip past the ",". */ - } - - /* Check if the part between the ":" and the "," contains only numbers. If not, return false. */ - for (i = 0; i < commaPos; ++i) { - if (hwid[i] < '0' || hwid[i] > '9') { - return MA_FALSE; - } - } - - /* Check if everything after the "," is numeric. If not, return false. */ - i = 0; - while (dev[i] != '\0') { - if (dev[i] < '0' || dev[i] > '9') { - return MA_FALSE; - } - i += 1; - } - - return MA_TRUE; -} - -static int ma_convert_device_name_to_hw_format__alsa(ma_context* pContext, char* dst, size_t dstSize, const char* src) /* Returns 0 on success, non-0 on error. */ -{ - /* src should look something like this: "hw:CARD=I82801AAICH,DEV=0" */ - - int colonPos; - int commaPos; - char card[256]; - const char* dev; - int cardIndex; - - if (dst == NULL) { - return -1; - } - if (dstSize < 7) { - return -1; /* Absolute minimum size of the output buffer is 7 bytes. */ - } - - *dst = '\0'; /* Safety. */ - if (src == NULL) { - return -1; - } - - /* If the input name is already in "hw:%d,%d" format, just return that verbatim. */ - if (ma_is_device_name_in_hw_format__alsa(src)) { - return ma_strcpy_s(dst, dstSize, src); - } - - src = ma_find_char(src, ':', &colonPos); - if (src == NULL) { - return -1; /* Couldn't find a colon */ - } - - dev = ma_find_char(src, ',', &commaPos); - if (dev == NULL) { - dev = "0"; - ma_strncpy_s(card, sizeof(card), src+6, (size_t)-1); /* +6 = ":CARD=" */ - } else { - dev = dev + 5; /* +5 = ",DEV=" */ - ma_strncpy_s(card, sizeof(card), src+6, commaPos-6); /* +6 = ":CARD=" */ - } - - cardIndex = ((ma_snd_card_get_index_proc)pContext->alsa.snd_card_get_index)(card); - if (cardIndex < 0) { - return -2; /* Failed to retrieve the card index. */ - } - - - /* Construction. */ - dst[0] = 'h'; dst[1] = 'w'; dst[2] = ':'; - if (ma_itoa_s(cardIndex, dst+3, dstSize-3, 10) != 0) { - return -3; - } - if (ma_strcat_s(dst, dstSize, ",") != 0) { - return -3; - } - if (ma_strcat_s(dst, dstSize, dev) != 0) { - return -3; - } - - return 0; -} - -static ma_bool32 ma_does_id_exist_in_list__alsa(ma_device_id* pUniqueIDs, ma_uint32 count, const char* pHWID) -{ - ma_uint32 i; - - MA_ASSERT(pHWID != NULL); - - for (i = 0; i < count; ++i) { - if (ma_strcmp(pUniqueIDs[i].alsa, pHWID) == 0) { - return MA_TRUE; - } - } - - return MA_FALSE; -} - - -static ma_result ma_context_open_pcm__alsa(ma_context* pContext, ma_share_mode shareMode, ma_device_type deviceType, const ma_device_id* pDeviceID, int openMode, ma_snd_pcm_t** ppPCM) -{ - ma_snd_pcm_t* pPCM; - ma_snd_pcm_stream_t stream; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppPCM != NULL); - - *ppPCM = NULL; - pPCM = NULL; - - stream = (deviceType == ma_device_type_playback) ? MA_SND_PCM_STREAM_PLAYBACK : MA_SND_PCM_STREAM_CAPTURE; - - if (pDeviceID == NULL) { - ma_bool32 isDeviceOpen; - size_t i; - - /* - We're opening the default device. I don't know if trying anything other than "default" is necessary, but it makes - me feel better to try as hard as we can get to get _something_ working. - */ - const char* defaultDeviceNames[] = { - "default", - NULL, - NULL, - NULL, - NULL, - NULL, - NULL - }; - - if (shareMode == ma_share_mode_exclusive) { - defaultDeviceNames[1] = "hw"; - defaultDeviceNames[2] = "hw:0"; - defaultDeviceNames[3] = "hw:0,0"; - } else { - if (deviceType == ma_device_type_playback) { - defaultDeviceNames[1] = "dmix"; - defaultDeviceNames[2] = "dmix:0"; - defaultDeviceNames[3] = "dmix:0,0"; - } else { - defaultDeviceNames[1] = "dsnoop"; - defaultDeviceNames[2] = "dsnoop:0"; - defaultDeviceNames[3] = "dsnoop:0,0"; - } - defaultDeviceNames[4] = "hw"; - defaultDeviceNames[5] = "hw:0"; - defaultDeviceNames[6] = "hw:0,0"; - } - - isDeviceOpen = MA_FALSE; - for (i = 0; i < ma_countof(defaultDeviceNames); ++i) { - if (defaultDeviceNames[i] != NULL && defaultDeviceNames[i][0] != '\0') { - if (((ma_snd_pcm_open_proc)pContext->alsa.snd_pcm_open)(&pPCM, defaultDeviceNames[i], stream, openMode) == 0) { - isDeviceOpen = MA_TRUE; - break; - } - } - } - - if (!isDeviceOpen) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[ALSA] snd_pcm_open() failed when trying to open an appropriate default device."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - } else { - /* - We're trying to open a specific device. There's a few things to consider here: - - miniaudio recongnizes a special format of device id that excludes the "hw", "dmix", etc. prefix. It looks like this: ":0,0", ":0,1", etc. When - an ID of this format is specified, it indicates to miniaudio that it can try different combinations of plugins ("hw", "dmix", etc.) until it - finds an appropriate one that works. This comes in very handy when trying to open a device in shared mode ("dmix"), vs exclusive mode ("hw"). - */ - - /* May end up needing to make small adjustments to the ID, so make a copy. */ - ma_device_id deviceID = *pDeviceID; - int resultALSA = -ENODEV; - - if (deviceID.alsa[0] != ':') { - /* The ID is not in ":0,0" format. Use the ID exactly as-is. */ - resultALSA = ((ma_snd_pcm_open_proc)pContext->alsa.snd_pcm_open)(&pPCM, deviceID.alsa, stream, openMode); - } else { - char hwid[256]; - - /* The ID is in ":0,0" format. Try different plugins depending on the shared mode. */ - if (deviceID.alsa[1] == '\0') { - deviceID.alsa[0] = '\0'; /* An ID of ":" should be converted to "". */ - } - - if (shareMode == ma_share_mode_shared) { - if (deviceType == ma_device_type_playback) { - ma_strcpy_s(hwid, sizeof(hwid), "dmix"); - } else { - ma_strcpy_s(hwid, sizeof(hwid), "dsnoop"); - } - - if (ma_strcat_s(hwid, sizeof(hwid), deviceID.alsa) == 0) { - resultALSA = ((ma_snd_pcm_open_proc)pContext->alsa.snd_pcm_open)(&pPCM, hwid, stream, openMode); - } - } - - /* If at this point we still don't have an open device it means we're either preferencing exclusive mode or opening with "dmix"/"dsnoop" failed. */ - if (resultALSA != 0) { - ma_strcpy_s(hwid, sizeof(hwid), "hw"); - if (ma_strcat_s(hwid, sizeof(hwid), deviceID.alsa) == 0) { - resultALSA = ((ma_snd_pcm_open_proc)pContext->alsa.snd_pcm_open)(&pPCM, hwid, stream, openMode); - } - } - } - - if (resultALSA < 0) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[ALSA] snd_pcm_open() failed."); - return ma_result_from_errno(-resultALSA); - } - } - - *ppPCM = pPCM; - return MA_SUCCESS; -} - - -static ma_result ma_context_enumerate_devices__alsa(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - int resultALSA; - ma_bool32 cbResult = MA_TRUE; - char** ppDeviceHints; - ma_device_id* pUniqueIDs = NULL; - ma_uint32 uniqueIDCount = 0; - char** ppNextDeviceHint; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - ma_mutex_lock(&pContext->alsa.internalDeviceEnumLock); - - resultALSA = ((ma_snd_device_name_hint_proc)pContext->alsa.snd_device_name_hint)(-1, "pcm", (void***)&ppDeviceHints); - if (resultALSA < 0) { - ma_mutex_unlock(&pContext->alsa.internalDeviceEnumLock); - return ma_result_from_errno(-resultALSA); - } - - ppNextDeviceHint = ppDeviceHints; - while (*ppNextDeviceHint != NULL) { - char* NAME = ((ma_snd_device_name_get_hint_proc)pContext->alsa.snd_device_name_get_hint)(*ppNextDeviceHint, "NAME"); - char* DESC = ((ma_snd_device_name_get_hint_proc)pContext->alsa.snd_device_name_get_hint)(*ppNextDeviceHint, "DESC"); - char* IOID = ((ma_snd_device_name_get_hint_proc)pContext->alsa.snd_device_name_get_hint)(*ppNextDeviceHint, "IOID"); - ma_device_type deviceType = ma_device_type_playback; - ma_bool32 stopEnumeration = MA_FALSE; - char hwid[sizeof(pUniqueIDs->alsa)]; - ma_device_info deviceInfo; - - if ((IOID == NULL || ma_strcmp(IOID, "Output") == 0)) { - deviceType = ma_device_type_playback; - } - if ((IOID != NULL && ma_strcmp(IOID, "Input" ) == 0)) { - deviceType = ma_device_type_capture; - } - - if (NAME != NULL) { - if (pContext->alsa.useVerboseDeviceEnumeration) { - /* Verbose mode. Use the name exactly as-is. */ - ma_strncpy_s(hwid, sizeof(hwid), NAME, (size_t)-1); - } else { - /* Simplified mode. Use ":%d,%d" format. */ - if (ma_convert_device_name_to_hw_format__alsa(pContext, hwid, sizeof(hwid), NAME) == 0) { - /* - At this point, hwid looks like "hw:0,0". In simplified enumeration mode, we actually want to strip off the - plugin name so it looks like ":0,0". The reason for this is that this special format is detected at device - initialization time and is used as an indicator to try and use the most appropriate plugin depending on the - device type and sharing mode. - */ - char* dst = hwid; - char* src = hwid+2; - while ((*dst++ = *src++)); - } else { - /* Conversion to "hw:%d,%d" failed. Just use the name as-is. */ - ma_strncpy_s(hwid, sizeof(hwid), NAME, (size_t)-1); - } - - if (ma_does_id_exist_in_list__alsa(pUniqueIDs, uniqueIDCount, hwid)) { - goto next_device; /* The device has already been enumerated. Move on to the next one. */ - } else { - /* The device has not yet been enumerated. Make sure it's added to our list so that it's not enumerated again. */ - size_t newCapacity = sizeof(*pUniqueIDs) * (uniqueIDCount + 1); - ma_device_id* pNewUniqueIDs = (ma_device_id*)ma_realloc(pUniqueIDs, newCapacity, &pContext->allocationCallbacks); - if (pNewUniqueIDs == NULL) { - goto next_device; /* Failed to allocate memory. */ - } - - pUniqueIDs = pNewUniqueIDs; - MA_COPY_MEMORY(pUniqueIDs[uniqueIDCount].alsa, hwid, sizeof(hwid)); - uniqueIDCount += 1; - } - } - } else { - MA_ZERO_MEMORY(hwid, sizeof(hwid)); - } - - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.id.alsa, sizeof(deviceInfo.id.alsa), hwid, (size_t)-1); - - /* - There's no good way to determine whether or not a device is the default on Linux. We're just going to do something simple and - just use the name of "default" as the indicator. - */ - if (ma_strcmp(deviceInfo.id.alsa, "default") == 0) { - deviceInfo.isDefault = MA_TRUE; - } - - - /* - DESC is the friendly name. We treat this slightly differently depending on whether or not we are using verbose - device enumeration. In verbose mode we want to take the entire description so that the end-user can distinguish - between the subdevices of each card/dev pair. In simplified mode, however, we only want the first part of the - description. - - The value in DESC seems to be split into two lines, with the first line being the name of the device and the - second line being a description of the device. I don't like having the description be across two lines because - it makes formatting ugly and annoying. I'm therefore deciding to put it all on a single line with the second line - being put into parentheses. In simplified mode I'm just stripping the second line entirely. - */ - if (DESC != NULL) { - int lfPos; - const char* line2 = ma_find_char(DESC, '\n', &lfPos); - if (line2 != NULL) { - line2 += 1; /* Skip past the new-line character. */ - - if (pContext->alsa.useVerboseDeviceEnumeration) { - /* Verbose mode. Put the second line in brackets. */ - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), DESC, lfPos); - ma_strcat_s (deviceInfo.name, sizeof(deviceInfo.name), " ("); - ma_strcat_s (deviceInfo.name, sizeof(deviceInfo.name), line2); - ma_strcat_s (deviceInfo.name, sizeof(deviceInfo.name), ")"); - } else { - /* Simplified mode. Strip the second line entirely. */ - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), DESC, lfPos); - } - } else { - /* There's no second line. Just copy the whole description. */ - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), DESC, (size_t)-1); - } - } - - if (!ma_is_device_blacklisted__alsa(deviceType, NAME)) { - cbResult = callback(pContext, deviceType, &deviceInfo, pUserData); - } - - /* - Some devices are both playback and capture, but they are only enumerated by ALSA once. We need to fire the callback - again for the other device type in this case. We do this for known devices and where the IOID hint is NULL, which - means both Input and Output. - */ - if (cbResult) { - if (ma_is_common_device_name__alsa(NAME) || IOID == NULL) { - if (deviceType == ma_device_type_playback) { - if (!ma_is_capture_device_blacklisted__alsa(NAME)) { - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - } else { - if (!ma_is_playback_device_blacklisted__alsa(NAME)) { - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - } - } - } - - if (cbResult == MA_FALSE) { - stopEnumeration = MA_TRUE; - } - - next_device: - free(NAME); - free(DESC); - free(IOID); - ppNextDeviceHint += 1; - - /* We need to stop enumeration if the callback returned false. */ - if (stopEnumeration) { - break; - } - } - - ma_free(pUniqueIDs, &pContext->allocationCallbacks); - ((ma_snd_device_name_free_hint_proc)pContext->alsa.snd_device_name_free_hint)((void**)ppDeviceHints); - - ma_mutex_unlock(&pContext->alsa.internalDeviceEnumLock); - - return MA_SUCCESS; -} - - -typedef struct -{ - ma_device_type deviceType; - const ma_device_id* pDeviceID; - ma_share_mode shareMode; - ma_device_info* pDeviceInfo; - ma_bool32 foundDevice; -} ma_context_get_device_info_enum_callback_data__alsa; - -static ma_bool32 ma_context_get_device_info_enum_callback__alsa(ma_context* pContext, ma_device_type deviceType, const ma_device_info* pDeviceInfo, void* pUserData) -{ - ma_context_get_device_info_enum_callback_data__alsa* pData = (ma_context_get_device_info_enum_callback_data__alsa*)pUserData; - MA_ASSERT(pData != NULL); - - (void)pContext; - - if (pData->pDeviceID == NULL && ma_strcmp(pDeviceInfo->id.alsa, "default") == 0) { - ma_strncpy_s(pData->pDeviceInfo->name, sizeof(pData->pDeviceInfo->name), pDeviceInfo->name, (size_t)-1); - pData->foundDevice = MA_TRUE; - } else { - if (pData->deviceType == deviceType && (pData->pDeviceID != NULL && ma_strcmp(pData->pDeviceID->alsa, pDeviceInfo->id.alsa) == 0)) { - ma_strncpy_s(pData->pDeviceInfo->name, sizeof(pData->pDeviceInfo->name), pDeviceInfo->name, (size_t)-1); - pData->foundDevice = MA_TRUE; - } - } - - /* Keep enumerating until we have found the device. */ - return !pData->foundDevice; -} - -static void ma_context_test_rate_and_add_native_data_format__alsa(ma_context* pContext, ma_snd_pcm_t* pPCM, ma_snd_pcm_hw_params_t* pHWParams, ma_format format, ma_uint32 channels, ma_uint32 sampleRate, ma_uint32 flags, ma_device_info* pDeviceInfo) -{ - MA_ASSERT(pPCM != NULL); - MA_ASSERT(pHWParams != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - if (pDeviceInfo->nativeDataFormatCount < ma_countof(pDeviceInfo->nativeDataFormats) && ((ma_snd_pcm_hw_params_test_rate_proc)pContext->alsa.snd_pcm_hw_params_test_rate)(pPCM, pHWParams, sampleRate, 0) == 0) { - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = format; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = sampleRate; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = flags; - pDeviceInfo->nativeDataFormatCount += 1; - } -} - -static void ma_context_iterate_rates_and_add_native_data_format__alsa(ma_context* pContext, ma_snd_pcm_t* pPCM, ma_snd_pcm_hw_params_t* pHWParams, ma_format format, ma_uint32 channels, ma_uint32 flags, ma_device_info* pDeviceInfo) -{ - ma_uint32 iSampleRate; - unsigned int minSampleRate; - unsigned int maxSampleRate; - int sampleRateDir; /* Not used. Just passed into snd_pcm_hw_params_get_rate_min/max(). */ - - /* There could be a range. */ - ((ma_snd_pcm_hw_params_get_rate_min_proc)pContext->alsa.snd_pcm_hw_params_get_rate_min)(pHWParams, &minSampleRate, &sampleRateDir); - ((ma_snd_pcm_hw_params_get_rate_max_proc)pContext->alsa.snd_pcm_hw_params_get_rate_max)(pHWParams, &maxSampleRate, &sampleRateDir); - - /* Make sure our sample rates are clamped to sane values. Stupid devices like "pulse" will reports rates like "1" which is ridiculus. */ - minSampleRate = ma_clamp(minSampleRate, (unsigned int)ma_standard_sample_rate_min, (unsigned int)ma_standard_sample_rate_max); - maxSampleRate = ma_clamp(maxSampleRate, (unsigned int)ma_standard_sample_rate_min, (unsigned int)ma_standard_sample_rate_max); - - for (iSampleRate = 0; iSampleRate < ma_countof(g_maStandardSampleRatePriorities); iSampleRate += 1) { - ma_uint32 standardSampleRate = g_maStandardSampleRatePriorities[iSampleRate]; - - if (standardSampleRate >= minSampleRate && standardSampleRate <= maxSampleRate) { - ma_context_test_rate_and_add_native_data_format__alsa(pContext, pPCM, pHWParams, format, channels, standardSampleRate, flags, pDeviceInfo); - } - } - - /* Now make sure our min and max rates are included just in case they aren't in the range of our standard rates. */ - if (!ma_is_standard_sample_rate(minSampleRate)) { - ma_context_test_rate_and_add_native_data_format__alsa(pContext, pPCM, pHWParams, format, channels, minSampleRate, flags, pDeviceInfo); - } - - if (!ma_is_standard_sample_rate(maxSampleRate) && maxSampleRate != minSampleRate) { - ma_context_test_rate_and_add_native_data_format__alsa(pContext, pPCM, pHWParams, format, channels, maxSampleRate, flags, pDeviceInfo); - } -} - -static ma_result ma_context_get_device_info__alsa(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_context_get_device_info_enum_callback_data__alsa data; - ma_result result; - int resultALSA; - ma_snd_pcm_t* pPCM; - ma_snd_pcm_hw_params_t* pHWParams; - ma_uint32 iFormat; - ma_uint32 iChannel; - - MA_ASSERT(pContext != NULL); - - /* We just enumerate to find basic information about the device. */ - data.deviceType = deviceType; - data.pDeviceID = pDeviceID; - data.pDeviceInfo = pDeviceInfo; - data.foundDevice = MA_FALSE; - result = ma_context_enumerate_devices__alsa(pContext, ma_context_get_device_info_enum_callback__alsa, &data); - if (result != MA_SUCCESS) { - return result; - } - - if (!data.foundDevice) { - return MA_NO_DEVICE; - } - - if (ma_strcmp(pDeviceInfo->id.alsa, "default") == 0) { - pDeviceInfo->isDefault = MA_TRUE; - } - - /* For detailed info we need to open the device. */ - result = ma_context_open_pcm__alsa(pContext, ma_share_mode_shared, deviceType, pDeviceID, 0, &pPCM); - if (result != MA_SUCCESS) { - return result; - } - - /* We need to initialize a HW parameters object in order to know what formats are supported. */ - pHWParams = (ma_snd_pcm_hw_params_t*)ma_calloc(((ma_snd_pcm_hw_params_sizeof_proc)pContext->alsa.snd_pcm_hw_params_sizeof)(), &pContext->allocationCallbacks); - if (pHWParams == NULL) { - ((ma_snd_pcm_close_proc)pContext->alsa.snd_pcm_close)(pPCM); - return MA_OUT_OF_MEMORY; - } - - resultALSA = ((ma_snd_pcm_hw_params_any_proc)pContext->alsa.snd_pcm_hw_params_any)(pPCM, pHWParams); - if (resultALSA < 0) { - ma_free(pHWParams, &pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pContext->alsa.snd_pcm_close)(pPCM); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to initialize hardware parameters. snd_pcm_hw_params_any() failed."); - return ma_result_from_errno(-resultALSA); - } - - /* - Some ALSA devices can support many permutations of formats, channels and rates. We only support - a fixed number of permutations which means we need to employ some strategies to ensure the best - combinations are returned. An example is the "pulse" device which can do it's own data conversion - in software and as a result can support any combination of format, channels and rate. - - We want to ensure the the first data formats are the best. We have a list of favored sample - formats and sample rates, so these will be the basis of our iteration. - */ - - /* Formats. We just iterate over our standard formats and test them, making sure we reset the configuration space each iteration. */ - for (iFormat = 0; iFormat < ma_countof(g_maFormatPriorities); iFormat += 1) { - ma_format format = g_maFormatPriorities[iFormat]; - - /* - For each format we need to make sure we reset the configuration space so we don't return - channel counts and rates that aren't compatible with a format. - */ - ((ma_snd_pcm_hw_params_any_proc)pContext->alsa.snd_pcm_hw_params_any)(pPCM, pHWParams); - - /* Test the format first. If this fails it means the format is not supported and we can skip it. */ - if (((ma_snd_pcm_hw_params_test_format_proc)pContext->alsa.snd_pcm_hw_params_test_format)(pPCM, pHWParams, ma_convert_ma_format_to_alsa_format(format)) == 0) { - /* The format is supported. */ - unsigned int minChannels; - unsigned int maxChannels; - - /* - The configuration space needs to be restricted to this format so we can get an accurate - picture of which sample rates and channel counts are support with this format. - */ - ((ma_snd_pcm_hw_params_set_format_proc)pContext->alsa.snd_pcm_hw_params_set_format)(pPCM, pHWParams, ma_convert_ma_format_to_alsa_format(format)); - - /* Now we need to check for supported channels. */ - ((ma_snd_pcm_hw_params_get_channels_min_proc)pContext->alsa.snd_pcm_hw_params_get_channels_min)(pHWParams, &minChannels); - ((ma_snd_pcm_hw_params_get_channels_max_proc)pContext->alsa.snd_pcm_hw_params_get_channels_max)(pHWParams, &maxChannels); - - if (minChannels > MA_MAX_CHANNELS) { - continue; /* Too many channels. */ - } - if (maxChannels < MA_MIN_CHANNELS) { - continue; /* Not enough channels. */ - } - - /* - Make sure the channel count is clamped. This is mainly intended for the max channels - because some devices can report an unbound maximum. - */ - minChannels = ma_clamp(minChannels, MA_MIN_CHANNELS, MA_MAX_CHANNELS); - maxChannels = ma_clamp(maxChannels, MA_MIN_CHANNELS, MA_MAX_CHANNELS); - - if (minChannels == MA_MIN_CHANNELS && maxChannels == MA_MAX_CHANNELS) { - /* The device supports all channels. Don't iterate over every single one. Instead just set the channels to 0 which means all channels are supported. */ - ma_context_iterate_rates_and_add_native_data_format__alsa(pContext, pPCM, pHWParams, format, 0, 0, pDeviceInfo); /* Intentionally setting the channel count to 0 as that means all channels are supported. */ - } else { - /* The device only supports a specific set of channels. We need to iterate over all of them. */ - for (iChannel = minChannels; iChannel <= maxChannels; iChannel += 1) { - /* Test the channel before applying it to the configuration space. */ - unsigned int channels = iChannel; - - /* Make sure our channel range is reset before testing again or else we'll always fail the test. */ - ((ma_snd_pcm_hw_params_any_proc)pContext->alsa.snd_pcm_hw_params_any)(pPCM, pHWParams); - ((ma_snd_pcm_hw_params_set_format_proc)pContext->alsa.snd_pcm_hw_params_set_format)(pPCM, pHWParams, ma_convert_ma_format_to_alsa_format(format)); - - if (((ma_snd_pcm_hw_params_test_channels_proc)pContext->alsa.snd_pcm_hw_params_test_channels)(pPCM, pHWParams, channels) == 0) { - /* The channel count is supported. */ - - /* The configuration space now needs to be restricted to the channel count before extracting the sample rate. */ - ((ma_snd_pcm_hw_params_set_channels_proc)pContext->alsa.snd_pcm_hw_params_set_channels)(pPCM, pHWParams, channels); - - /* Only after the configuration space has been restricted to the specific channel count should we iterate over our sample rates. */ - ma_context_iterate_rates_and_add_native_data_format__alsa(pContext, pPCM, pHWParams, format, channels, 0, pDeviceInfo); - } else { - /* The channel count is not supported. Skip. */ - } - } - } - } else { - /* The format is not supported. Skip. */ - } - } - - ma_free(pHWParams, &pContext->allocationCallbacks); - - ((ma_snd_pcm_close_proc)pContext->alsa.snd_pcm_close)(pPCM); - return MA_SUCCESS; -} - -static ma_result ma_device_uninit__alsa(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if ((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture) { - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture); - close(pDevice->alsa.wakeupfdCapture); - ma_free(pDevice->alsa.pPollDescriptorsCapture, &pDevice->pContext->allocationCallbacks); - } - - if ((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback) { - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback); - close(pDevice->alsa.wakeupfdPlayback); - ma_free(pDevice->alsa.pPollDescriptorsPlayback, &pDevice->pContext->allocationCallbacks); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_init_by_type__alsa(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptor, ma_device_type deviceType) -{ - ma_result result; - int resultALSA; - ma_snd_pcm_t* pPCM; - ma_bool32 isUsingMMap; - ma_snd_pcm_format_t formatALSA; - ma_format internalFormat; - ma_uint32 internalChannels; - ma_uint32 internalSampleRate; - ma_channel internalChannelMap[MA_MAX_CHANNELS]; - ma_uint32 internalPeriodSizeInFrames; - ma_uint32 internalPeriods; - int openMode; - ma_snd_pcm_hw_params_t* pHWParams; - ma_snd_pcm_sw_params_t* pSWParams; - ma_snd_pcm_uframes_t bufferBoundary; - int pollDescriptorCount; - struct pollfd* pPollDescriptors; - int wakeupfd; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(deviceType != ma_device_type_duplex); /* This function should only be called for playback _or_ capture, never duplex. */ - MA_ASSERT(pDevice != NULL); - - formatALSA = ma_convert_ma_format_to_alsa_format(pDescriptor->format); - - openMode = 0; - if (pConfig->alsa.noAutoResample) { - openMode |= MA_SND_PCM_NO_AUTO_RESAMPLE; - } - if (pConfig->alsa.noAutoChannels) { - openMode |= MA_SND_PCM_NO_AUTO_CHANNELS; - } - if (pConfig->alsa.noAutoFormat) { - openMode |= MA_SND_PCM_NO_AUTO_FORMAT; - } - - result = ma_context_open_pcm__alsa(pDevice->pContext, pDescriptor->shareMode, deviceType, pDescriptor->pDeviceID, openMode, &pPCM); - if (result != MA_SUCCESS) { - return result; - } - - - /* Hardware parameters. */ - pHWParams = (ma_snd_pcm_hw_params_t*)ma_calloc(((ma_snd_pcm_hw_params_sizeof_proc)pDevice->pContext->alsa.snd_pcm_hw_params_sizeof)(), &pDevice->pContext->allocationCallbacks); - if (pHWParams == NULL) { - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to allocate memory for hardware parameters."); - return MA_OUT_OF_MEMORY; - } - - resultALSA = ((ma_snd_pcm_hw_params_any_proc)pDevice->pContext->alsa.snd_pcm_hw_params_any)(pPCM, pHWParams); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to initialize hardware parameters. snd_pcm_hw_params_any() failed."); - return ma_result_from_errno(-resultALSA); - } - - /* MMAP Mode. Try using interleaved MMAP access. If this fails, fall back to standard readi/writei. */ - isUsingMMap = MA_FALSE; -#if 0 /* NOTE: MMAP mode temporarily disabled. */ - if (deviceType != ma_device_type_capture) { /* <-- Disabling MMAP mode for capture devices because I apparently do not have a device that supports it which means I can't test it... Contributions welcome. */ - if (!pConfig->alsa.noMMap) { - if (((ma_snd_pcm_hw_params_set_access_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_access)(pPCM, pHWParams, MA_SND_PCM_ACCESS_MMAP_INTERLEAVED) == 0) { - pDevice->alsa.isUsingMMap = MA_TRUE; - } - } - } -#endif - - if (!isUsingMMap) { - resultALSA = ((ma_snd_pcm_hw_params_set_access_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_access)(pPCM, pHWParams, MA_SND_PCM_ACCESS_RW_INTERLEAVED); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set access mode to neither SND_PCM_ACCESS_MMAP_INTERLEAVED nor SND_PCM_ACCESS_RW_INTERLEAVED. snd_pcm_hw_params_set_access() failed."); - return ma_result_from_errno(-resultALSA); - } - } - - /* - Most important properties first. The documentation for OSS (yes, I know this is ALSA!) recommends format, channels, then sample rate. I can't - find any documentation for ALSA specifically, so I'm going to copy the recommendation for OSS. - */ - - /* Format. */ - { - /* - At this point we should have a list of supported formats, so now we need to find the best one. We first check if the requested format is - supported, and if so, use that one. If it's not supported, we just run though a list of formats and try to find the best one. - */ - if (formatALSA == MA_SND_PCM_FORMAT_UNKNOWN || ((ma_snd_pcm_hw_params_test_format_proc)pDevice->pContext->alsa.snd_pcm_hw_params_test_format)(pPCM, pHWParams, formatALSA) != 0) { - /* We're either requesting the native format or the specified format is not supported. */ - size_t iFormat; - - formatALSA = MA_SND_PCM_FORMAT_UNKNOWN; - for (iFormat = 0; iFormat < ma_countof(g_maFormatPriorities); ++iFormat) { - if (((ma_snd_pcm_hw_params_test_format_proc)pDevice->pContext->alsa.snd_pcm_hw_params_test_format)(pPCM, pHWParams, ma_convert_ma_format_to_alsa_format(g_maFormatPriorities[iFormat])) == 0) { - formatALSA = ma_convert_ma_format_to_alsa_format(g_maFormatPriorities[iFormat]); - break; - } - } - - if (formatALSA == MA_SND_PCM_FORMAT_UNKNOWN) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Format not supported. The device does not support any miniaudio formats."); - return MA_FORMAT_NOT_SUPPORTED; - } - } - - resultALSA = ((ma_snd_pcm_hw_params_set_format_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_format)(pPCM, pHWParams, formatALSA); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Format not supported. snd_pcm_hw_params_set_format() failed."); - return ma_result_from_errno(-resultALSA); - } - - internalFormat = ma_format_from_alsa(formatALSA); - if (internalFormat == ma_format_unknown) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] The chosen format is not supported by miniaudio."); - return MA_FORMAT_NOT_SUPPORTED; - } - } - - /* Channels. */ - { - unsigned int channels = pDescriptor->channels; - if (channels == 0) { - channels = MA_DEFAULT_CHANNELS; - } - - resultALSA = ((ma_snd_pcm_hw_params_set_channels_near_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_channels_near)(pPCM, pHWParams, &channels); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set channel count. snd_pcm_hw_params_set_channels_near() failed."); - return ma_result_from_errno(-resultALSA); - } - - internalChannels = (ma_uint32)channels; - } - - /* Sample Rate */ - { - unsigned int sampleRate; - - /* - It appears there's either a bug in ALSA, a bug in some drivers, or I'm doing something silly; but having resampling enabled causes - problems with some device configurations when used in conjunction with MMAP access mode. To fix this problem we need to disable - resampling. - - To reproduce this problem, open the "plug:dmix" device, and set the sample rate to 44100. Internally, it looks like dmix uses a - sample rate of 48000. The hardware parameters will get set correctly with no errors, but it looks like the 44100 -> 48000 resampling - doesn't work properly - but only with MMAP access mode. You will notice skipping/crackling in the audio, and it'll run at a slightly - faster rate. - - miniaudio has built-in support for sample rate conversion (albeit low quality at the moment), so disabling resampling should be fine - for us. The only problem is that it won't be taking advantage of any kind of hardware-accelerated resampling and it won't be very - good quality until I get a chance to improve the quality of miniaudio's software sample rate conversion. - - I don't currently know if the dmix plugin is the only one with this error. Indeed, this is the only one I've been able to reproduce - this error with. In the future, we may want to restrict the disabling of resampling to only known bad plugins. - */ - ((ma_snd_pcm_hw_params_set_rate_resample_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_rate_resample)(pPCM, pHWParams, 0); - - sampleRate = pDescriptor->sampleRate; - if (sampleRate == 0) { - sampleRate = MA_DEFAULT_SAMPLE_RATE; - } - - resultALSA = ((ma_snd_pcm_hw_params_set_rate_near_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_rate_near)(pPCM, pHWParams, &sampleRate, 0); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Sample rate not supported. snd_pcm_hw_params_set_rate_near() failed."); - return ma_result_from_errno(-resultALSA); - } - - internalSampleRate = (ma_uint32)sampleRate; - } - - /* Periods. */ - { - ma_uint32 periods = pDescriptor->periodCount; - - resultALSA = ((ma_snd_pcm_hw_params_set_periods_near_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_periods_near)(pPCM, pHWParams, &periods, NULL); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set period count. snd_pcm_hw_params_set_periods_near() failed."); - return ma_result_from_errno(-resultALSA); - } - - internalPeriods = periods; - } - - /* Buffer Size */ - { - ma_snd_pcm_uframes_t actualBufferSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, internalSampleRate, pConfig->performanceProfile) * internalPeriods; - - resultALSA = ((ma_snd_pcm_hw_params_set_buffer_size_near_proc)pDevice->pContext->alsa.snd_pcm_hw_params_set_buffer_size_near)(pPCM, pHWParams, &actualBufferSizeInFrames); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set buffer size for device. snd_pcm_hw_params_set_buffer_size() failed."); - return ma_result_from_errno(-resultALSA); - } - - internalPeriodSizeInFrames = actualBufferSizeInFrames / internalPeriods; - } - - /* Apply hardware parameters. */ - resultALSA = ((ma_snd_pcm_hw_params_proc)pDevice->pContext->alsa.snd_pcm_hw_params)(pPCM, pHWParams); - if (resultALSA < 0) { - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set hardware parameters. snd_pcm_hw_params() failed."); - return ma_result_from_errno(-resultALSA); - } - - ma_free(pHWParams, &pDevice->pContext->allocationCallbacks); - pHWParams = NULL; - - - /* Software parameters. */ - pSWParams = (ma_snd_pcm_sw_params_t*)ma_calloc(((ma_snd_pcm_sw_params_sizeof_proc)pDevice->pContext->alsa.snd_pcm_sw_params_sizeof)(), &pDevice->pContext->allocationCallbacks); - if (pSWParams == NULL) { - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to allocate memory for software parameters."); - return MA_OUT_OF_MEMORY; - } - - resultALSA = ((ma_snd_pcm_sw_params_current_proc)pDevice->pContext->alsa.snd_pcm_sw_params_current)(pPCM, pSWParams); - if (resultALSA < 0) { - ma_free(pSWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to initialize software parameters. snd_pcm_sw_params_current() failed."); - return ma_result_from_errno(-resultALSA); - } - - resultALSA = ((ma_snd_pcm_sw_params_set_avail_min_proc)pDevice->pContext->alsa.snd_pcm_sw_params_set_avail_min)(pPCM, pSWParams, ma_prev_power_of_2(internalPeriodSizeInFrames)); - if (resultALSA < 0) { - ma_free(pSWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] snd_pcm_sw_params_set_avail_min() failed."); - return ma_result_from_errno(-resultALSA); - } - - resultALSA = ((ma_snd_pcm_sw_params_get_boundary_proc)pDevice->pContext->alsa.snd_pcm_sw_params_get_boundary)(pSWParams, &bufferBoundary); - if (resultALSA < 0) { - bufferBoundary = internalPeriodSizeInFrames * internalPeriods; - } - - if (deviceType == ma_device_type_playback && !isUsingMMap) { /* Only playback devices in writei/readi mode need a start threshold. */ - /* - Subtle detail here with the start threshold. When in playback-only mode (no full-duplex) we can set the start threshold to - the size of a period. But for full-duplex we need to set it such that it is at least two periods. - */ - resultALSA = ((ma_snd_pcm_sw_params_set_start_threshold_proc)pDevice->pContext->alsa.snd_pcm_sw_params_set_start_threshold)(pPCM, pSWParams, internalPeriodSizeInFrames*2); - if (resultALSA < 0) { - ma_free(pSWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set start threshold for playback device. snd_pcm_sw_params_set_start_threshold() failed."); - return ma_result_from_errno(-resultALSA); - } - - resultALSA = ((ma_snd_pcm_sw_params_set_stop_threshold_proc)pDevice->pContext->alsa.snd_pcm_sw_params_set_stop_threshold)(pPCM, pSWParams, bufferBoundary); - if (resultALSA < 0) { /* Set to boundary to loop instead of stop in the event of an xrun. */ - ma_free(pSWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set stop threshold for playback device. snd_pcm_sw_params_set_stop_threshold() failed."); - return ma_result_from_errno(-resultALSA); - } - } - - resultALSA = ((ma_snd_pcm_sw_params_proc)pDevice->pContext->alsa.snd_pcm_sw_params)(pPCM, pSWParams); - if (resultALSA < 0) { - ma_free(pSWParams, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to set software parameters. snd_pcm_sw_params() failed."); - return ma_result_from_errno(-resultALSA); - } - - ma_free(pSWParams, &pDevice->pContext->allocationCallbacks); - pSWParams = NULL; - - - /* Grab the internal channel map. For now we're not going to bother trying to change the channel map and instead just do it ourselves. */ - { - ma_snd_pcm_chmap_t* pChmap = NULL; - if (pDevice->pContext->alsa.snd_pcm_get_chmap != NULL) { - pChmap = ((ma_snd_pcm_get_chmap_proc)pDevice->pContext->alsa.snd_pcm_get_chmap)(pPCM); - } - - if (pChmap != NULL) { - ma_uint32 iChannel; - - /* There are cases where the returned channel map can have a different channel count than was returned by snd_pcm_hw_params_set_channels_near(). */ - if (pChmap->channels >= internalChannels) { - /* Drop excess channels. */ - for (iChannel = 0; iChannel < internalChannels; ++iChannel) { - internalChannelMap[iChannel] = ma_convert_alsa_channel_position_to_ma_channel(pChmap->pos[iChannel]); - } - } else { - ma_uint32 i; - - /* - Excess channels use defaults. Do an initial fill with defaults, overwrite the first pChmap->channels, validate to ensure there are no duplicate - channels. If validation fails, fall back to defaults. - */ - ma_bool32 isValid = MA_TRUE; - - /* Fill with defaults. */ - ma_channel_map_init_standard(ma_standard_channel_map_alsa, internalChannelMap, ma_countof(internalChannelMap), internalChannels); - - /* Overwrite first pChmap->channels channels. */ - for (iChannel = 0; iChannel < pChmap->channels; ++iChannel) { - internalChannelMap[iChannel] = ma_convert_alsa_channel_position_to_ma_channel(pChmap->pos[iChannel]); - } - - /* Validate. */ - for (i = 0; i < internalChannels && isValid; ++i) { - ma_uint32 j; - for (j = i+1; j < internalChannels; ++j) { - if (internalChannelMap[i] == internalChannelMap[j]) { - isValid = MA_FALSE; - break; - } - } - } - - /* If our channel map is invalid, fall back to defaults. */ - if (!isValid) { - ma_channel_map_init_standard(ma_standard_channel_map_alsa, internalChannelMap, ma_countof(internalChannelMap), internalChannels); - } - } - - free(pChmap); - pChmap = NULL; - } else { - /* Could not retrieve the channel map. Fall back to a hard-coded assumption. */ - ma_channel_map_init_standard(ma_standard_channel_map_alsa, internalChannelMap, ma_countof(internalChannelMap), internalChannels); - } - } - - - /* - We need to retrieve the poll descriptors so we can use poll() to wait for data to become - available for reading or writing. There's no well defined maximum for this so we're just going - to allocate this on the heap. - */ - pollDescriptorCount = ((ma_snd_pcm_poll_descriptors_count_proc)pDevice->pContext->alsa.snd_pcm_poll_descriptors_count)(pPCM); - if (pollDescriptorCount <= 0) { - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to retrieve poll descriptors count."); - return MA_ERROR; - } - - pPollDescriptors = (struct pollfd*)ma_malloc(sizeof(*pPollDescriptors) * (pollDescriptorCount + 1), &pDevice->pContext->allocationCallbacks); /* +1 because we want room for the wakeup descriptor. */ - if (pPollDescriptors == NULL) { - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to allocate memory for poll descriptors."); - return MA_OUT_OF_MEMORY; - } - - /* - We need an eventfd to wakeup from poll() and avoid a deadlock in situations where the driver - never returns from writei() and readi(). This has been observed with the "pulse" device. - */ - wakeupfd = eventfd(0, 0); - if (wakeupfd < 0) { - ma_free(pPollDescriptors, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to create eventfd for poll wakeup."); - return ma_result_from_errno(errno); - } - - /* We'll place the wakeup fd at the start of the buffer. */ - pPollDescriptors[0].fd = wakeupfd; - pPollDescriptors[0].events = POLLIN; /* We only care about waiting to read from the wakeup file descriptor. */ - pPollDescriptors[0].revents = 0; - - /* We can now extract the PCM poll descriptors which we place after the wakeup descriptor. */ - pollDescriptorCount = ((ma_snd_pcm_poll_descriptors_proc)pDevice->pContext->alsa.snd_pcm_poll_descriptors)(pPCM, pPollDescriptors + 1, pollDescriptorCount); /* +1 because we want to place these descriptors after the wakeup descriptor. */ - if (pollDescriptorCount <= 0) { - close(wakeupfd); - ma_free(pPollDescriptors, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to retrieve poll descriptors."); - return MA_ERROR; - } - - if (deviceType == ma_device_type_capture) { - pDevice->alsa.pollDescriptorCountCapture = pollDescriptorCount; - pDevice->alsa.pPollDescriptorsCapture = pPollDescriptors; - pDevice->alsa.wakeupfdCapture = wakeupfd; - } else { - pDevice->alsa.pollDescriptorCountPlayback = pollDescriptorCount; - pDevice->alsa.pPollDescriptorsPlayback = pPollDescriptors; - pDevice->alsa.wakeupfdPlayback = wakeupfd; - } - - - /* We're done. Prepare the device. */ - resultALSA = ((ma_snd_pcm_prepare_proc)pDevice->pContext->alsa.snd_pcm_prepare)(pPCM); - if (resultALSA < 0) { - close(wakeupfd); - ma_free(pPollDescriptors, &pDevice->pContext->allocationCallbacks); - ((ma_snd_pcm_close_proc)pDevice->pContext->alsa.snd_pcm_close)(pPCM); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to prepare device."); - return ma_result_from_errno(-resultALSA); - } - - - if (deviceType == ma_device_type_capture) { - pDevice->alsa.pPCMCapture = (ma_ptr)pPCM; - pDevice->alsa.isUsingMMapCapture = isUsingMMap; - } else { - pDevice->alsa.pPCMPlayback = (ma_ptr)pPCM; - pDevice->alsa.isUsingMMapPlayback = isUsingMMap; - } - - pDescriptor->format = internalFormat; - pDescriptor->channels = internalChannels; - pDescriptor->sampleRate = internalSampleRate; - ma_channel_map_copy(pDescriptor->channelMap, internalChannelMap, ma_min(internalChannels, MA_MAX_CHANNELS)); - pDescriptor->periodSizeInFrames = internalPeriodSizeInFrames; - pDescriptor->periodCount = internalPeriods; - - return MA_SUCCESS; -} - -static ma_result ma_device_init__alsa(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->alsa); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_by_type__alsa(pDevice, pConfig, pDescriptorCapture, ma_device_type_capture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_by_type__alsa(pDevice, pConfig, pDescriptorPlayback, ma_device_type_playback); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__alsa(ma_device* pDevice) -{ - int resultALSA; - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - resultALSA = ((ma_snd_pcm_start_proc)pDevice->pContext->alsa.snd_pcm_start)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture); - if (resultALSA < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to start capture device."); - return ma_result_from_errno(-resultALSA); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - /* Don't need to do anything for playback because it'll be started automatically when enough data has been written. */ - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__alsa(ma_device* pDevice) -{ - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Dropping capture device...\n"); - ((ma_snd_pcm_drop_proc)pDevice->pContext->alsa.snd_pcm_drop)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Dropping capture device successful.\n"); - - /* We need to prepare the device again, otherwise we won't be able to restart the device. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Preparing capture device...\n"); - if (((ma_snd_pcm_prepare_proc)pDevice->pContext->alsa.snd_pcm_prepare)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture) < 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Preparing capture device failed.\n"); - } else { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Preparing capture device successful.\n"); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Dropping playback device...\n"); - ((ma_snd_pcm_drop_proc)pDevice->pContext->alsa.snd_pcm_drop)((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Dropping playback device successful.\n"); - - /* We need to prepare the device again, otherwise we won't be able to restart the device. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Preparing playback device...\n"); - if (((ma_snd_pcm_prepare_proc)pDevice->pContext->alsa.snd_pcm_prepare)((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback) < 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Preparing playback device failed.\n"); - } else { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Preparing playback device successful.\n"); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_wait__alsa(ma_device* pDevice, ma_snd_pcm_t* pPCM, struct pollfd* pPollDescriptors, int pollDescriptorCount, short requiredEvent) -{ - for (;;) { - unsigned short revents; - int resultALSA; - int resultPoll = poll(pPollDescriptors, pollDescriptorCount, -1); - if (resultPoll < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] poll() failed."); - return ma_result_from_errno(errno); - } - - /* - Before checking the ALSA poll descriptor flag we need to check if the wakeup descriptor - has had it's POLLIN flag set. If so, we need to actually read the data and then exit - function. The wakeup descriptor will be the first item in the descriptors buffer. - */ - if ((pPollDescriptors[0].revents & POLLIN) != 0) { - ma_uint64 t; - int resultRead = read(pPollDescriptors[0].fd, &t, sizeof(t)); /* <-- Important that we read here so that the next write() does not block. */ - if (resultRead < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] read() failed."); - return ma_result_from_errno(errno); - } - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] POLLIN set for wakeupfd\n"); - return MA_DEVICE_NOT_STARTED; - } - - /* - Getting here means that some data should be able to be read. We need to use ALSA to - translate the revents flags for us. - */ - resultALSA = ((ma_snd_pcm_poll_descriptors_revents_proc)pDevice->pContext->alsa.snd_pcm_poll_descriptors_revents)(pPCM, pPollDescriptors + 1, pollDescriptorCount - 1, &revents); /* +1, -1 to ignore the wakeup descriptor. */ - if (resultALSA < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] snd_pcm_poll_descriptors_revents() failed."); - return ma_result_from_errno(-resultALSA); - } - - if ((revents & POLLERR) != 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] POLLERR detected."); - return ma_result_from_errno(errno); - } - - if ((revents & requiredEvent) == requiredEvent) { - break; /* We're done. Data available for reading or writing. */ - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_wait_read__alsa(ma_device* pDevice) -{ - return ma_device_wait__alsa(pDevice, (ma_snd_pcm_t*)pDevice->alsa.pPCMCapture, (struct pollfd*)pDevice->alsa.pPollDescriptorsCapture, pDevice->alsa.pollDescriptorCountCapture + 1, POLLIN); /* +1 to account for the wakeup descriptor. */ -} - -static ma_result ma_device_wait_write__alsa(ma_device* pDevice) -{ - return ma_device_wait__alsa(pDevice, (ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback, (struct pollfd*)pDevice->alsa.pPollDescriptorsPlayback, pDevice->alsa.pollDescriptorCountPlayback + 1, POLLOUT); /* +1 to account for the wakeup descriptor. */ -} - -static ma_result ma_device_read__alsa(ma_device* pDevice, void* pFramesOut, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - ma_snd_pcm_sframes_t resultALSA = 0; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pFramesOut != NULL); - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - while (ma_device_get_state(pDevice) == ma_device_state_started) { - ma_result result; - - /* The first thing to do is wait for data to become available for reading. This will return an error code if the device has been stopped. */ - result = ma_device_wait_read__alsa(pDevice); - if (result != MA_SUCCESS) { - return result; - } - - /* Getting here means we should have data available. */ - resultALSA = ((ma_snd_pcm_readi_proc)pDevice->pContext->alsa.snd_pcm_readi)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture, pFramesOut, frameCount); - if (resultALSA >= 0) { - break; /* Success. */ - } else { - if (resultALSA == -EAGAIN) { - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "EGAIN (read)\n");*/ - continue; /* Try again. */ - } else if (resultALSA == -EPIPE) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "EPIPE (read)\n"); - - /* Overrun. Recover and try again. If this fails we need to return an error. */ - resultALSA = ((ma_snd_pcm_recover_proc)pDevice->pContext->alsa.snd_pcm_recover)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture, resultALSA, MA_TRUE); - if (resultALSA < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to recover device after overrun."); - return ma_result_from_errno((int)-resultALSA); - } - - resultALSA = ((ma_snd_pcm_start_proc)pDevice->pContext->alsa.snd_pcm_start)((ma_snd_pcm_t*)pDevice->alsa.pPCMCapture); - if (resultALSA < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to start device after underrun."); - return ma_result_from_errno((int)-resultALSA); - } - - continue; /* Try reading again. */ - } - } - } - - if (pFramesRead != NULL) { - *pFramesRead = resultALSA; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_write__alsa(ma_device* pDevice, const void* pFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - ma_snd_pcm_sframes_t resultALSA = 0; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pFrames != NULL); - - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - while (ma_device_get_state(pDevice) == ma_device_state_started) { - ma_result result; - - /* The first thing to do is wait for space to become available for writing. This will return an error code if the device has been stopped. */ - result = ma_device_wait_write__alsa(pDevice); - if (result != MA_SUCCESS) { - return result; - } - - resultALSA = ((ma_snd_pcm_writei_proc)pDevice->pContext->alsa.snd_pcm_writei)((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback, pFrames, frameCount); - if (resultALSA >= 0) { - break; /* Success. */ - } else { - if (resultALSA == -EAGAIN) { - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "EGAIN (write)\n");*/ - continue; /* Try again. */ - } else if (resultALSA == -EPIPE) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "EPIPE (write)\n"); - - /* Underrun. Recover and try again. If this fails we need to return an error. */ - resultALSA = ((ma_snd_pcm_recover_proc)pDevice->pContext->alsa.snd_pcm_recover)((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback, resultALSA, MA_TRUE); /* MA_TRUE=silent (don't print anything on error). */ - if (resultALSA < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to recover device after underrun."); - return ma_result_from_errno((int)-resultALSA); - } - - /* - In my testing I have had a situation where writei() does not automatically restart the device even though I've set it - up as such in the software parameters. What will happen is writei() will block indefinitely even though the number of - frames is well beyond the auto-start threshold. To work around this I've needed to add an explicit start here. Not sure - if this is me just being stupid and not recovering the device properly, but this definitely feels like something isn't - quite right here. - */ - resultALSA = ((ma_snd_pcm_start_proc)pDevice->pContext->alsa.snd_pcm_start)((ma_snd_pcm_t*)pDevice->alsa.pPCMPlayback); - if (resultALSA < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] Failed to start device after underrun."); - return ma_result_from_errno((int)-resultALSA); - } - - continue; /* Try writing again. */ - } - } - } - - if (pFramesWritten != NULL) { - *pFramesWritten = resultALSA; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_data_loop_wakeup__alsa(ma_device* pDevice) -{ - ma_uint64 t = 1; - int resultWrite = 0; - - MA_ASSERT(pDevice != NULL); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Waking up...\n"); - - /* Write to an eventfd to trigger a wakeup from poll() and abort any reading or writing. */ - if (pDevice->alsa.pPollDescriptorsCapture != NULL) { - resultWrite = write(pDevice->alsa.wakeupfdCapture, &t, sizeof(t)); - } - if (pDevice->alsa.pPollDescriptorsPlayback != NULL) { - resultWrite = write(pDevice->alsa.wakeupfdPlayback, &t, sizeof(t)); - } - - if (resultWrite < 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[ALSA] write() failed.\n"); - return ma_result_from_errno(errno); - } - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[ALSA] Waking up completed successfully.\n"); - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__alsa(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_alsa); - - /* Clean up memory for memory leak checkers. */ - ((ma_snd_config_update_free_global_proc)pContext->alsa.snd_config_update_free_global)(); - -#ifndef MA_NO_RUNTIME_LINKING - ma_dlclose(pContext, pContext->alsa.asoundSO); -#endif - - ma_mutex_uninit(&pContext->alsa.internalDeviceEnumLock); - - return MA_SUCCESS; -} - -static ma_result ma_context_init__alsa(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - ma_result result; -#ifndef MA_NO_RUNTIME_LINKING - const char* libasoundNames[] = { - "libasound.so.2", - "libasound.so" - }; - size_t i; - - for (i = 0; i < ma_countof(libasoundNames); ++i) { - pContext->alsa.asoundSO = ma_dlopen(pContext, libasoundNames[i]); - if (pContext->alsa.asoundSO != NULL) { - break; - } - } - - if (pContext->alsa.asoundSO == NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "[ALSA] Failed to open shared object.\n"); - return MA_NO_BACKEND; - } - - pContext->alsa.snd_pcm_open = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_open"); - pContext->alsa.snd_pcm_close = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_close"); - pContext->alsa.snd_pcm_hw_params_sizeof = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_sizeof"); - pContext->alsa.snd_pcm_hw_params_any = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_any"); - pContext->alsa.snd_pcm_hw_params_set_format = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_format"); - pContext->alsa.snd_pcm_hw_params_set_format_first = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_format_first"); - pContext->alsa.snd_pcm_hw_params_get_format_mask = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_format_mask"); - pContext->alsa.snd_pcm_hw_params_set_channels = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_channels"); - pContext->alsa.snd_pcm_hw_params_set_channels_near = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_channels_near"); - pContext->alsa.snd_pcm_hw_params_set_channels_minmax = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_channels_minmax"); - pContext->alsa.snd_pcm_hw_params_set_rate_resample = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_rate_resample"); - pContext->alsa.snd_pcm_hw_params_set_rate = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_rate"); - pContext->alsa.snd_pcm_hw_params_set_rate_near = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_rate_near"); - pContext->alsa.snd_pcm_hw_params_set_buffer_size_near = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_buffer_size_near"); - pContext->alsa.snd_pcm_hw_params_set_periods_near = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_periods_near"); - pContext->alsa.snd_pcm_hw_params_set_access = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_set_access"); - pContext->alsa.snd_pcm_hw_params_get_format = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_format"); - pContext->alsa.snd_pcm_hw_params_get_channels = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_channels"); - pContext->alsa.snd_pcm_hw_params_get_channels_min = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_channels_min"); - pContext->alsa.snd_pcm_hw_params_get_channels_max = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_channels_max"); - pContext->alsa.snd_pcm_hw_params_get_rate = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_rate"); - pContext->alsa.snd_pcm_hw_params_get_rate_min = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_rate_min"); - pContext->alsa.snd_pcm_hw_params_get_rate_max = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_rate_max"); - pContext->alsa.snd_pcm_hw_params_get_buffer_size = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_buffer_size"); - pContext->alsa.snd_pcm_hw_params_get_periods = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_periods"); - pContext->alsa.snd_pcm_hw_params_get_access = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_get_access"); - pContext->alsa.snd_pcm_hw_params_test_format = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_test_format"); - pContext->alsa.snd_pcm_hw_params_test_channels = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_test_channels"); - pContext->alsa.snd_pcm_hw_params_test_rate = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params_test_rate"); - pContext->alsa.snd_pcm_hw_params = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_hw_params"); - pContext->alsa.snd_pcm_sw_params_sizeof = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params_sizeof"); - pContext->alsa.snd_pcm_sw_params_current = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params_current"); - pContext->alsa.snd_pcm_sw_params_get_boundary = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params_get_boundary"); - pContext->alsa.snd_pcm_sw_params_set_avail_min = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params_set_avail_min"); - pContext->alsa.snd_pcm_sw_params_set_start_threshold = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params_set_start_threshold"); - pContext->alsa.snd_pcm_sw_params_set_stop_threshold = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params_set_stop_threshold"); - pContext->alsa.snd_pcm_sw_params = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_sw_params"); - pContext->alsa.snd_pcm_format_mask_sizeof = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_format_mask_sizeof"); - pContext->alsa.snd_pcm_format_mask_test = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_format_mask_test"); - pContext->alsa.snd_pcm_get_chmap = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_get_chmap"); - pContext->alsa.snd_pcm_state = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_state"); - pContext->alsa.snd_pcm_prepare = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_prepare"); - pContext->alsa.snd_pcm_start = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_start"); - pContext->alsa.snd_pcm_drop = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_drop"); - pContext->alsa.snd_pcm_drain = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_drain"); - pContext->alsa.snd_pcm_reset = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_reset"); - pContext->alsa.snd_device_name_hint = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_device_name_hint"); - pContext->alsa.snd_device_name_get_hint = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_device_name_get_hint"); - pContext->alsa.snd_card_get_index = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_card_get_index"); - pContext->alsa.snd_device_name_free_hint = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_device_name_free_hint"); - pContext->alsa.snd_pcm_mmap_begin = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_mmap_begin"); - pContext->alsa.snd_pcm_mmap_commit = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_mmap_commit"); - pContext->alsa.snd_pcm_recover = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_recover"); - pContext->alsa.snd_pcm_readi = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_readi"); - pContext->alsa.snd_pcm_writei = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_writei"); - pContext->alsa.snd_pcm_avail = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_avail"); - pContext->alsa.snd_pcm_avail_update = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_avail_update"); - pContext->alsa.snd_pcm_wait = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_wait"); - pContext->alsa.snd_pcm_nonblock = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_nonblock"); - pContext->alsa.snd_pcm_info = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_info"); - pContext->alsa.snd_pcm_info_sizeof = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_info_sizeof"); - pContext->alsa.snd_pcm_info_get_name = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_info_get_name"); - pContext->alsa.snd_pcm_poll_descriptors = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_poll_descriptors"); - pContext->alsa.snd_pcm_poll_descriptors_count = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_poll_descriptors_count"); - pContext->alsa.snd_pcm_poll_descriptors_revents = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_pcm_poll_descriptors_revents"); - pContext->alsa.snd_config_update_free_global = (ma_proc)ma_dlsym(pContext, pContext->alsa.asoundSO, "snd_config_update_free_global"); -#else - /* The system below is just for type safety. */ - ma_snd_pcm_open_proc _snd_pcm_open = snd_pcm_open; - ma_snd_pcm_close_proc _snd_pcm_close = snd_pcm_close; - ma_snd_pcm_hw_params_sizeof_proc _snd_pcm_hw_params_sizeof = snd_pcm_hw_params_sizeof; - ma_snd_pcm_hw_params_any_proc _snd_pcm_hw_params_any = snd_pcm_hw_params_any; - ma_snd_pcm_hw_params_set_format_proc _snd_pcm_hw_params_set_format = snd_pcm_hw_params_set_format; - ma_snd_pcm_hw_params_set_format_first_proc _snd_pcm_hw_params_set_format_first = snd_pcm_hw_params_set_format_first; - ma_snd_pcm_hw_params_get_format_mask_proc _snd_pcm_hw_params_get_format_mask = snd_pcm_hw_params_get_format_mask; - ma_snd_pcm_hw_params_set_channels_proc _snd_pcm_hw_params_set_channels = snd_pcm_hw_params_set_channels; - ma_snd_pcm_hw_params_set_channels_near_proc _snd_pcm_hw_params_set_channels_near = snd_pcm_hw_params_set_channels_near; - ma_snd_pcm_hw_params_set_rate_resample_proc _snd_pcm_hw_params_set_rate_resample = snd_pcm_hw_params_set_rate_resample; - ma_snd_pcm_hw_params_set_rate_near _snd_pcm_hw_params_set_rate = snd_pcm_hw_params_set_rate; - ma_snd_pcm_hw_params_set_rate_near_proc _snd_pcm_hw_params_set_rate_near = snd_pcm_hw_params_set_rate_near; - ma_snd_pcm_hw_params_set_rate_minmax_proc _snd_pcm_hw_params_set_rate_minmax = snd_pcm_hw_params_set_rate_minmax; - ma_snd_pcm_hw_params_set_buffer_size_near_proc _snd_pcm_hw_params_set_buffer_size_near = snd_pcm_hw_params_set_buffer_size_near; - ma_snd_pcm_hw_params_set_periods_near_proc _snd_pcm_hw_params_set_periods_near = snd_pcm_hw_params_set_periods_near; - ma_snd_pcm_hw_params_set_access_proc _snd_pcm_hw_params_set_access = snd_pcm_hw_params_set_access; - ma_snd_pcm_hw_params_get_format_proc _snd_pcm_hw_params_get_format = snd_pcm_hw_params_get_format; - ma_snd_pcm_hw_params_get_channels_proc _snd_pcm_hw_params_get_channels = snd_pcm_hw_params_get_channels; - ma_snd_pcm_hw_params_get_channels_min_proc _snd_pcm_hw_params_get_channels_min = snd_pcm_hw_params_get_channels_min; - ma_snd_pcm_hw_params_get_channels_max_proc _snd_pcm_hw_params_get_channels_max = snd_pcm_hw_params_get_channels_max; - ma_snd_pcm_hw_params_get_rate_proc _snd_pcm_hw_params_get_rate = snd_pcm_hw_params_get_rate; - ma_snd_pcm_hw_params_get_rate_min_proc _snd_pcm_hw_params_get_rate_min = snd_pcm_hw_params_get_rate_min; - ma_snd_pcm_hw_params_get_rate_max_proc _snd_pcm_hw_params_get_rate_max = snd_pcm_hw_params_get_rate_max; - ma_snd_pcm_hw_params_get_buffer_size_proc _snd_pcm_hw_params_get_buffer_size = snd_pcm_hw_params_get_buffer_size; - ma_snd_pcm_hw_params_get_periods_proc _snd_pcm_hw_params_get_periods = snd_pcm_hw_params_get_periods; - ma_snd_pcm_hw_params_get_access_proc _snd_pcm_hw_params_get_access = snd_pcm_hw_params_get_access; - ma_snd_pcm_hw_params_test_format_proc _snd_pcm_hw_params_test_format = snd_pcm_hw_params_test_format; - ma_snd_pcm_hw_params_test_channels_proc _snd_pcm_hw_params_test_channels = snd_pcm_hw_params_test_channels; - ma_snd_pcm_hw_params_test_rate_proc _snd_pcm_hw_params_test_rate = snd_pcm_hw_params_test_rate; - ma_snd_pcm_hw_params_proc _snd_pcm_hw_params = snd_pcm_hw_params; - ma_snd_pcm_sw_params_sizeof_proc _snd_pcm_sw_params_sizeof = snd_pcm_sw_params_sizeof; - ma_snd_pcm_sw_params_current_proc _snd_pcm_sw_params_current = snd_pcm_sw_params_current; - ma_snd_pcm_sw_params_get_boundary_proc _snd_pcm_sw_params_get_boundary = snd_pcm_sw_params_get_boundary; - ma_snd_pcm_sw_params_set_avail_min_proc _snd_pcm_sw_params_set_avail_min = snd_pcm_sw_params_set_avail_min; - ma_snd_pcm_sw_params_set_start_threshold_proc _snd_pcm_sw_params_set_start_threshold = snd_pcm_sw_params_set_start_threshold; - ma_snd_pcm_sw_params_set_stop_threshold_proc _snd_pcm_sw_params_set_stop_threshold = snd_pcm_sw_params_set_stop_threshold; - ma_snd_pcm_sw_params_proc _snd_pcm_sw_params = snd_pcm_sw_params; - ma_snd_pcm_format_mask_sizeof_proc _snd_pcm_format_mask_sizeof = snd_pcm_format_mask_sizeof; - ma_snd_pcm_format_mask_test_proc _snd_pcm_format_mask_test = snd_pcm_format_mask_test; - ma_snd_pcm_get_chmap_proc _snd_pcm_get_chmap = snd_pcm_get_chmap; - ma_snd_pcm_state_proc _snd_pcm_state = snd_pcm_state; - ma_snd_pcm_prepare_proc _snd_pcm_prepare = snd_pcm_prepare; - ma_snd_pcm_start_proc _snd_pcm_start = snd_pcm_start; - ma_snd_pcm_drop_proc _snd_pcm_drop = snd_pcm_drop; - ma_snd_pcm_drain_proc _snd_pcm_drain = snd_pcm_drain; - ma_snd_pcm_reset_proc _snd_pcm_reset = snd_pcm_reset; - ma_snd_device_name_hint_proc _snd_device_name_hint = snd_device_name_hint; - ma_snd_device_name_get_hint_proc _snd_device_name_get_hint = snd_device_name_get_hint; - ma_snd_card_get_index_proc _snd_card_get_index = snd_card_get_index; - ma_snd_device_name_free_hint_proc _snd_device_name_free_hint = snd_device_name_free_hint; - ma_snd_pcm_mmap_begin_proc _snd_pcm_mmap_begin = snd_pcm_mmap_begin; - ma_snd_pcm_mmap_commit_proc _snd_pcm_mmap_commit = snd_pcm_mmap_commit; - ma_snd_pcm_recover_proc _snd_pcm_recover = snd_pcm_recover; - ma_snd_pcm_readi_proc _snd_pcm_readi = snd_pcm_readi; - ma_snd_pcm_writei_proc _snd_pcm_writei = snd_pcm_writei; - ma_snd_pcm_avail_proc _snd_pcm_avail = snd_pcm_avail; - ma_snd_pcm_avail_update_proc _snd_pcm_avail_update = snd_pcm_avail_update; - ma_snd_pcm_wait_proc _snd_pcm_wait = snd_pcm_wait; - ma_snd_pcm_nonblock_proc _snd_pcm_nonblock = snd_pcm_nonblock; - ma_snd_pcm_info_proc _snd_pcm_info = snd_pcm_info; - ma_snd_pcm_info_sizeof_proc _snd_pcm_info_sizeof = snd_pcm_info_sizeof; - ma_snd_pcm_info_get_name_proc _snd_pcm_info_get_name = snd_pcm_info_get_name; - ma_snd_pcm_poll_descriptors _snd_pcm_poll_descriptors = snd_pcm_poll_descriptors; - ma_snd_pcm_poll_descriptors_count _snd_pcm_poll_descriptors_count = snd_pcm_poll_descriptors_count; - ma_snd_pcm_poll_descriptors_revents _snd_pcm_poll_descriptors_revents = snd_pcm_poll_descriptors_revents; - ma_snd_config_update_free_global_proc _snd_config_update_free_global = snd_config_update_free_global; - - pContext->alsa.snd_pcm_open = (ma_proc)_snd_pcm_open; - pContext->alsa.snd_pcm_close = (ma_proc)_snd_pcm_close; - pContext->alsa.snd_pcm_hw_params_sizeof = (ma_proc)_snd_pcm_hw_params_sizeof; - pContext->alsa.snd_pcm_hw_params_any = (ma_proc)_snd_pcm_hw_params_any; - pContext->alsa.snd_pcm_hw_params_set_format = (ma_proc)_snd_pcm_hw_params_set_format; - pContext->alsa.snd_pcm_hw_params_set_format_first = (ma_proc)_snd_pcm_hw_params_set_format_first; - pContext->alsa.snd_pcm_hw_params_get_format_mask = (ma_proc)_snd_pcm_hw_params_get_format_mask; - pContext->alsa.snd_pcm_hw_params_set_channels = (ma_proc)_snd_pcm_hw_params_set_channels; - pContext->alsa.snd_pcm_hw_params_set_channels_near = (ma_proc)_snd_pcm_hw_params_set_channels_near; - pContext->alsa.snd_pcm_hw_params_set_channels_minmax = (ma_proc)_snd_pcm_hw_params_set_channels_minmax; - pContext->alsa.snd_pcm_hw_params_set_rate_resample = (ma_proc)_snd_pcm_hw_params_set_rate_resample; - pContext->alsa.snd_pcm_hw_params_set_rate = (ma_proc)_snd_pcm_hw_params_set_rate; - pContext->alsa.snd_pcm_hw_params_set_rate_near = (ma_proc)_snd_pcm_hw_params_set_rate_near; - pContext->alsa.snd_pcm_hw_params_set_buffer_size_near = (ma_proc)_snd_pcm_hw_params_set_buffer_size_near; - pContext->alsa.snd_pcm_hw_params_set_periods_near = (ma_proc)_snd_pcm_hw_params_set_periods_near; - pContext->alsa.snd_pcm_hw_params_set_access = (ma_proc)_snd_pcm_hw_params_set_access; - pContext->alsa.snd_pcm_hw_params_get_format = (ma_proc)_snd_pcm_hw_params_get_format; - pContext->alsa.snd_pcm_hw_params_get_channels = (ma_proc)_snd_pcm_hw_params_get_channels; - pContext->alsa.snd_pcm_hw_params_get_channels_min = (ma_proc)_snd_pcm_hw_params_get_channels_min; - pContext->alsa.snd_pcm_hw_params_get_channels_max = (ma_proc)_snd_pcm_hw_params_get_channels_max; - pContext->alsa.snd_pcm_hw_params_get_rate = (ma_proc)_snd_pcm_hw_params_get_rate; - pContext->alsa.snd_pcm_hw_params_get_rate_min = (ma_proc)_snd_pcm_hw_params_get_rate_min; - pContext->alsa.snd_pcm_hw_params_get_rate_max = (ma_proc)_snd_pcm_hw_params_get_rate_max; - pContext->alsa.snd_pcm_hw_params_get_buffer_size = (ma_proc)_snd_pcm_hw_params_get_buffer_size; - pContext->alsa.snd_pcm_hw_params_get_periods = (ma_proc)_snd_pcm_hw_params_get_periods; - pContext->alsa.snd_pcm_hw_params_get_access = (ma_proc)_snd_pcm_hw_params_get_access; - pContext->alsa.snd_pcm_hw_params_test_format = (ma_proc)_snd_pcm_hw_params_test_format; - pContext->alsa.snd_pcm_hw_params_test_channels = (ma_proc)_snd_pcm_hw_params_test_channels; - pContext->alsa.snd_pcm_hw_params_test_rate = (ma_proc)_snd_pcm_hw_params_test_rate; - pContext->alsa.snd_pcm_hw_params = (ma_proc)_snd_pcm_hw_params; - pContext->alsa.snd_pcm_sw_params_sizeof = (ma_proc)_snd_pcm_sw_params_sizeof; - pContext->alsa.snd_pcm_sw_params_current = (ma_proc)_snd_pcm_sw_params_current; - pContext->alsa.snd_pcm_sw_params_get_boundary = (ma_proc)_snd_pcm_sw_params_get_boundary; - pContext->alsa.snd_pcm_sw_params_set_avail_min = (ma_proc)_snd_pcm_sw_params_set_avail_min; - pContext->alsa.snd_pcm_sw_params_set_start_threshold = (ma_proc)_snd_pcm_sw_params_set_start_threshold; - pContext->alsa.snd_pcm_sw_params_set_stop_threshold = (ma_proc)_snd_pcm_sw_params_set_stop_threshold; - pContext->alsa.snd_pcm_sw_params = (ma_proc)_snd_pcm_sw_params; - pContext->alsa.snd_pcm_format_mask_sizeof = (ma_proc)_snd_pcm_format_mask_sizeof; - pContext->alsa.snd_pcm_format_mask_test = (ma_proc)_snd_pcm_format_mask_test; - pContext->alsa.snd_pcm_get_chmap = (ma_proc)_snd_pcm_get_chmap; - pContext->alsa.snd_pcm_state = (ma_proc)_snd_pcm_state; - pContext->alsa.snd_pcm_prepare = (ma_proc)_snd_pcm_prepare; - pContext->alsa.snd_pcm_start = (ma_proc)_snd_pcm_start; - pContext->alsa.snd_pcm_drop = (ma_proc)_snd_pcm_drop; - pContext->alsa.snd_pcm_drain = (ma_proc)_snd_pcm_drain; - pContext->alsa.snd_pcm_reset = (ma_proc)_snd_pcm_reset; - pContext->alsa.snd_device_name_hint = (ma_proc)_snd_device_name_hint; - pContext->alsa.snd_device_name_get_hint = (ma_proc)_snd_device_name_get_hint; - pContext->alsa.snd_card_get_index = (ma_proc)_snd_card_get_index; - pContext->alsa.snd_device_name_free_hint = (ma_proc)_snd_device_name_free_hint; - pContext->alsa.snd_pcm_mmap_begin = (ma_proc)_snd_pcm_mmap_begin; - pContext->alsa.snd_pcm_mmap_commit = (ma_proc)_snd_pcm_mmap_commit; - pContext->alsa.snd_pcm_recover = (ma_proc)_snd_pcm_recover; - pContext->alsa.snd_pcm_readi = (ma_proc)_snd_pcm_readi; - pContext->alsa.snd_pcm_writei = (ma_proc)_snd_pcm_writei; - pContext->alsa.snd_pcm_avail = (ma_proc)_snd_pcm_avail; - pContext->alsa.snd_pcm_avail_update = (ma_proc)_snd_pcm_avail_update; - pContext->alsa.snd_pcm_wait = (ma_proc)_snd_pcm_wait; - pContext->alsa.snd_pcm_nonblock = (ma_proc)_snd_pcm_nonblock; - pContext->alsa.snd_pcm_info = (ma_proc)_snd_pcm_info; - pContext->alsa.snd_pcm_info_sizeof = (ma_proc)_snd_pcm_info_sizeof; - pContext->alsa.snd_pcm_info_get_name = (ma_proc)_snd_pcm_info_get_name; - pContext->alsa.snd_pcm_poll_descriptors = (ma_proc)_snd_pcm_poll_descriptors; - pContext->alsa.snd_pcm_poll_descriptors_count = (ma_proc)_snd_pcm_poll_descriptors_count; - pContext->alsa.snd_pcm_poll_descriptors_revents = (ma_proc)_snd_pcm_poll_descriptors_revents; - pContext->alsa.snd_config_update_free_global = (ma_proc)_snd_config_update_free_global; -#endif - - pContext->alsa.useVerboseDeviceEnumeration = pConfig->alsa.useVerboseDeviceEnumeration; - - result = ma_mutex_init(&pContext->alsa.internalDeviceEnumLock); - if (result != MA_SUCCESS) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[ALSA] WARNING: Failed to initialize mutex for internal device enumeration."); - return result; - } - - pCallbacks->onContextInit = ma_context_init__alsa; - pCallbacks->onContextUninit = ma_context_uninit__alsa; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__alsa; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__alsa; - pCallbacks->onDeviceInit = ma_device_init__alsa; - pCallbacks->onDeviceUninit = ma_device_uninit__alsa; - pCallbacks->onDeviceStart = ma_device_start__alsa; - pCallbacks->onDeviceStop = ma_device_stop__alsa; - pCallbacks->onDeviceRead = ma_device_read__alsa; - pCallbacks->onDeviceWrite = ma_device_write__alsa; - pCallbacks->onDeviceDataLoop = NULL; - pCallbacks->onDeviceDataLoopWakeup = ma_device_data_loop_wakeup__alsa; - - return MA_SUCCESS; -} -#endif /* ALSA */ - - - -/****************************************************************************** - -PulseAudio Backend - -******************************************************************************/ -#ifdef MA_HAS_PULSEAUDIO -/* -The PulseAudio API, along with Apple's Core Audio, is the worst of the maintream audio APIs. This is a brief description of what's going on -in the PulseAudio backend. I apologize if this gets a bit ranty for your liking - you might want to skip this discussion. - -PulseAudio has something they call the "Simple API", which unfortunately isn't suitable for miniaudio. I've not seen anywhere where it -allows you to enumerate over devices, nor does it seem to support the ability to stop and start streams. Looking at the documentation, it -appears as though the stream is constantly running and you prevent sound from being emitted or captured by simply not calling the read or -write functions. This is not a professional solution as it would be much better to *actually* stop the underlying stream. Perhaps the -simple API has some smarts to do this automatically, but I'm not sure. Another limitation with the simple API is that it seems inefficient -when you want to have multiple streams to a single context. For these reasons, miniaudio is not using the simple API. - -Since we're not using the simple API, we're left with the asynchronous API as our only other option. And boy, is this where it starts to -get fun, and I don't mean that in a good way... - -The problems start with the very name of the API - "asynchronous". Yes, this is an asynchronous oriented API which means your commands -don't immediately take effect. You instead need to issue your commands, and then wait for them to complete. The waiting mechanism is -enabled through the use of a "main loop". In the asychronous API you cannot get away from the main loop, and the main loop is where almost -all of PulseAudio's problems stem from. - -When you first initialize PulseAudio you need an object referred to as "main loop". You can implement this yourself by defining your own -vtable, but it's much easier to just use one of the built-in main loop implementations. There's two generic implementations called -pa_mainloop and pa_threaded_mainloop, and another implementation specific to GLib called pa_glib_mainloop. We're using pa_threaded_mainloop -because it simplifies management of the worker thread. The idea of the main loop object is pretty self explanatory - you're supposed to use -it to implement a worker thread which runs in a loop. The main loop is where operations are actually executed. - -To initialize the main loop, you just use `pa_threaded_mainloop_new()`. This is the first function you'll call. You can then get a pointer -to the vtable with `pa_threaded_mainloop_get_api()` (the main loop vtable is called `pa_mainloop_api`). Again, you can bypass the threaded -main loop object entirely and just implement `pa_mainloop_api` directly, but there's no need for it unless you're doing something extremely -specialized such as if you want to integrate it into your application's existing main loop infrastructure. - -(EDIT 2021-01-26: miniaudio is no longer using `pa_threaded_mainloop` due to this issue: https://github.com/mackron/miniaudio/issues/262. -It is now using `pa_mainloop` which turns out to be a simpler solution anyway. The rest of this rant still applies, however.) - -Once you have your main loop vtable (the `pa_mainloop_api` object) you can create the PulseAudio context. This is very similar to -miniaudio's context and they map to each other quite well. You have one context to many streams, which is basically the same as miniaudio's -one `ma_context` to many `ma_device`s. Here's where it starts to get annoying, however. When you first create the PulseAudio context, which -is done with `pa_context_new()`, it's not actually connected to anything. When you connect, you call `pa_context_connect()`. However, if -you remember, PulseAudio is an asynchronous API. That means you cannot just assume the context is connected after `pa_context_context()` -has returned. You instead need to wait for it to connect. To do this, you need to either wait for a callback to get fired, which you can -set with `pa_context_set_state_callback()`, or you can continuously poll the context's state. Either way, you need to run this in a loop. -All objects from here out are created from the context, and, I believe, you can't be creating these objects until the context is connected. -This waiting loop is therefore unavoidable. In order for the waiting to ever complete, however, the main loop needs to be running. Before -attempting to connect the context, the main loop needs to be started with `pa_threaded_mainloop_start()`. - -The reason for this asynchronous design is to support cases where you're connecting to a remote server, say through a local network or an -internet connection. However, the *VAST* majority of cases don't involve this at all - they just connect to a local "server" running on the -host machine. The fact that this would be the default rather than making `pa_context_connect()` synchronous tends to boggle the mind. - -Once the context has been created and connected you can start creating a stream. A PulseAudio stream is analogous to miniaudio's device. -The initialization of a stream is fairly standard - you configure some attributes (analogous to miniaudio's device config) and then call -`pa_stream_new()` to actually create it. Here is where we start to get into "operations". When configuring the stream, you can get -information about the source (such as sample format, sample rate, etc.), however it's not synchronous. Instead, a `pa_operation` object -is returned from `pa_context_get_source_info_by_name()` (capture) or `pa_context_get_sink_info_by_name()` (playback). Then, you need to -run a loop (again!) to wait for the operation to complete which you can determine via a callback or polling, just like we did with the -context. Then, as an added bonus, you need to decrement the reference counter of the `pa_operation` object to ensure memory is cleaned up. -All of that just to retrieve basic information about a device! - -Once the basic information about the device has been retrieved, miniaudio can now create the stream with `ma_stream_new()`. Like the -context, this needs to be connected. But we need to be careful here, because we're now about to introduce one of the most horrific design -choices in PulseAudio. - -PulseAudio allows you to specify a callback that is fired when data can be written to or read from a stream. The language is important here -because PulseAudio takes it literally, specifically the "can be". You would think these callbacks would be appropriate as the place for -writing and reading data to and from the stream, and that would be right, except when it's not. When you initialize the stream, you can -set a flag that tells PulseAudio to not start the stream automatically. This is required because miniaudio does not auto-start devices -straight after initialization - you need to call `ma_device_start()` manually. The problem is that even when this flag is specified, -PulseAudio will immediately fire it's write or read callback. This is *technically* correct (based on the wording in the documentation) -because indeed, data *can* be written at this point. The problem is that it's not *practical*. It makes sense that the write/read callback -would be where a program will want to write or read data to or from the stream, but when it's called before the application has even -requested that the stream be started, it's just not practical because the program probably isn't ready for any kind of data delivery at -that point (it may still need to load files or whatnot). Instead, this callback should only be fired when the application requests the -stream be started which is how it works with literally *every* other callback-based audio API. Since miniaudio forbids firing of the data -callback until the device has been started (as it should be with *all* callback based APIs), logic needs to be added to ensure miniaudio -doesn't just blindly fire the application-defined data callback from within the PulseAudio callback before the stream has actually been -started. The device state is used for this - if the state is anything other than `ma_device_state_starting` or `ma_device_state_started`, the main data -callback is not fired. - -This, unfortunately, is not the end of the problems with the PulseAudio write callback. Any normal callback based audio API will -continuously fire the callback at regular intervals based on the size of the internal buffer. This will only ever be fired when the device -is running, and will be fired regardless of whether or not the user actually wrote anything to the device/stream. This not the case in -PulseAudio. In PulseAudio, the data callback will *only* be called if you wrote something to it previously. That means, if you don't call -`pa_stream_write()`, the callback will not get fired. On the surface you wouldn't think this would matter because you should be always -writing data, and if you don't have anything to write, just write silence. That's fine until you want to drain the stream. You see, if -you're continuously writing data to the stream, the stream will never get drained! That means in order to drain the stream, you need to -*not* write data to it! But remember, when you don't write data to the stream, the callback won't get fired again! Why is draining -important? Because that's how we've defined stopping to work in miniaudio. In miniaudio, stopping the device requires it to be drained -before returning from ma_device_stop(). So we've stopped the device, which requires us to drain, but draining requires us to *not* write -data to the stream (or else it won't ever complete draining), but not writing to the stream means the callback won't get fired again! - -This becomes a problem when stopping and then restarting the device. When the device is stopped, it's drained, which requires us to *not* -write anything to the stream. But then, since we didn't write anything to it, the write callback will *never* get called again if we just -resume the stream naively. This means that starting the stream requires us to write data to the stream from outside the callback. This -disconnect is something PulseAudio has got seriously wrong - there should only ever be a single source of data delivery, that being the -callback. (I have tried using `pa_stream_flush()` to trigger the write callback to fire, but this just doesn't work for some reason.) - -Once you've created the stream, you need to connect it which involves the whole waiting procedure. This is the same process as the context, -only this time you'll poll for the state with `pa_stream_get_status()`. The starting and stopping of a streaming is referred to as -"corking" in PulseAudio. The analogy is corking a barrel. To start the stream, you uncork it, to stop it you cork it. Personally I think -it's silly - why would you not just call it "starting" and "stopping" like any other normal audio API? Anyway, the act of corking is, you -guessed it, asynchronous. This means you'll need our waiting loop as usual. Again, why this asynchronous design is the default is -absolutely beyond me. Would it really be that hard to just make it run synchronously? - -Teardown is pretty simple (what?!). It's just a matter of calling the relevant `_unref()` function on each object in reverse order that -they were initialized in. - -That's about it from the PulseAudio side. A bit ranty, I know, but they really need to fix that main loop and callback system. They're -embarrassingly unpractical. The main loop thing is an easy fix - have synchronous versions of all APIs. If an application wants these to -run asynchronously, they can execute them in a separate thread themselves. The desire to run these asynchronously is such a niche -requirement - it makes no sense to make it the default. The stream write callback needs to be change, or an alternative provided, that is -constantly fired, regardless of whether or not `pa_stream_write()` has been called, and it needs to take a pointer to a buffer as a -parameter which the program just writes to directly rather than having to call `pa_stream_writable_size()` and `pa_stream_write()`. These -changes alone will change PulseAudio from one of the worst audio APIs to one of the best. -*/ - - -/* -It is assumed pulseaudio.h is available when linking at compile time. When linking at compile time, we use the declarations in the header -to check for type safety. We cannot do this when linking at run time because the header might not be available. -*/ -#ifdef MA_NO_RUNTIME_LINKING - -/* pulseaudio.h marks some functions with "inline" which isn't always supported. Need to emulate it. */ -#if !defined(__cplusplus) - #if defined(__STRICT_ANSI__) - #if !defined(inline) - #define inline __inline__ __attribute__((always_inline)) - #define MA_INLINE_DEFINED - #endif - #endif -#endif -#include -#if defined(MA_INLINE_DEFINED) - #undef inline - #undef MA_INLINE_DEFINED -#endif - -#define MA_PA_OK PA_OK -#define MA_PA_ERR_ACCESS PA_ERR_ACCESS -#define MA_PA_ERR_INVALID PA_ERR_INVALID -#define MA_PA_ERR_NOENTITY PA_ERR_NOENTITY -#define MA_PA_ERR_NOTSUPPORTED PA_ERR_NOTSUPPORTED - -#define MA_PA_CHANNELS_MAX PA_CHANNELS_MAX -#define MA_PA_RATE_MAX PA_RATE_MAX - -typedef pa_context_flags_t ma_pa_context_flags_t; -#define MA_PA_CONTEXT_NOFLAGS PA_CONTEXT_NOFLAGS -#define MA_PA_CONTEXT_NOAUTOSPAWN PA_CONTEXT_NOAUTOSPAWN -#define MA_PA_CONTEXT_NOFAIL PA_CONTEXT_NOFAIL - -typedef pa_stream_flags_t ma_pa_stream_flags_t; -#define MA_PA_STREAM_NOFLAGS PA_STREAM_NOFLAGS -#define MA_PA_STREAM_START_CORKED PA_STREAM_START_CORKED -#define MA_PA_STREAM_INTERPOLATE_TIMING PA_STREAM_INTERPOLATE_TIMING -#define MA_PA_STREAM_NOT_MONOTONIC PA_STREAM_NOT_MONOTONIC -#define MA_PA_STREAM_AUTO_TIMING_UPDATE PA_STREAM_AUTO_TIMING_UPDATE -#define MA_PA_STREAM_NO_REMAP_CHANNELS PA_STREAM_NO_REMAP_CHANNELS -#define MA_PA_STREAM_NO_REMIX_CHANNELS PA_STREAM_NO_REMIX_CHANNELS -#define MA_PA_STREAM_FIX_FORMAT PA_STREAM_FIX_FORMAT -#define MA_PA_STREAM_FIX_RATE PA_STREAM_FIX_RATE -#define MA_PA_STREAM_FIX_CHANNELS PA_STREAM_FIX_CHANNELS -#define MA_PA_STREAM_DONT_MOVE PA_STREAM_DONT_MOVE -#define MA_PA_STREAM_VARIABLE_RATE PA_STREAM_VARIABLE_RATE -#define MA_PA_STREAM_PEAK_DETECT PA_STREAM_PEAK_DETECT -#define MA_PA_STREAM_START_MUTED PA_STREAM_START_MUTED -#define MA_PA_STREAM_ADJUST_LATENCY PA_STREAM_ADJUST_LATENCY -#define MA_PA_STREAM_EARLY_REQUESTS PA_STREAM_EARLY_REQUESTS -#define MA_PA_STREAM_DONT_INHIBIT_AUTO_SUSPEND PA_STREAM_DONT_INHIBIT_AUTO_SUSPEND -#define MA_PA_STREAM_START_UNMUTED PA_STREAM_START_UNMUTED -#define MA_PA_STREAM_FAIL_ON_SUSPEND PA_STREAM_FAIL_ON_SUSPEND -#define MA_PA_STREAM_RELATIVE_VOLUME PA_STREAM_RELATIVE_VOLUME -#define MA_PA_STREAM_PASSTHROUGH PA_STREAM_PASSTHROUGH - -typedef pa_sink_flags_t ma_pa_sink_flags_t; -#define MA_PA_SINK_NOFLAGS PA_SINK_NOFLAGS -#define MA_PA_SINK_HW_VOLUME_CTRL PA_SINK_HW_VOLUME_CTRL -#define MA_PA_SINK_LATENCY PA_SINK_LATENCY -#define MA_PA_SINK_HARDWARE PA_SINK_HARDWARE -#define MA_PA_SINK_NETWORK PA_SINK_NETWORK -#define MA_PA_SINK_HW_MUTE_CTRL PA_SINK_HW_MUTE_CTRL -#define MA_PA_SINK_DECIBEL_VOLUME PA_SINK_DECIBEL_VOLUME -#define MA_PA_SINK_FLAT_VOLUME PA_SINK_FLAT_VOLUME -#define MA_PA_SINK_DYNAMIC_LATENCY PA_SINK_DYNAMIC_LATENCY -#define MA_PA_SINK_SET_FORMATS PA_SINK_SET_FORMATS - -typedef pa_source_flags_t ma_pa_source_flags_t; -#define MA_PA_SOURCE_NOFLAGS PA_SOURCE_NOFLAGS -#define MA_PA_SOURCE_HW_VOLUME_CTRL PA_SOURCE_HW_VOLUME_CTRL -#define MA_PA_SOURCE_LATENCY PA_SOURCE_LATENCY -#define MA_PA_SOURCE_HARDWARE PA_SOURCE_HARDWARE -#define MA_PA_SOURCE_NETWORK PA_SOURCE_NETWORK -#define MA_PA_SOURCE_HW_MUTE_CTRL PA_SOURCE_HW_MUTE_CTRL -#define MA_PA_SOURCE_DECIBEL_VOLUME PA_SOURCE_DECIBEL_VOLUME -#define MA_PA_SOURCE_DYNAMIC_LATENCY PA_SOURCE_DYNAMIC_LATENCY -#define MA_PA_SOURCE_FLAT_VOLUME PA_SOURCE_FLAT_VOLUME - -typedef pa_context_state_t ma_pa_context_state_t; -#define MA_PA_CONTEXT_UNCONNECTED PA_CONTEXT_UNCONNECTED -#define MA_PA_CONTEXT_CONNECTING PA_CONTEXT_CONNECTING -#define MA_PA_CONTEXT_AUTHORIZING PA_CONTEXT_AUTHORIZING -#define MA_PA_CONTEXT_SETTING_NAME PA_CONTEXT_SETTING_NAME -#define MA_PA_CONTEXT_READY PA_CONTEXT_READY -#define MA_PA_CONTEXT_FAILED PA_CONTEXT_FAILED -#define MA_PA_CONTEXT_TERMINATED PA_CONTEXT_TERMINATED - -typedef pa_stream_state_t ma_pa_stream_state_t; -#define MA_PA_STREAM_UNCONNECTED PA_STREAM_UNCONNECTED -#define MA_PA_STREAM_CREATING PA_STREAM_CREATING -#define MA_PA_STREAM_READY PA_STREAM_READY -#define MA_PA_STREAM_FAILED PA_STREAM_FAILED -#define MA_PA_STREAM_TERMINATED PA_STREAM_TERMINATED - -typedef pa_operation_state_t ma_pa_operation_state_t; -#define MA_PA_OPERATION_RUNNING PA_OPERATION_RUNNING -#define MA_PA_OPERATION_DONE PA_OPERATION_DONE -#define MA_PA_OPERATION_CANCELLED PA_OPERATION_CANCELLED - -typedef pa_sink_state_t ma_pa_sink_state_t; -#define MA_PA_SINK_INVALID_STATE PA_SINK_INVALID_STATE -#define MA_PA_SINK_RUNNING PA_SINK_RUNNING -#define MA_PA_SINK_IDLE PA_SINK_IDLE -#define MA_PA_SINK_SUSPENDED PA_SINK_SUSPENDED - -typedef pa_source_state_t ma_pa_source_state_t; -#define MA_PA_SOURCE_INVALID_STATE PA_SOURCE_INVALID_STATE -#define MA_PA_SOURCE_RUNNING PA_SOURCE_RUNNING -#define MA_PA_SOURCE_IDLE PA_SOURCE_IDLE -#define MA_PA_SOURCE_SUSPENDED PA_SOURCE_SUSPENDED - -typedef pa_seek_mode_t ma_pa_seek_mode_t; -#define MA_PA_SEEK_RELATIVE PA_SEEK_RELATIVE -#define MA_PA_SEEK_ABSOLUTE PA_SEEK_ABSOLUTE -#define MA_PA_SEEK_RELATIVE_ON_READ PA_SEEK_RELATIVE_ON_READ -#define MA_PA_SEEK_RELATIVE_END PA_SEEK_RELATIVE_END - -typedef pa_channel_position_t ma_pa_channel_position_t; -#define MA_PA_CHANNEL_POSITION_INVALID PA_CHANNEL_POSITION_INVALID -#define MA_PA_CHANNEL_POSITION_MONO PA_CHANNEL_POSITION_MONO -#define MA_PA_CHANNEL_POSITION_FRONT_LEFT PA_CHANNEL_POSITION_FRONT_LEFT -#define MA_PA_CHANNEL_POSITION_FRONT_RIGHT PA_CHANNEL_POSITION_FRONT_RIGHT -#define MA_PA_CHANNEL_POSITION_FRONT_CENTER PA_CHANNEL_POSITION_FRONT_CENTER -#define MA_PA_CHANNEL_POSITION_REAR_CENTER PA_CHANNEL_POSITION_REAR_CENTER -#define MA_PA_CHANNEL_POSITION_REAR_LEFT PA_CHANNEL_POSITION_REAR_LEFT -#define MA_PA_CHANNEL_POSITION_REAR_RIGHT PA_CHANNEL_POSITION_REAR_RIGHT -#define MA_PA_CHANNEL_POSITION_LFE PA_CHANNEL_POSITION_LFE -#define MA_PA_CHANNEL_POSITION_FRONT_LEFT_OF_CENTER PA_CHANNEL_POSITION_FRONT_LEFT_OF_CENTER -#define MA_PA_CHANNEL_POSITION_FRONT_RIGHT_OF_CENTER PA_CHANNEL_POSITION_FRONT_RIGHT_OF_CENTER -#define MA_PA_CHANNEL_POSITION_SIDE_LEFT PA_CHANNEL_POSITION_SIDE_LEFT -#define MA_PA_CHANNEL_POSITION_SIDE_RIGHT PA_CHANNEL_POSITION_SIDE_RIGHT -#define MA_PA_CHANNEL_POSITION_AUX0 PA_CHANNEL_POSITION_AUX0 -#define MA_PA_CHANNEL_POSITION_AUX1 PA_CHANNEL_POSITION_AUX1 -#define MA_PA_CHANNEL_POSITION_AUX2 PA_CHANNEL_POSITION_AUX2 -#define MA_PA_CHANNEL_POSITION_AUX3 PA_CHANNEL_POSITION_AUX3 -#define MA_PA_CHANNEL_POSITION_AUX4 PA_CHANNEL_POSITION_AUX4 -#define MA_PA_CHANNEL_POSITION_AUX5 PA_CHANNEL_POSITION_AUX5 -#define MA_PA_CHANNEL_POSITION_AUX6 PA_CHANNEL_POSITION_AUX6 -#define MA_PA_CHANNEL_POSITION_AUX7 PA_CHANNEL_POSITION_AUX7 -#define MA_PA_CHANNEL_POSITION_AUX8 PA_CHANNEL_POSITION_AUX8 -#define MA_PA_CHANNEL_POSITION_AUX9 PA_CHANNEL_POSITION_AUX9 -#define MA_PA_CHANNEL_POSITION_AUX10 PA_CHANNEL_POSITION_AUX10 -#define MA_PA_CHANNEL_POSITION_AUX11 PA_CHANNEL_POSITION_AUX11 -#define MA_PA_CHANNEL_POSITION_AUX12 PA_CHANNEL_POSITION_AUX12 -#define MA_PA_CHANNEL_POSITION_AUX13 PA_CHANNEL_POSITION_AUX13 -#define MA_PA_CHANNEL_POSITION_AUX14 PA_CHANNEL_POSITION_AUX14 -#define MA_PA_CHANNEL_POSITION_AUX15 PA_CHANNEL_POSITION_AUX15 -#define MA_PA_CHANNEL_POSITION_AUX16 PA_CHANNEL_POSITION_AUX16 -#define MA_PA_CHANNEL_POSITION_AUX17 PA_CHANNEL_POSITION_AUX17 -#define MA_PA_CHANNEL_POSITION_AUX18 PA_CHANNEL_POSITION_AUX18 -#define MA_PA_CHANNEL_POSITION_AUX19 PA_CHANNEL_POSITION_AUX19 -#define MA_PA_CHANNEL_POSITION_AUX20 PA_CHANNEL_POSITION_AUX20 -#define MA_PA_CHANNEL_POSITION_AUX21 PA_CHANNEL_POSITION_AUX21 -#define MA_PA_CHANNEL_POSITION_AUX22 PA_CHANNEL_POSITION_AUX22 -#define MA_PA_CHANNEL_POSITION_AUX23 PA_CHANNEL_POSITION_AUX23 -#define MA_PA_CHANNEL_POSITION_AUX24 PA_CHANNEL_POSITION_AUX24 -#define MA_PA_CHANNEL_POSITION_AUX25 PA_CHANNEL_POSITION_AUX25 -#define MA_PA_CHANNEL_POSITION_AUX26 PA_CHANNEL_POSITION_AUX26 -#define MA_PA_CHANNEL_POSITION_AUX27 PA_CHANNEL_POSITION_AUX27 -#define MA_PA_CHANNEL_POSITION_AUX28 PA_CHANNEL_POSITION_AUX28 -#define MA_PA_CHANNEL_POSITION_AUX29 PA_CHANNEL_POSITION_AUX29 -#define MA_PA_CHANNEL_POSITION_AUX30 PA_CHANNEL_POSITION_AUX30 -#define MA_PA_CHANNEL_POSITION_AUX31 PA_CHANNEL_POSITION_AUX31 -#define MA_PA_CHANNEL_POSITION_TOP_CENTER PA_CHANNEL_POSITION_TOP_CENTER -#define MA_PA_CHANNEL_POSITION_TOP_FRONT_LEFT PA_CHANNEL_POSITION_TOP_FRONT_LEFT -#define MA_PA_CHANNEL_POSITION_TOP_FRONT_RIGHT PA_CHANNEL_POSITION_TOP_FRONT_RIGHT -#define MA_PA_CHANNEL_POSITION_TOP_FRONT_CENTER PA_CHANNEL_POSITION_TOP_FRONT_CENTER -#define MA_PA_CHANNEL_POSITION_TOP_REAR_LEFT PA_CHANNEL_POSITION_TOP_REAR_LEFT -#define MA_PA_CHANNEL_POSITION_TOP_REAR_RIGHT PA_CHANNEL_POSITION_TOP_REAR_RIGHT -#define MA_PA_CHANNEL_POSITION_TOP_REAR_CENTER PA_CHANNEL_POSITION_TOP_REAR_CENTER -#define MA_PA_CHANNEL_POSITION_LEFT PA_CHANNEL_POSITION_LEFT -#define MA_PA_CHANNEL_POSITION_RIGHT PA_CHANNEL_POSITION_RIGHT -#define MA_PA_CHANNEL_POSITION_CENTER PA_CHANNEL_POSITION_CENTER -#define MA_PA_CHANNEL_POSITION_SUBWOOFER PA_CHANNEL_POSITION_SUBWOOFER - -typedef pa_channel_map_def_t ma_pa_channel_map_def_t; -#define MA_PA_CHANNEL_MAP_AIFF PA_CHANNEL_MAP_AIFF -#define MA_PA_CHANNEL_MAP_ALSA PA_CHANNEL_MAP_ALSA -#define MA_PA_CHANNEL_MAP_AUX PA_CHANNEL_MAP_AUX -#define MA_PA_CHANNEL_MAP_WAVEEX PA_CHANNEL_MAP_WAVEEX -#define MA_PA_CHANNEL_MAP_OSS PA_CHANNEL_MAP_OSS -#define MA_PA_CHANNEL_MAP_DEFAULT PA_CHANNEL_MAP_DEFAULT - -typedef pa_sample_format_t ma_pa_sample_format_t; -#define MA_PA_SAMPLE_INVALID PA_SAMPLE_INVALID -#define MA_PA_SAMPLE_U8 PA_SAMPLE_U8 -#define MA_PA_SAMPLE_ALAW PA_SAMPLE_ALAW -#define MA_PA_SAMPLE_ULAW PA_SAMPLE_ULAW -#define MA_PA_SAMPLE_S16LE PA_SAMPLE_S16LE -#define MA_PA_SAMPLE_S16BE PA_SAMPLE_S16BE -#define MA_PA_SAMPLE_FLOAT32LE PA_SAMPLE_FLOAT32LE -#define MA_PA_SAMPLE_FLOAT32BE PA_SAMPLE_FLOAT32BE -#define MA_PA_SAMPLE_S32LE PA_SAMPLE_S32LE -#define MA_PA_SAMPLE_S32BE PA_SAMPLE_S32BE -#define MA_PA_SAMPLE_S24LE PA_SAMPLE_S24LE -#define MA_PA_SAMPLE_S24BE PA_SAMPLE_S24BE -#define MA_PA_SAMPLE_S24_32LE PA_SAMPLE_S24_32LE -#define MA_PA_SAMPLE_S24_32BE PA_SAMPLE_S24_32BE - -typedef pa_mainloop ma_pa_mainloop; -typedef pa_threaded_mainloop ma_pa_threaded_mainloop; -typedef pa_mainloop_api ma_pa_mainloop_api; -typedef pa_context ma_pa_context; -typedef pa_operation ma_pa_operation; -typedef pa_stream ma_pa_stream; -typedef pa_spawn_api ma_pa_spawn_api; -typedef pa_buffer_attr ma_pa_buffer_attr; -typedef pa_channel_map ma_pa_channel_map; -typedef pa_cvolume ma_pa_cvolume; -typedef pa_sample_spec ma_pa_sample_spec; -typedef pa_sink_info ma_pa_sink_info; -typedef pa_source_info ma_pa_source_info; - -typedef pa_context_notify_cb_t ma_pa_context_notify_cb_t; -typedef pa_sink_info_cb_t ma_pa_sink_info_cb_t; -typedef pa_source_info_cb_t ma_pa_source_info_cb_t; -typedef pa_stream_success_cb_t ma_pa_stream_success_cb_t; -typedef pa_stream_request_cb_t ma_pa_stream_request_cb_t; -typedef pa_stream_notify_cb_t ma_pa_stream_notify_cb_t; -typedef pa_free_cb_t ma_pa_free_cb_t; -#else -#define MA_PA_OK 0 -#define MA_PA_ERR_ACCESS 1 -#define MA_PA_ERR_INVALID 2 -#define MA_PA_ERR_NOENTITY 5 -#define MA_PA_ERR_NOTSUPPORTED 19 - -#define MA_PA_CHANNELS_MAX 32 -#define MA_PA_RATE_MAX 384000 - -typedef int ma_pa_context_flags_t; -#define MA_PA_CONTEXT_NOFLAGS 0x00000000 -#define MA_PA_CONTEXT_NOAUTOSPAWN 0x00000001 -#define MA_PA_CONTEXT_NOFAIL 0x00000002 - -typedef int ma_pa_stream_flags_t; -#define MA_PA_STREAM_NOFLAGS 0x00000000 -#define MA_PA_STREAM_START_CORKED 0x00000001 -#define MA_PA_STREAM_INTERPOLATE_TIMING 0x00000002 -#define MA_PA_STREAM_NOT_MONOTONIC 0x00000004 -#define MA_PA_STREAM_AUTO_TIMING_UPDATE 0x00000008 -#define MA_PA_STREAM_NO_REMAP_CHANNELS 0x00000010 -#define MA_PA_STREAM_NO_REMIX_CHANNELS 0x00000020 -#define MA_PA_STREAM_FIX_FORMAT 0x00000040 -#define MA_PA_STREAM_FIX_RATE 0x00000080 -#define MA_PA_STREAM_FIX_CHANNELS 0x00000100 -#define MA_PA_STREAM_DONT_MOVE 0x00000200 -#define MA_PA_STREAM_VARIABLE_RATE 0x00000400 -#define MA_PA_STREAM_PEAK_DETECT 0x00000800 -#define MA_PA_STREAM_START_MUTED 0x00001000 -#define MA_PA_STREAM_ADJUST_LATENCY 0x00002000 -#define MA_PA_STREAM_EARLY_REQUESTS 0x00004000 -#define MA_PA_STREAM_DONT_INHIBIT_AUTO_SUSPEND 0x00008000 -#define MA_PA_STREAM_START_UNMUTED 0x00010000 -#define MA_PA_STREAM_FAIL_ON_SUSPEND 0x00020000 -#define MA_PA_STREAM_RELATIVE_VOLUME 0x00040000 -#define MA_PA_STREAM_PASSTHROUGH 0x00080000 - -typedef int ma_pa_sink_flags_t; -#define MA_PA_SINK_NOFLAGS 0x00000000 -#define MA_PA_SINK_HW_VOLUME_CTRL 0x00000001 -#define MA_PA_SINK_LATENCY 0x00000002 -#define MA_PA_SINK_HARDWARE 0x00000004 -#define MA_PA_SINK_NETWORK 0x00000008 -#define MA_PA_SINK_HW_MUTE_CTRL 0x00000010 -#define MA_PA_SINK_DECIBEL_VOLUME 0x00000020 -#define MA_PA_SINK_FLAT_VOLUME 0x00000040 -#define MA_PA_SINK_DYNAMIC_LATENCY 0x00000080 -#define MA_PA_SINK_SET_FORMATS 0x00000100 - -typedef int ma_pa_source_flags_t; -#define MA_PA_SOURCE_NOFLAGS 0x00000000 -#define MA_PA_SOURCE_HW_VOLUME_CTRL 0x00000001 -#define MA_PA_SOURCE_LATENCY 0x00000002 -#define MA_PA_SOURCE_HARDWARE 0x00000004 -#define MA_PA_SOURCE_NETWORK 0x00000008 -#define MA_PA_SOURCE_HW_MUTE_CTRL 0x00000010 -#define MA_PA_SOURCE_DECIBEL_VOLUME 0x00000020 -#define MA_PA_SOURCE_DYNAMIC_LATENCY 0x00000040 -#define MA_PA_SOURCE_FLAT_VOLUME 0x00000080 - -typedef int ma_pa_context_state_t; -#define MA_PA_CONTEXT_UNCONNECTED 0 -#define MA_PA_CONTEXT_CONNECTING 1 -#define MA_PA_CONTEXT_AUTHORIZING 2 -#define MA_PA_CONTEXT_SETTING_NAME 3 -#define MA_PA_CONTEXT_READY 4 -#define MA_PA_CONTEXT_FAILED 5 -#define MA_PA_CONTEXT_TERMINATED 6 - -typedef int ma_pa_stream_state_t; -#define MA_PA_STREAM_UNCONNECTED 0 -#define MA_PA_STREAM_CREATING 1 -#define MA_PA_STREAM_READY 2 -#define MA_PA_STREAM_FAILED 3 -#define MA_PA_STREAM_TERMINATED 4 - -typedef int ma_pa_operation_state_t; -#define MA_PA_OPERATION_RUNNING 0 -#define MA_PA_OPERATION_DONE 1 -#define MA_PA_OPERATION_CANCELLED 2 - -typedef int ma_pa_sink_state_t; -#define MA_PA_SINK_INVALID_STATE -1 -#define MA_PA_SINK_RUNNING 0 -#define MA_PA_SINK_IDLE 1 -#define MA_PA_SINK_SUSPENDED 2 - -typedef int ma_pa_source_state_t; -#define MA_PA_SOURCE_INVALID_STATE -1 -#define MA_PA_SOURCE_RUNNING 0 -#define MA_PA_SOURCE_IDLE 1 -#define MA_PA_SOURCE_SUSPENDED 2 - -typedef int ma_pa_seek_mode_t; -#define MA_PA_SEEK_RELATIVE 0 -#define MA_PA_SEEK_ABSOLUTE 1 -#define MA_PA_SEEK_RELATIVE_ON_READ 2 -#define MA_PA_SEEK_RELATIVE_END 3 - -typedef int ma_pa_channel_position_t; -#define MA_PA_CHANNEL_POSITION_INVALID -1 -#define MA_PA_CHANNEL_POSITION_MONO 0 -#define MA_PA_CHANNEL_POSITION_FRONT_LEFT 1 -#define MA_PA_CHANNEL_POSITION_FRONT_RIGHT 2 -#define MA_PA_CHANNEL_POSITION_FRONT_CENTER 3 -#define MA_PA_CHANNEL_POSITION_REAR_CENTER 4 -#define MA_PA_CHANNEL_POSITION_REAR_LEFT 5 -#define MA_PA_CHANNEL_POSITION_REAR_RIGHT 6 -#define MA_PA_CHANNEL_POSITION_LFE 7 -#define MA_PA_CHANNEL_POSITION_FRONT_LEFT_OF_CENTER 8 -#define MA_PA_CHANNEL_POSITION_FRONT_RIGHT_OF_CENTER 9 -#define MA_PA_CHANNEL_POSITION_SIDE_LEFT 10 -#define MA_PA_CHANNEL_POSITION_SIDE_RIGHT 11 -#define MA_PA_CHANNEL_POSITION_AUX0 12 -#define MA_PA_CHANNEL_POSITION_AUX1 13 -#define MA_PA_CHANNEL_POSITION_AUX2 14 -#define MA_PA_CHANNEL_POSITION_AUX3 15 -#define MA_PA_CHANNEL_POSITION_AUX4 16 -#define MA_PA_CHANNEL_POSITION_AUX5 17 -#define MA_PA_CHANNEL_POSITION_AUX6 18 -#define MA_PA_CHANNEL_POSITION_AUX7 19 -#define MA_PA_CHANNEL_POSITION_AUX8 20 -#define MA_PA_CHANNEL_POSITION_AUX9 21 -#define MA_PA_CHANNEL_POSITION_AUX10 22 -#define MA_PA_CHANNEL_POSITION_AUX11 23 -#define MA_PA_CHANNEL_POSITION_AUX12 24 -#define MA_PA_CHANNEL_POSITION_AUX13 25 -#define MA_PA_CHANNEL_POSITION_AUX14 26 -#define MA_PA_CHANNEL_POSITION_AUX15 27 -#define MA_PA_CHANNEL_POSITION_AUX16 28 -#define MA_PA_CHANNEL_POSITION_AUX17 29 -#define MA_PA_CHANNEL_POSITION_AUX18 30 -#define MA_PA_CHANNEL_POSITION_AUX19 31 -#define MA_PA_CHANNEL_POSITION_AUX20 32 -#define MA_PA_CHANNEL_POSITION_AUX21 33 -#define MA_PA_CHANNEL_POSITION_AUX22 34 -#define MA_PA_CHANNEL_POSITION_AUX23 35 -#define MA_PA_CHANNEL_POSITION_AUX24 36 -#define MA_PA_CHANNEL_POSITION_AUX25 37 -#define MA_PA_CHANNEL_POSITION_AUX26 38 -#define MA_PA_CHANNEL_POSITION_AUX27 39 -#define MA_PA_CHANNEL_POSITION_AUX28 40 -#define MA_PA_CHANNEL_POSITION_AUX29 41 -#define MA_PA_CHANNEL_POSITION_AUX30 42 -#define MA_PA_CHANNEL_POSITION_AUX31 43 -#define MA_PA_CHANNEL_POSITION_TOP_CENTER 44 -#define MA_PA_CHANNEL_POSITION_TOP_FRONT_LEFT 45 -#define MA_PA_CHANNEL_POSITION_TOP_FRONT_RIGHT 46 -#define MA_PA_CHANNEL_POSITION_TOP_FRONT_CENTER 47 -#define MA_PA_CHANNEL_POSITION_TOP_REAR_LEFT 48 -#define MA_PA_CHANNEL_POSITION_TOP_REAR_RIGHT 49 -#define MA_PA_CHANNEL_POSITION_TOP_REAR_CENTER 50 -#define MA_PA_CHANNEL_POSITION_LEFT MA_PA_CHANNEL_POSITION_FRONT_LEFT -#define MA_PA_CHANNEL_POSITION_RIGHT MA_PA_CHANNEL_POSITION_FRONT_RIGHT -#define MA_PA_CHANNEL_POSITION_CENTER MA_PA_CHANNEL_POSITION_FRONT_CENTER -#define MA_PA_CHANNEL_POSITION_SUBWOOFER MA_PA_CHANNEL_POSITION_LFE - -typedef int ma_pa_channel_map_def_t; -#define MA_PA_CHANNEL_MAP_AIFF 0 -#define MA_PA_CHANNEL_MAP_ALSA 1 -#define MA_PA_CHANNEL_MAP_AUX 2 -#define MA_PA_CHANNEL_MAP_WAVEEX 3 -#define MA_PA_CHANNEL_MAP_OSS 4 -#define MA_PA_CHANNEL_MAP_DEFAULT MA_PA_CHANNEL_MAP_AIFF - -typedef int ma_pa_sample_format_t; -#define MA_PA_SAMPLE_INVALID -1 -#define MA_PA_SAMPLE_U8 0 -#define MA_PA_SAMPLE_ALAW 1 -#define MA_PA_SAMPLE_ULAW 2 -#define MA_PA_SAMPLE_S16LE 3 -#define MA_PA_SAMPLE_S16BE 4 -#define MA_PA_SAMPLE_FLOAT32LE 5 -#define MA_PA_SAMPLE_FLOAT32BE 6 -#define MA_PA_SAMPLE_S32LE 7 -#define MA_PA_SAMPLE_S32BE 8 -#define MA_PA_SAMPLE_S24LE 9 -#define MA_PA_SAMPLE_S24BE 10 -#define MA_PA_SAMPLE_S24_32LE 11 -#define MA_PA_SAMPLE_S24_32BE 12 - -typedef struct ma_pa_mainloop ma_pa_mainloop; -typedef struct ma_pa_threaded_mainloop ma_pa_threaded_mainloop; -typedef struct ma_pa_mainloop_api ma_pa_mainloop_api; -typedef struct ma_pa_context ma_pa_context; -typedef struct ma_pa_operation ma_pa_operation; -typedef struct ma_pa_stream ma_pa_stream; -typedef struct ma_pa_spawn_api ma_pa_spawn_api; - -typedef struct -{ - ma_uint32 maxlength; - ma_uint32 tlength; - ma_uint32 prebuf; - ma_uint32 minreq; - ma_uint32 fragsize; -} ma_pa_buffer_attr; - -typedef struct -{ - ma_uint8 channels; - ma_pa_channel_position_t map[MA_PA_CHANNELS_MAX]; -} ma_pa_channel_map; - -typedef struct -{ - ma_uint8 channels; - ma_uint32 values[MA_PA_CHANNELS_MAX]; -} ma_pa_cvolume; - -typedef struct -{ - ma_pa_sample_format_t format; - ma_uint32 rate; - ma_uint8 channels; -} ma_pa_sample_spec; - -typedef struct -{ - const char* name; - ma_uint32 index; - const char* description; - ma_pa_sample_spec sample_spec; - ma_pa_channel_map channel_map; - ma_uint32 owner_module; - ma_pa_cvolume volume; - int mute; - ma_uint32 monitor_source; - const char* monitor_source_name; - ma_uint64 latency; - const char* driver; - ma_pa_sink_flags_t flags; - void* proplist; - ma_uint64 configured_latency; - ma_uint32 base_volume; - ma_pa_sink_state_t state; - ma_uint32 n_volume_steps; - ma_uint32 card; - ma_uint32 n_ports; - void** ports; - void* active_port; - ma_uint8 n_formats; - void** formats; -} ma_pa_sink_info; - -typedef struct -{ - const char *name; - ma_uint32 index; - const char *description; - ma_pa_sample_spec sample_spec; - ma_pa_channel_map channel_map; - ma_uint32 owner_module; - ma_pa_cvolume volume; - int mute; - ma_uint32 monitor_of_sink; - const char *monitor_of_sink_name; - ma_uint64 latency; - const char *driver; - ma_pa_source_flags_t flags; - void* proplist; - ma_uint64 configured_latency; - ma_uint32 base_volume; - ma_pa_source_state_t state; - ma_uint32 n_volume_steps; - ma_uint32 card; - ma_uint32 n_ports; - void** ports; - void* active_port; - ma_uint8 n_formats; - void** formats; -} ma_pa_source_info; - -typedef void (* ma_pa_context_notify_cb_t)(ma_pa_context* c, void* userdata); -typedef void (* ma_pa_sink_info_cb_t) (ma_pa_context* c, const ma_pa_sink_info* i, int eol, void* userdata); -typedef void (* ma_pa_source_info_cb_t) (ma_pa_context* c, const ma_pa_source_info* i, int eol, void* userdata); -typedef void (* ma_pa_stream_success_cb_t)(ma_pa_stream* s, int success, void* userdata); -typedef void (* ma_pa_stream_request_cb_t)(ma_pa_stream* s, size_t nbytes, void* userdata); -typedef void (* ma_pa_stream_notify_cb_t) (ma_pa_stream* s, void* userdata); -typedef void (* ma_pa_free_cb_t) (void* p); -#endif - - -typedef ma_pa_mainloop* (* ma_pa_mainloop_new_proc) (void); -typedef void (* ma_pa_mainloop_free_proc) (ma_pa_mainloop* m); -typedef void (* ma_pa_mainloop_quit_proc) (ma_pa_mainloop* m, int retval); -typedef ma_pa_mainloop_api* (* ma_pa_mainloop_get_api_proc) (ma_pa_mainloop* m); -typedef int (* ma_pa_mainloop_iterate_proc) (ma_pa_mainloop* m, int block, int* retval); -typedef void (* ma_pa_mainloop_wakeup_proc) (ma_pa_mainloop* m); -typedef ma_pa_threaded_mainloop* (* ma_pa_threaded_mainloop_new_proc) (void); -typedef void (* ma_pa_threaded_mainloop_free_proc) (ma_pa_threaded_mainloop* m); -typedef int (* ma_pa_threaded_mainloop_start_proc) (ma_pa_threaded_mainloop* m); -typedef void (* ma_pa_threaded_mainloop_stop_proc) (ma_pa_threaded_mainloop* m); -typedef void (* ma_pa_threaded_mainloop_lock_proc) (ma_pa_threaded_mainloop* m); -typedef void (* ma_pa_threaded_mainloop_unlock_proc) (ma_pa_threaded_mainloop* m); -typedef void (* ma_pa_threaded_mainloop_wait_proc) (ma_pa_threaded_mainloop* m); -typedef void (* ma_pa_threaded_mainloop_signal_proc) (ma_pa_threaded_mainloop* m, int wait_for_accept); -typedef void (* ma_pa_threaded_mainloop_accept_proc) (ma_pa_threaded_mainloop* m); -typedef int (* ma_pa_threaded_mainloop_get_retval_proc) (ma_pa_threaded_mainloop* m); -typedef ma_pa_mainloop_api* (* ma_pa_threaded_mainloop_get_api_proc) (ma_pa_threaded_mainloop* m); -typedef int (* ma_pa_threaded_mainloop_in_thread_proc) (ma_pa_threaded_mainloop* m); -typedef void (* ma_pa_threaded_mainloop_set_name_proc) (ma_pa_threaded_mainloop* m, const char* name); -typedef ma_pa_context* (* ma_pa_context_new_proc) (ma_pa_mainloop_api* mainloop, const char* name); -typedef void (* ma_pa_context_unref_proc) (ma_pa_context* c); -typedef int (* ma_pa_context_connect_proc) (ma_pa_context* c, const char* server, ma_pa_context_flags_t flags, const ma_pa_spawn_api* api); -typedef void (* ma_pa_context_disconnect_proc) (ma_pa_context* c); -typedef void (* ma_pa_context_set_state_callback_proc) (ma_pa_context* c, ma_pa_context_notify_cb_t cb, void* userdata); -typedef ma_pa_context_state_t (* ma_pa_context_get_state_proc) (ma_pa_context* c); -typedef ma_pa_operation* (* ma_pa_context_get_sink_info_list_proc) (ma_pa_context* c, ma_pa_sink_info_cb_t cb, void* userdata); -typedef ma_pa_operation* (* ma_pa_context_get_source_info_list_proc) (ma_pa_context* c, ma_pa_source_info_cb_t cb, void* userdata); -typedef ma_pa_operation* (* ma_pa_context_get_sink_info_by_name_proc) (ma_pa_context* c, const char* name, ma_pa_sink_info_cb_t cb, void* userdata); -typedef ma_pa_operation* (* ma_pa_context_get_source_info_by_name_proc)(ma_pa_context* c, const char* name, ma_pa_source_info_cb_t cb, void* userdata); -typedef void (* ma_pa_operation_unref_proc) (ma_pa_operation* o); -typedef ma_pa_operation_state_t (* ma_pa_operation_get_state_proc) (ma_pa_operation* o); -typedef ma_pa_channel_map* (* ma_pa_channel_map_init_extend_proc) (ma_pa_channel_map* m, unsigned channels, ma_pa_channel_map_def_t def); -typedef int (* ma_pa_channel_map_valid_proc) (const ma_pa_channel_map* m); -typedef int (* ma_pa_channel_map_compatible_proc) (const ma_pa_channel_map* m, const ma_pa_sample_spec* ss); -typedef ma_pa_stream* (* ma_pa_stream_new_proc) (ma_pa_context* c, const char* name, const ma_pa_sample_spec* ss, const ma_pa_channel_map* map); -typedef void (* ma_pa_stream_unref_proc) (ma_pa_stream* s); -typedef int (* ma_pa_stream_connect_playback_proc) (ma_pa_stream* s, const char* dev, const ma_pa_buffer_attr* attr, ma_pa_stream_flags_t flags, const ma_pa_cvolume* volume, ma_pa_stream* sync_stream); -typedef int (* ma_pa_stream_connect_record_proc) (ma_pa_stream* s, const char* dev, const ma_pa_buffer_attr* attr, ma_pa_stream_flags_t flags); -typedef int (* ma_pa_stream_disconnect_proc) (ma_pa_stream* s); -typedef ma_pa_stream_state_t (* ma_pa_stream_get_state_proc) (ma_pa_stream* s); -typedef const ma_pa_sample_spec* (* ma_pa_stream_get_sample_spec_proc) (ma_pa_stream* s); -typedef const ma_pa_channel_map* (* ma_pa_stream_get_channel_map_proc) (ma_pa_stream* s); -typedef const ma_pa_buffer_attr* (* ma_pa_stream_get_buffer_attr_proc) (ma_pa_stream* s); -typedef ma_pa_operation* (* ma_pa_stream_set_buffer_attr_proc) (ma_pa_stream* s, const ma_pa_buffer_attr* attr, ma_pa_stream_success_cb_t cb, void* userdata); -typedef const char* (* ma_pa_stream_get_device_name_proc) (ma_pa_stream* s); -typedef void (* ma_pa_stream_set_write_callback_proc) (ma_pa_stream* s, ma_pa_stream_request_cb_t cb, void* userdata); -typedef void (* ma_pa_stream_set_read_callback_proc) (ma_pa_stream* s, ma_pa_stream_request_cb_t cb, void* userdata); -typedef void (* ma_pa_stream_set_suspended_callback_proc) (ma_pa_stream* s, ma_pa_stream_notify_cb_t cb, void* userdata); -typedef void (* ma_pa_stream_set_moved_callback_proc) (ma_pa_stream* s, ma_pa_stream_notify_cb_t cb, void* userdata); -typedef int (* ma_pa_stream_is_suspended_proc) (const ma_pa_stream* s); -typedef ma_pa_operation* (* ma_pa_stream_flush_proc) (ma_pa_stream* s, ma_pa_stream_success_cb_t cb, void* userdata); -typedef ma_pa_operation* (* ma_pa_stream_drain_proc) (ma_pa_stream* s, ma_pa_stream_success_cb_t cb, void* userdata); -typedef int (* ma_pa_stream_is_corked_proc) (ma_pa_stream* s); -typedef ma_pa_operation* (* ma_pa_stream_cork_proc) (ma_pa_stream* s, int b, ma_pa_stream_success_cb_t cb, void* userdata); -typedef ma_pa_operation* (* ma_pa_stream_trigger_proc) (ma_pa_stream* s, ma_pa_stream_success_cb_t cb, void* userdata); -typedef int (* ma_pa_stream_begin_write_proc) (ma_pa_stream* s, void** data, size_t* nbytes); -typedef int (* ma_pa_stream_write_proc) (ma_pa_stream* s, const void* data, size_t nbytes, ma_pa_free_cb_t free_cb, int64_t offset, ma_pa_seek_mode_t seek); -typedef int (* ma_pa_stream_peek_proc) (ma_pa_stream* s, const void** data, size_t* nbytes); -typedef int (* ma_pa_stream_drop_proc) (ma_pa_stream* s); -typedef size_t (* ma_pa_stream_writable_size_proc) (ma_pa_stream* s); -typedef size_t (* ma_pa_stream_readable_size_proc) (ma_pa_stream* s); - -typedef struct -{ - ma_uint32 count; - ma_uint32 capacity; - ma_device_info* pInfo; -} ma_pulse_device_enum_data; - -static ma_result ma_result_from_pulse(int result) -{ - if (result < 0) { - return MA_ERROR; - } - - switch (result) { - case MA_PA_OK: return MA_SUCCESS; - case MA_PA_ERR_ACCESS: return MA_ACCESS_DENIED; - case MA_PA_ERR_INVALID: return MA_INVALID_ARGS; - case MA_PA_ERR_NOENTITY: return MA_NO_DEVICE; - default: return MA_ERROR; - } -} - -#if 0 -static ma_pa_sample_format_t ma_format_to_pulse(ma_format format) -{ - if (ma_is_little_endian()) { - switch (format) { - case ma_format_s16: return MA_PA_SAMPLE_S16LE; - case ma_format_s24: return MA_PA_SAMPLE_S24LE; - case ma_format_s32: return MA_PA_SAMPLE_S32LE; - case ma_format_f32: return MA_PA_SAMPLE_FLOAT32LE; - default: break; - } - } else { - switch (format) { - case ma_format_s16: return MA_PA_SAMPLE_S16BE; - case ma_format_s24: return MA_PA_SAMPLE_S24BE; - case ma_format_s32: return MA_PA_SAMPLE_S32BE; - case ma_format_f32: return MA_PA_SAMPLE_FLOAT32BE; - default: break; - } - } - - /* Endian agnostic. */ - switch (format) { - case ma_format_u8: return MA_PA_SAMPLE_U8; - default: return MA_PA_SAMPLE_INVALID; - } -} -#endif - -static ma_format ma_format_from_pulse(ma_pa_sample_format_t format) -{ - if (ma_is_little_endian()) { - switch (format) { - case MA_PA_SAMPLE_S16LE: return ma_format_s16; - case MA_PA_SAMPLE_S24LE: return ma_format_s24; - case MA_PA_SAMPLE_S32LE: return ma_format_s32; - case MA_PA_SAMPLE_FLOAT32LE: return ma_format_f32; - default: break; - } - } else { - switch (format) { - case MA_PA_SAMPLE_S16BE: return ma_format_s16; - case MA_PA_SAMPLE_S24BE: return ma_format_s24; - case MA_PA_SAMPLE_S32BE: return ma_format_s32; - case MA_PA_SAMPLE_FLOAT32BE: return ma_format_f32; - default: break; - } - } - - /* Endian agnostic. */ - switch (format) { - case MA_PA_SAMPLE_U8: return ma_format_u8; - default: return ma_format_unknown; - } -} - -static ma_channel ma_channel_position_from_pulse(ma_pa_channel_position_t position) -{ - switch (position) - { - case MA_PA_CHANNEL_POSITION_INVALID: return MA_CHANNEL_NONE; - case MA_PA_CHANNEL_POSITION_MONO: return MA_CHANNEL_MONO; - case MA_PA_CHANNEL_POSITION_FRONT_LEFT: return MA_CHANNEL_FRONT_LEFT; - case MA_PA_CHANNEL_POSITION_FRONT_RIGHT: return MA_CHANNEL_FRONT_RIGHT; - case MA_PA_CHANNEL_POSITION_FRONT_CENTER: return MA_CHANNEL_FRONT_CENTER; - case MA_PA_CHANNEL_POSITION_REAR_CENTER: return MA_CHANNEL_BACK_CENTER; - case MA_PA_CHANNEL_POSITION_REAR_LEFT: return MA_CHANNEL_BACK_LEFT; - case MA_PA_CHANNEL_POSITION_REAR_RIGHT: return MA_CHANNEL_BACK_RIGHT; - case MA_PA_CHANNEL_POSITION_LFE: return MA_CHANNEL_LFE; - case MA_PA_CHANNEL_POSITION_FRONT_LEFT_OF_CENTER: return MA_CHANNEL_FRONT_LEFT_CENTER; - case MA_PA_CHANNEL_POSITION_FRONT_RIGHT_OF_CENTER: return MA_CHANNEL_FRONT_RIGHT_CENTER; - case MA_PA_CHANNEL_POSITION_SIDE_LEFT: return MA_CHANNEL_SIDE_LEFT; - case MA_PA_CHANNEL_POSITION_SIDE_RIGHT: return MA_CHANNEL_SIDE_RIGHT; - case MA_PA_CHANNEL_POSITION_AUX0: return MA_CHANNEL_AUX_0; - case MA_PA_CHANNEL_POSITION_AUX1: return MA_CHANNEL_AUX_1; - case MA_PA_CHANNEL_POSITION_AUX2: return MA_CHANNEL_AUX_2; - case MA_PA_CHANNEL_POSITION_AUX3: return MA_CHANNEL_AUX_3; - case MA_PA_CHANNEL_POSITION_AUX4: return MA_CHANNEL_AUX_4; - case MA_PA_CHANNEL_POSITION_AUX5: return MA_CHANNEL_AUX_5; - case MA_PA_CHANNEL_POSITION_AUX6: return MA_CHANNEL_AUX_6; - case MA_PA_CHANNEL_POSITION_AUX7: return MA_CHANNEL_AUX_7; - case MA_PA_CHANNEL_POSITION_AUX8: return MA_CHANNEL_AUX_8; - case MA_PA_CHANNEL_POSITION_AUX9: return MA_CHANNEL_AUX_9; - case MA_PA_CHANNEL_POSITION_AUX10: return MA_CHANNEL_AUX_10; - case MA_PA_CHANNEL_POSITION_AUX11: return MA_CHANNEL_AUX_11; - case MA_PA_CHANNEL_POSITION_AUX12: return MA_CHANNEL_AUX_12; - case MA_PA_CHANNEL_POSITION_AUX13: return MA_CHANNEL_AUX_13; - case MA_PA_CHANNEL_POSITION_AUX14: return MA_CHANNEL_AUX_14; - case MA_PA_CHANNEL_POSITION_AUX15: return MA_CHANNEL_AUX_15; - case MA_PA_CHANNEL_POSITION_AUX16: return MA_CHANNEL_AUX_16; - case MA_PA_CHANNEL_POSITION_AUX17: return MA_CHANNEL_AUX_17; - case MA_PA_CHANNEL_POSITION_AUX18: return MA_CHANNEL_AUX_18; - case MA_PA_CHANNEL_POSITION_AUX19: return MA_CHANNEL_AUX_19; - case MA_PA_CHANNEL_POSITION_AUX20: return MA_CHANNEL_AUX_20; - case MA_PA_CHANNEL_POSITION_AUX21: return MA_CHANNEL_AUX_21; - case MA_PA_CHANNEL_POSITION_AUX22: return MA_CHANNEL_AUX_22; - case MA_PA_CHANNEL_POSITION_AUX23: return MA_CHANNEL_AUX_23; - case MA_PA_CHANNEL_POSITION_AUX24: return MA_CHANNEL_AUX_24; - case MA_PA_CHANNEL_POSITION_AUX25: return MA_CHANNEL_AUX_25; - case MA_PA_CHANNEL_POSITION_AUX26: return MA_CHANNEL_AUX_26; - case MA_PA_CHANNEL_POSITION_AUX27: return MA_CHANNEL_AUX_27; - case MA_PA_CHANNEL_POSITION_AUX28: return MA_CHANNEL_AUX_28; - case MA_PA_CHANNEL_POSITION_AUX29: return MA_CHANNEL_AUX_29; - case MA_PA_CHANNEL_POSITION_AUX30: return MA_CHANNEL_AUX_30; - case MA_PA_CHANNEL_POSITION_AUX31: return MA_CHANNEL_AUX_31; - case MA_PA_CHANNEL_POSITION_TOP_CENTER: return MA_CHANNEL_TOP_CENTER; - case MA_PA_CHANNEL_POSITION_TOP_FRONT_LEFT: return MA_CHANNEL_TOP_FRONT_LEFT; - case MA_PA_CHANNEL_POSITION_TOP_FRONT_RIGHT: return MA_CHANNEL_TOP_FRONT_RIGHT; - case MA_PA_CHANNEL_POSITION_TOP_FRONT_CENTER: return MA_CHANNEL_TOP_FRONT_CENTER; - case MA_PA_CHANNEL_POSITION_TOP_REAR_LEFT: return MA_CHANNEL_TOP_BACK_LEFT; - case MA_PA_CHANNEL_POSITION_TOP_REAR_RIGHT: return MA_CHANNEL_TOP_BACK_RIGHT; - case MA_PA_CHANNEL_POSITION_TOP_REAR_CENTER: return MA_CHANNEL_TOP_BACK_CENTER; - default: return MA_CHANNEL_NONE; - } -} - -#if 0 -static ma_pa_channel_position_t ma_channel_position_to_pulse(ma_channel position) -{ - switch (position) - { - case MA_CHANNEL_NONE: return MA_PA_CHANNEL_POSITION_INVALID; - case MA_CHANNEL_FRONT_LEFT: return MA_PA_CHANNEL_POSITION_FRONT_LEFT; - case MA_CHANNEL_FRONT_RIGHT: return MA_PA_CHANNEL_POSITION_FRONT_RIGHT; - case MA_CHANNEL_FRONT_CENTER: return MA_PA_CHANNEL_POSITION_FRONT_CENTER; - case MA_CHANNEL_LFE: return MA_PA_CHANNEL_POSITION_LFE; - case MA_CHANNEL_BACK_LEFT: return MA_PA_CHANNEL_POSITION_REAR_LEFT; - case MA_CHANNEL_BACK_RIGHT: return MA_PA_CHANNEL_POSITION_REAR_RIGHT; - case MA_CHANNEL_FRONT_LEFT_CENTER: return MA_PA_CHANNEL_POSITION_FRONT_LEFT_OF_CENTER; - case MA_CHANNEL_FRONT_RIGHT_CENTER: return MA_PA_CHANNEL_POSITION_FRONT_RIGHT_OF_CENTER; - case MA_CHANNEL_BACK_CENTER: return MA_PA_CHANNEL_POSITION_REAR_CENTER; - case MA_CHANNEL_SIDE_LEFT: return MA_PA_CHANNEL_POSITION_SIDE_LEFT; - case MA_CHANNEL_SIDE_RIGHT: return MA_PA_CHANNEL_POSITION_SIDE_RIGHT; - case MA_CHANNEL_TOP_CENTER: return MA_PA_CHANNEL_POSITION_TOP_CENTER; - case MA_CHANNEL_TOP_FRONT_LEFT: return MA_PA_CHANNEL_POSITION_TOP_FRONT_LEFT; - case MA_CHANNEL_TOP_FRONT_CENTER: return MA_PA_CHANNEL_POSITION_TOP_FRONT_CENTER; - case MA_CHANNEL_TOP_FRONT_RIGHT: return MA_PA_CHANNEL_POSITION_TOP_FRONT_RIGHT; - case MA_CHANNEL_TOP_BACK_LEFT: return MA_PA_CHANNEL_POSITION_TOP_REAR_LEFT; - case MA_CHANNEL_TOP_BACK_CENTER: return MA_PA_CHANNEL_POSITION_TOP_REAR_CENTER; - case MA_CHANNEL_TOP_BACK_RIGHT: return MA_PA_CHANNEL_POSITION_TOP_REAR_RIGHT; - case MA_CHANNEL_19: return MA_PA_CHANNEL_POSITION_AUX18; - case MA_CHANNEL_20: return MA_PA_CHANNEL_POSITION_AUX19; - case MA_CHANNEL_21: return MA_PA_CHANNEL_POSITION_AUX20; - case MA_CHANNEL_22: return MA_PA_CHANNEL_POSITION_AUX21; - case MA_CHANNEL_23: return MA_PA_CHANNEL_POSITION_AUX22; - case MA_CHANNEL_24: return MA_PA_CHANNEL_POSITION_AUX23; - case MA_CHANNEL_25: return MA_PA_CHANNEL_POSITION_AUX24; - case MA_CHANNEL_26: return MA_PA_CHANNEL_POSITION_AUX25; - case MA_CHANNEL_27: return MA_PA_CHANNEL_POSITION_AUX26; - case MA_CHANNEL_28: return MA_PA_CHANNEL_POSITION_AUX27; - case MA_CHANNEL_29: return MA_PA_CHANNEL_POSITION_AUX28; - case MA_CHANNEL_30: return MA_PA_CHANNEL_POSITION_AUX29; - case MA_CHANNEL_31: return MA_PA_CHANNEL_POSITION_AUX30; - case MA_CHANNEL_32: return MA_PA_CHANNEL_POSITION_AUX31; - default: return (ma_pa_channel_position_t)position; - } -} -#endif - -static ma_result ma_wait_for_operation__pulse(ma_context* pContext, ma_ptr pMainLoop, ma_pa_operation* pOP) -{ - int resultPA; - ma_pa_operation_state_t state; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pOP != NULL); - - for (;;) { - state = ((ma_pa_operation_get_state_proc)pContext->pulse.pa_operation_get_state)(pOP); - if (state != MA_PA_OPERATION_RUNNING) { - break; /* Done. */ - } - - resultPA = ((ma_pa_mainloop_iterate_proc)pContext->pulse.pa_mainloop_iterate)((ma_pa_mainloop*)pMainLoop, 1, NULL); - if (resultPA < 0) { - return ma_result_from_pulse(resultPA); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_wait_for_operation_and_unref__pulse(ma_context* pContext, ma_ptr pMainLoop, ma_pa_operation* pOP) -{ - ma_result result; - - if (pOP == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_wait_for_operation__pulse(pContext, pMainLoop, pOP); - ((ma_pa_operation_unref_proc)pContext->pulse.pa_operation_unref)(pOP); - - return result; -} - -static ma_result ma_wait_for_pa_context_to_connect__pulse(ma_context* pContext, ma_ptr pMainLoop, ma_ptr pPulseContext) -{ - int resultPA; - ma_pa_context_state_t state; - - for (;;) { - state = ((ma_pa_context_get_state_proc)pContext->pulse.pa_context_get_state)((ma_pa_context*)pPulseContext); - if (state == MA_PA_CONTEXT_READY) { - break; /* Done. */ - } - - if (state == MA_PA_CONTEXT_FAILED || state == MA_PA_CONTEXT_TERMINATED) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[PulseAudio] An error occurred while connecting the PulseAudio context."); - return MA_ERROR; - } - - resultPA = ((ma_pa_mainloop_iterate_proc)pContext->pulse.pa_mainloop_iterate)((ma_pa_mainloop*)pMainLoop, 1, NULL); - if (resultPA < 0) { - return ma_result_from_pulse(resultPA); - } - } - - /* Should never get here. */ - return MA_SUCCESS; -} - -static ma_result ma_wait_for_pa_stream_to_connect__pulse(ma_context* pContext, ma_ptr pMainLoop, ma_ptr pStream) -{ - int resultPA; - ma_pa_stream_state_t state; - - for (;;) { - state = ((ma_pa_stream_get_state_proc)pContext->pulse.pa_stream_get_state)((ma_pa_stream*)pStream); - if (state == MA_PA_STREAM_READY) { - break; /* Done. */ - } - - if (state == MA_PA_STREAM_FAILED || state == MA_PA_STREAM_TERMINATED) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[PulseAudio] An error occurred while connecting the PulseAudio stream."); - return MA_ERROR; - } - - resultPA = ((ma_pa_mainloop_iterate_proc)pContext->pulse.pa_mainloop_iterate)((ma_pa_mainloop*)pMainLoop, 1, NULL); - if (resultPA < 0) { - return ma_result_from_pulse(resultPA); - } - } - - return MA_SUCCESS; -} - - -static ma_result ma_init_pa_mainloop_and_pa_context__pulse(ma_context* pContext, const char* pApplicationName, const char* pServerName, ma_bool32 tryAutoSpawn, ma_ptr* ppMainLoop, ma_ptr* ppPulseContext) -{ - ma_result result; - ma_ptr pMainLoop; - ma_ptr pPulseContext; - - MA_ASSERT(ppMainLoop != NULL); - MA_ASSERT(ppPulseContext != NULL); - - /* The PulseAudio context maps well to miniaudio's notion of a context. The pa_context object will be initialized as part of the ma_context. */ - pMainLoop = ((ma_pa_mainloop_new_proc)pContext->pulse.pa_mainloop_new)(); - if (pMainLoop == NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to create mainloop."); - return MA_FAILED_TO_INIT_BACKEND; - } - - pPulseContext = ((ma_pa_context_new_proc)pContext->pulse.pa_context_new)(((ma_pa_mainloop_get_api_proc)pContext->pulse.pa_mainloop_get_api)((ma_pa_mainloop*)pMainLoop), pApplicationName); - if (pPulseContext == NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to create PulseAudio context."); - ((ma_pa_mainloop_free_proc)pContext->pulse.pa_mainloop_free)((ma_pa_mainloop*)(pMainLoop)); - return MA_FAILED_TO_INIT_BACKEND; - } - - /* Now we need to connect to the context. Everything is asynchronous so we need to wait for it to connect before returning. */ - result = ma_result_from_pulse(((ma_pa_context_connect_proc)pContext->pulse.pa_context_connect)((ma_pa_context*)pPulseContext, pServerName, (tryAutoSpawn) ? 0 : MA_PA_CONTEXT_NOAUTOSPAWN, NULL)); - if (result != MA_SUCCESS) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to connect PulseAudio context."); - ((ma_pa_mainloop_free_proc)pContext->pulse.pa_mainloop_free)((ma_pa_mainloop*)(pMainLoop)); - return result; - } - - /* Since ma_context_init() runs synchronously we need to wait for the PulseAudio context to connect before we return. */ - result = ma_wait_for_pa_context_to_connect__pulse(pContext, pMainLoop, pPulseContext); - if (result != MA_SUCCESS) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[PulseAudio] Waiting for connection failed."); - ((ma_pa_mainloop_free_proc)pContext->pulse.pa_mainloop_free)((ma_pa_mainloop*)(pMainLoop)); - return result; - } - - *ppMainLoop = pMainLoop; - *ppPulseContext = pPulseContext; - - return MA_SUCCESS; -} - - -static void ma_device_sink_info_callback(ma_pa_context* pPulseContext, const ma_pa_sink_info* pInfo, int endOfList, void* pUserData) -{ - ma_pa_sink_info* pInfoOut; - - if (endOfList > 0) { - return; - } - - /* - There has been a report that indicates that pInfo can be null which results - in a null pointer dereference below. We'll check for this for safety. - */ - if (pInfo == NULL) { - return; - } - - pInfoOut = (ma_pa_sink_info*)pUserData; - MA_ASSERT(pInfoOut != NULL); - - *pInfoOut = *pInfo; - - (void)pPulseContext; /* Unused. */ -} - -static void ma_device_source_info_callback(ma_pa_context* pPulseContext, const ma_pa_source_info* pInfo, int endOfList, void* pUserData) -{ - ma_pa_source_info* pInfoOut; - - if (endOfList > 0) { - return; - } - - /* - There has been a report that indicates that pInfo can be null which results - in a null pointer dereference below. We'll check for this for safety. - */ - if (pInfo == NULL) { - return; - } - - pInfoOut = (ma_pa_source_info*)pUserData; - MA_ASSERT(pInfoOut != NULL); - - *pInfoOut = *pInfo; - - (void)pPulseContext; /* Unused. */ -} - -#if 0 -static void ma_device_sink_name_callback(ma_pa_context* pPulseContext, const ma_pa_sink_info* pInfo, int endOfList, void* pUserData) -{ - ma_device* pDevice; - - if (endOfList > 0) { - return; - } - - pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), pInfo->description, (size_t)-1); - - (void)pPulseContext; /* Unused. */ -} - -static void ma_device_source_name_callback(ma_pa_context* pPulseContext, const ma_pa_source_info* pInfo, int endOfList, void* pUserData) -{ - ma_device* pDevice; - - if (endOfList > 0) { - return; - } - - pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), pInfo->description, (size_t)-1); - - (void)pPulseContext; /* Unused. */ -} -#endif - -static ma_result ma_context_get_sink_info__pulse(ma_context* pContext, const char* pDeviceName, ma_pa_sink_info* pSinkInfo) -{ - ma_pa_operation* pOP; - - pOP = ((ma_pa_context_get_sink_info_by_name_proc)pContext->pulse.pa_context_get_sink_info_by_name)((ma_pa_context*)pContext->pulse.pPulseContext, pDeviceName, ma_device_sink_info_callback, pSinkInfo); - if (pOP == NULL) { - return MA_ERROR; - } - - return ma_wait_for_operation_and_unref__pulse(pContext, pContext->pulse.pMainLoop, pOP); -} - -static ma_result ma_context_get_source_info__pulse(ma_context* pContext, const char* pDeviceName, ma_pa_source_info* pSourceInfo) -{ - ma_pa_operation* pOP; - - pOP = ((ma_pa_context_get_source_info_by_name_proc)pContext->pulse.pa_context_get_source_info_by_name)((ma_pa_context*)pContext->pulse.pPulseContext, pDeviceName, ma_device_source_info_callback, pSourceInfo); - if (pOP == NULL) { - return MA_ERROR; - } - - return ma_wait_for_operation_and_unref__pulse(pContext, pContext->pulse.pMainLoop, pOP); -} - -static ma_result ma_context_get_default_device_index__pulse(ma_context* pContext, ma_device_type deviceType, ma_uint32* pIndex) -{ - ma_result result; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pIndex != NULL); - - if (pIndex != NULL) { - *pIndex = (ma_uint32)-1; - } - - if (deviceType == ma_device_type_playback) { - ma_pa_sink_info sinkInfo; - result = ma_context_get_sink_info__pulse(pContext, NULL, &sinkInfo); - if (result != MA_SUCCESS) { - return result; - } - - if (pIndex != NULL) { - *pIndex = sinkInfo.index; - } - } - - if (deviceType == ma_device_type_capture) { - ma_pa_source_info sourceInfo; - result = ma_context_get_source_info__pulse(pContext, NULL, &sourceInfo); - if (result != MA_SUCCESS) { - return result; - } - - if (pIndex != NULL) { - *pIndex = sourceInfo.index; - } - } - - return MA_SUCCESS; -} - - -typedef struct -{ - ma_context* pContext; - ma_enum_devices_callback_proc callback; - void* pUserData; - ma_bool32 isTerminated; - ma_uint32 defaultDeviceIndexPlayback; - ma_uint32 defaultDeviceIndexCapture; -} ma_context_enumerate_devices_callback_data__pulse; - -static void ma_context_enumerate_devices_sink_callback__pulse(ma_pa_context* pPulseContext, const ma_pa_sink_info* pSinkInfo, int endOfList, void* pUserData) -{ - ma_context_enumerate_devices_callback_data__pulse* pData = (ma_context_enumerate_devices_callback_data__pulse*)pUserData; - ma_device_info deviceInfo; - - MA_ASSERT(pData != NULL); - - if (endOfList || pData->isTerminated) { - return; - } - - MA_ZERO_OBJECT(&deviceInfo); - - /* The name from PulseAudio is the ID for miniaudio. */ - if (pSinkInfo->name != NULL) { - ma_strncpy_s(deviceInfo.id.pulse, sizeof(deviceInfo.id.pulse), pSinkInfo->name, (size_t)-1); - } - - /* The description from PulseAudio is the name for miniaudio. */ - if (pSinkInfo->description != NULL) { - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), pSinkInfo->description, (size_t)-1); - } - - if (pSinkInfo->index == pData->defaultDeviceIndexPlayback) { - deviceInfo.isDefault = MA_TRUE; - } - - pData->isTerminated = !pData->callback(pData->pContext, ma_device_type_playback, &deviceInfo, pData->pUserData); - - (void)pPulseContext; /* Unused. */ -} - -static void ma_context_enumerate_devices_source_callback__pulse(ma_pa_context* pPulseContext, const ma_pa_source_info* pSourceInfo, int endOfList, void* pUserData) -{ - ma_context_enumerate_devices_callback_data__pulse* pData = (ma_context_enumerate_devices_callback_data__pulse*)pUserData; - ma_device_info deviceInfo; - - MA_ASSERT(pData != NULL); - - if (endOfList || pData->isTerminated) { - return; - } - - MA_ZERO_OBJECT(&deviceInfo); - - /* The name from PulseAudio is the ID for miniaudio. */ - if (pSourceInfo->name != NULL) { - ma_strncpy_s(deviceInfo.id.pulse, sizeof(deviceInfo.id.pulse), pSourceInfo->name, (size_t)-1); - } - - /* The description from PulseAudio is the name for miniaudio. */ - if (pSourceInfo->description != NULL) { - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), pSourceInfo->description, (size_t)-1); - } - - if (pSourceInfo->index == pData->defaultDeviceIndexCapture) { - deviceInfo.isDefault = MA_TRUE; - } - - pData->isTerminated = !pData->callback(pData->pContext, ma_device_type_capture, &deviceInfo, pData->pUserData); - - (void)pPulseContext; /* Unused. */ -} - -static ma_result ma_context_enumerate_devices__pulse(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_result result = MA_SUCCESS; - ma_context_enumerate_devices_callback_data__pulse callbackData; - ma_pa_operation* pOP = NULL; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - callbackData.pContext = pContext; - callbackData.callback = callback; - callbackData.pUserData = pUserData; - callbackData.isTerminated = MA_FALSE; - callbackData.defaultDeviceIndexPlayback = (ma_uint32)-1; - callbackData.defaultDeviceIndexCapture = (ma_uint32)-1; - - /* We need to get the index of the default devices. */ - ma_context_get_default_device_index__pulse(pContext, ma_device_type_playback, &callbackData.defaultDeviceIndexPlayback); - ma_context_get_default_device_index__pulse(pContext, ma_device_type_capture, &callbackData.defaultDeviceIndexCapture); - - /* Playback. */ - if (!callbackData.isTerminated) { - pOP = ((ma_pa_context_get_sink_info_list_proc)pContext->pulse.pa_context_get_sink_info_list)((ma_pa_context*)(pContext->pulse.pPulseContext), ma_context_enumerate_devices_sink_callback__pulse, &callbackData); - if (pOP == NULL) { - result = MA_ERROR; - goto done; - } - - result = ma_wait_for_operation__pulse(pContext, pContext->pulse.pMainLoop, pOP); - ((ma_pa_operation_unref_proc)pContext->pulse.pa_operation_unref)(pOP); - - if (result != MA_SUCCESS) { - goto done; - } - } - - - /* Capture. */ - if (!callbackData.isTerminated) { - pOP = ((ma_pa_context_get_source_info_list_proc)pContext->pulse.pa_context_get_source_info_list)((ma_pa_context*)(pContext->pulse.pPulseContext), ma_context_enumerate_devices_source_callback__pulse, &callbackData); - if (pOP == NULL) { - result = MA_ERROR; - goto done; - } - - result = ma_wait_for_operation__pulse(pContext, pContext->pulse.pMainLoop, pOP); - ((ma_pa_operation_unref_proc)pContext->pulse.pa_operation_unref)(pOP); - - if (result != MA_SUCCESS) { - goto done; - } - } - -done: - return result; -} - - -typedef struct -{ - ma_device_info* pDeviceInfo; - ma_uint32 defaultDeviceIndex; - ma_bool32 foundDevice; -} ma_context_get_device_info_callback_data__pulse; - -static void ma_context_get_device_info_sink_callback__pulse(ma_pa_context* pPulseContext, const ma_pa_sink_info* pInfo, int endOfList, void* pUserData) -{ - ma_context_get_device_info_callback_data__pulse* pData = (ma_context_get_device_info_callback_data__pulse*)pUserData; - - if (endOfList > 0) { - return; - } - - MA_ASSERT(pData != NULL); - pData->foundDevice = MA_TRUE; - - if (pInfo->name != NULL) { - ma_strncpy_s(pData->pDeviceInfo->id.pulse, sizeof(pData->pDeviceInfo->id.pulse), pInfo->name, (size_t)-1); - } - - if (pInfo->description != NULL) { - ma_strncpy_s(pData->pDeviceInfo->name, sizeof(pData->pDeviceInfo->name), pInfo->description, (size_t)-1); - } - - /* - We're just reporting a single data format here. I think technically PulseAudio might support - all formats, but I don't trust that PulseAudio will do *anything* right, so I'm just going to - report the "native" device format. - */ - pData->pDeviceInfo->nativeDataFormats[0].format = ma_format_from_pulse(pInfo->sample_spec.format); - pData->pDeviceInfo->nativeDataFormats[0].channels = pInfo->sample_spec.channels; - pData->pDeviceInfo->nativeDataFormats[0].sampleRate = pInfo->sample_spec.rate; - pData->pDeviceInfo->nativeDataFormats[0].flags = 0; - pData->pDeviceInfo->nativeDataFormatCount = 1; - - if (pData->defaultDeviceIndex == pInfo->index) { - pData->pDeviceInfo->isDefault = MA_TRUE; - } - - (void)pPulseContext; /* Unused. */ -} - -static void ma_context_get_device_info_source_callback__pulse(ma_pa_context* pPulseContext, const ma_pa_source_info* pInfo, int endOfList, void* pUserData) -{ - ma_context_get_device_info_callback_data__pulse* pData = (ma_context_get_device_info_callback_data__pulse*)pUserData; - - if (endOfList > 0) { - return; - } - - MA_ASSERT(pData != NULL); - pData->foundDevice = MA_TRUE; - - if (pInfo->name != NULL) { - ma_strncpy_s(pData->pDeviceInfo->id.pulse, sizeof(pData->pDeviceInfo->id.pulse), pInfo->name, (size_t)-1); - } - - if (pInfo->description != NULL) { - ma_strncpy_s(pData->pDeviceInfo->name, sizeof(pData->pDeviceInfo->name), pInfo->description, (size_t)-1); - } - - /* - We're just reporting a single data format here. I think technically PulseAudio might support - all formats, but I don't trust that PulseAudio will do *anything* right, so I'm just going to - report the "native" device format. - */ - pData->pDeviceInfo->nativeDataFormats[0].format = ma_format_from_pulse(pInfo->sample_spec.format); - pData->pDeviceInfo->nativeDataFormats[0].channels = pInfo->sample_spec.channels; - pData->pDeviceInfo->nativeDataFormats[0].sampleRate = pInfo->sample_spec.rate; - pData->pDeviceInfo->nativeDataFormats[0].flags = 0; - pData->pDeviceInfo->nativeDataFormatCount = 1; - - if (pData->defaultDeviceIndex == pInfo->index) { - pData->pDeviceInfo->isDefault = MA_TRUE; - } - - (void)pPulseContext; /* Unused. */ -} - -static ma_result ma_context_get_device_info__pulse(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_result result = MA_SUCCESS; - ma_context_get_device_info_callback_data__pulse callbackData; - ma_pa_operation* pOP = NULL; - const char* pDeviceName = NULL; - - MA_ASSERT(pContext != NULL); - - callbackData.pDeviceInfo = pDeviceInfo; - callbackData.foundDevice = MA_FALSE; - - if (pDeviceID != NULL) { - pDeviceName = pDeviceID->pulse; - } else { - pDeviceName = NULL; - } - - result = ma_context_get_default_device_index__pulse(pContext, deviceType, &callbackData.defaultDeviceIndex); - - if (deviceType == ma_device_type_playback) { - pOP = ((ma_pa_context_get_sink_info_by_name_proc)pContext->pulse.pa_context_get_sink_info_by_name)((ma_pa_context*)(pContext->pulse.pPulseContext), pDeviceName, ma_context_get_device_info_sink_callback__pulse, &callbackData); - } else { - pOP = ((ma_pa_context_get_source_info_by_name_proc)pContext->pulse.pa_context_get_source_info_by_name)((ma_pa_context*)(pContext->pulse.pPulseContext), pDeviceName, ma_context_get_device_info_source_callback__pulse, &callbackData); - } - - if (pOP != NULL) { - ma_wait_for_operation_and_unref__pulse(pContext, pContext->pulse.pMainLoop, pOP); - } else { - result = MA_ERROR; - goto done; - } - - if (!callbackData.foundDevice) { - result = MA_NO_DEVICE; - goto done; - } - -done: - return result; -} - -static ma_result ma_device_uninit__pulse(ma_device* pDevice) -{ - ma_context* pContext; - - MA_ASSERT(pDevice != NULL); - - pContext = pDevice->pContext; - MA_ASSERT(pContext != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ((ma_pa_stream_disconnect_proc)pContext->pulse.pa_stream_disconnect)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - ((ma_pa_stream_unref_proc)pContext->pulse.pa_stream_unref)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ((ma_pa_stream_disconnect_proc)pContext->pulse.pa_stream_disconnect)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - ((ma_pa_stream_unref_proc)pContext->pulse.pa_stream_unref)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - } - - if (pDevice->type == ma_device_type_duplex) { - ma_duplex_rb_uninit(&pDevice->duplexRB); - } - - ((ma_pa_context_disconnect_proc)pContext->pulse.pa_context_disconnect)((ma_pa_context*)pDevice->pulse.pPulseContext); - ((ma_pa_context_unref_proc)pContext->pulse.pa_context_unref)((ma_pa_context*)pDevice->pulse.pPulseContext); - ((ma_pa_mainloop_free_proc)pContext->pulse.pa_mainloop_free)((ma_pa_mainloop*)pDevice->pulse.pMainLoop); - - return MA_SUCCESS; -} - -static ma_pa_buffer_attr ma_device__pa_buffer_attr_new(ma_uint32 periodSizeInFrames, ma_uint32 periods, const ma_pa_sample_spec* ss) -{ - ma_pa_buffer_attr attr; - attr.maxlength = periodSizeInFrames * periods * ma_get_bytes_per_frame(ma_format_from_pulse(ss->format), ss->channels); - attr.tlength = attr.maxlength / periods; - attr.prebuf = (ma_uint32)-1; - attr.minreq = (ma_uint32)-1; - attr.fragsize = attr.maxlength / periods; - - return attr; -} - -static ma_pa_stream* ma_device__pa_stream_new__pulse(ma_device* pDevice, const char* pStreamName, const ma_pa_sample_spec* ss, const ma_pa_channel_map* cmap) -{ - static int g_StreamCounter = 0; - char actualStreamName[256]; - - if (pStreamName != NULL) { - ma_strncpy_s(actualStreamName, sizeof(actualStreamName), pStreamName, (size_t)-1); - } else { - ma_strcpy_s(actualStreamName, sizeof(actualStreamName), "miniaudio:"); - ma_itoa_s(g_StreamCounter, actualStreamName + 8, sizeof(actualStreamName)-8, 10); /* 8 = strlen("miniaudio:") */ - } - g_StreamCounter += 1; - - return ((ma_pa_stream_new_proc)pDevice->pContext->pulse.pa_stream_new)((ma_pa_context*)pDevice->pulse.pPulseContext, actualStreamName, ss, cmap); -} - - -static void ma_device_on_read__pulse(ma_pa_stream* pStream, size_t byteCount, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - ma_uint32 bpf; - ma_uint32 deviceState; - ma_uint64 frameCount; - ma_uint64 framesProcessed; - - MA_ASSERT(pDevice != NULL); - - /* - Don't do anything if the device isn't initialized yet. Yes, this can happen because PulseAudio - can fire this callback before the stream has even started. Ridiculous. - */ - deviceState = ma_device_get_state(pDevice); - if (deviceState != ma_device_state_starting && deviceState != ma_device_state_started) { - return; - } - - bpf = ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - MA_ASSERT(bpf > 0); - - frameCount = byteCount / bpf; - framesProcessed = 0; - - while (ma_device_get_state(pDevice) == ma_device_state_started && framesProcessed < frameCount) { - const void* pMappedPCMFrames; - size_t bytesMapped; - ma_uint64 framesMapped; - - int pulseResult = ((ma_pa_stream_peek_proc)pDevice->pContext->pulse.pa_stream_peek)(pStream, &pMappedPCMFrames, &bytesMapped); - if (pulseResult < 0) { - break; /* Failed to map. Abort. */ - } - - framesMapped = bytesMapped / bpf; - if (framesMapped > 0) { - if (pMappedPCMFrames != NULL) { - ma_device_handle_backend_data_callback(pDevice, NULL, pMappedPCMFrames, framesMapped); - } else { - /* It's a hole. */ - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[PulseAudio] ma_device_on_read__pulse: Hole.\n"); - } - - pulseResult = ((ma_pa_stream_drop_proc)pDevice->pContext->pulse.pa_stream_drop)(pStream); - if (pulseResult < 0) { - break; /* Failed to drop the buffer. */ - } - - framesProcessed += framesMapped; - - } else { - /* Nothing was mapped. Just abort. */ - break; - } - } -} - -static ma_result ma_device_write_to_stream__pulse(ma_device* pDevice, ma_pa_stream* pStream, ma_uint64* pFramesProcessed) -{ - ma_result result = MA_SUCCESS; - ma_uint64 framesProcessed = 0; - size_t bytesMapped; - ma_uint32 bpf; - ma_uint32 deviceState; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pStream != NULL); - - bpf = ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - MA_ASSERT(bpf > 0); - - deviceState = ma_device_get_state(pDevice); - - bytesMapped = ((ma_pa_stream_writable_size_proc)pDevice->pContext->pulse.pa_stream_writable_size)(pStream); - if (bytesMapped != (size_t)-1) { - if (bytesMapped > 0) { - ma_uint64 framesMapped; - void* pMappedPCMFrames; - int pulseResult = ((ma_pa_stream_begin_write_proc)pDevice->pContext->pulse.pa_stream_begin_write)(pStream, &pMappedPCMFrames, &bytesMapped); - if (pulseResult < 0) { - result = ma_result_from_pulse(pulseResult); - goto done; - } - - framesMapped = bytesMapped / bpf; - - if (deviceState == ma_device_state_started || deviceState == ma_device_state_starting) { /* Check for starting state just in case this is being used to do the initial fill. */ - ma_device_handle_backend_data_callback(pDevice, pMappedPCMFrames, NULL, framesMapped); - } else { - /* Device is not started. Write silence. */ - ma_silence_pcm_frames(pMappedPCMFrames, framesMapped, pDevice->playback.format, pDevice->playback.channels); - } - - pulseResult = ((ma_pa_stream_write_proc)pDevice->pContext->pulse.pa_stream_write)(pStream, pMappedPCMFrames, bytesMapped, NULL, 0, MA_PA_SEEK_RELATIVE); - if (pulseResult < 0) { - result = ma_result_from_pulse(pulseResult); - goto done; /* Failed to write data to stream. */ - } - - framesProcessed += framesMapped; - } else { - result = MA_SUCCESS; /* No data available for writing. */ - goto done; - } - } else { - result = MA_ERROR; /* Failed to retrieve the writable size. Abort. */ - goto done; - } - -done: - if (pFramesProcessed != NULL) { - *pFramesProcessed = framesProcessed; - } - - return result; -} - -static void ma_device_on_write__pulse(ma_pa_stream* pStream, size_t byteCount, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - ma_uint32 bpf; - ma_uint64 frameCount; - ma_uint64 framesProcessed; - ma_uint32 deviceState; - ma_result result; - - MA_ASSERT(pDevice != NULL); - - /* - Don't do anything if the device isn't initialized yet. Yes, this can happen because PulseAudio - can fire this callback before the stream has even started. Ridiculous. - */ - deviceState = ma_device_get_state(pDevice); - if (deviceState != ma_device_state_starting && deviceState != ma_device_state_started) { - return; - } - - bpf = ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - MA_ASSERT(bpf > 0); - - frameCount = byteCount / bpf; - framesProcessed = 0; - - while (framesProcessed < frameCount) { - ma_uint64 framesProcessedThisIteration; - - /* Don't keep trying to process frames if the device isn't started. */ - deviceState = ma_device_get_state(pDevice); - if (deviceState != ma_device_state_starting && deviceState != ma_device_state_started) { - break; - } - - result = ma_device_write_to_stream__pulse(pDevice, pStream, &framesProcessedThisIteration); - if (result != MA_SUCCESS) { - break; - } - - framesProcessed += framesProcessedThisIteration; - } -} - -static void ma_device_on_suspended__pulse(ma_pa_stream* pStream, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - int suspended; - - (void)pStream; - - suspended = ((ma_pa_stream_is_suspended_proc)pDevice->pContext->pulse.pa_stream_is_suspended)(pStream); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[Pulse] Device suspended state changed. pa_stream_is_suspended() returned %d.\n", suspended); - - if (suspended < 0) { - return; - } - - if (suspended == 1) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[Pulse] Device suspended state changed. Suspended.\n"); - ma_device__on_notification_stopped(pDevice); - } else { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "[Pulse] Device suspended state changed. Resumed.\n"); - ma_device__on_notification_started(pDevice); - } -} - -static void ma_device_on_rerouted__pulse(ma_pa_stream* pStream, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - - (void)pStream; - (void)pUserData; - - ma_device__on_notification_rerouted(pDevice); -} - -static ma_uint32 ma_calculate_period_size_in_frames_from_descriptor__pulse(const ma_device_descriptor* pDescriptor, ma_uint32 nativeSampleRate, ma_performance_profile performanceProfile) -{ - /* - There have been reports from users where buffers of < ~20ms result glitches when running through - PipeWire. To work around this we're going to have to use a different default buffer size. - */ - const ma_uint32 defaultPeriodSizeInMilliseconds_LowLatency = 25; - const ma_uint32 defaultPeriodSizeInMilliseconds_Conservative = MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE; - - MA_ASSERT(nativeSampleRate != 0); - - if (pDescriptor->periodSizeInFrames == 0) { - if (pDescriptor->periodSizeInMilliseconds == 0) { - if (performanceProfile == ma_performance_profile_low_latency) { - return ma_calculate_buffer_size_in_frames_from_milliseconds(defaultPeriodSizeInMilliseconds_LowLatency, nativeSampleRate); - } else { - return ma_calculate_buffer_size_in_frames_from_milliseconds(defaultPeriodSizeInMilliseconds_Conservative, nativeSampleRate); - } - } else { - return ma_calculate_buffer_size_in_frames_from_milliseconds(pDescriptor->periodSizeInMilliseconds, nativeSampleRate); - } - } else { - return pDescriptor->periodSizeInFrames; - } -} - -static ma_result ma_device_init__pulse(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - /* - Notes for PulseAudio: - - - We're always using native format/channels/rate regardless of whether or not PulseAudio - supports the format directly through their own data conversion system. I'm doing this to - reduce as much variability from the PulseAudio side as possible because it's seems to be - extremely unreliable at everything it does. - - - When both the period size in frames and milliseconds are 0, we default to miniaudio's - default buffer sizes rather than leaving it up to PulseAudio because I don't trust - PulseAudio to give us any kind of reasonable latency by default. - - - Do not ever, *ever* forget to use MA_PA_STREAM_ADJUST_LATENCY. If you don't specify this - flag, capture mode will just not work properly until you open another PulseAudio app. - */ - - ma_result result = MA_SUCCESS; - int error = 0; - const char* devPlayback = NULL; - const char* devCapture = NULL; - ma_format format = ma_format_unknown; - ma_uint32 channels = 0; - ma_uint32 sampleRate = 0; - ma_pa_sink_info sinkInfo; - ma_pa_source_info sourceInfo; - ma_pa_sample_spec ss; - ma_pa_channel_map cmap; - ma_pa_buffer_attr attr; - const ma_pa_sample_spec* pActualSS = NULL; - const ma_pa_channel_map* pActualCMap = NULL; - const ma_pa_buffer_attr* pActualAttr = NULL; - ma_uint32 iChannel; - ma_pa_stream_flags_t streamFlags; - - MA_ASSERT(pDevice != NULL); - MA_ZERO_OBJECT(&pDevice->pulse); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* No exclusive mode with the PulseAudio backend. */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pConfig->playback.shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pConfig->capture.shareMode == ma_share_mode_exclusive)) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - if (pDescriptorPlayback->pDeviceID != NULL) { - devPlayback = pDescriptorPlayback->pDeviceID->pulse; - } - - format = pDescriptorPlayback->format; - channels = pDescriptorPlayback->channels; - sampleRate = pDescriptorPlayback->sampleRate; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - if (pDescriptorCapture->pDeviceID != NULL) { - devCapture = pDescriptorCapture->pDeviceID->pulse; - } - - format = pDescriptorCapture->format; - channels = pDescriptorCapture->channels; - sampleRate = pDescriptorCapture->sampleRate; - } - - - - result = ma_init_pa_mainloop_and_pa_context__pulse(pDevice->pContext, pDevice->pContext->pulse.pApplicationName, pDevice->pContext->pulse.pServerName, MA_FALSE, &pDevice->pulse.pMainLoop, &pDevice->pulse.pPulseContext); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to initialize PA mainloop and context for device.\n"); - return result; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - result = ma_context_get_source_info__pulse(pDevice->pContext, devCapture, &sourceInfo); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to retrieve source info for capture device."); - goto on_error0; - } - - ss = sourceInfo.sample_spec; - cmap = sourceInfo.channel_map; - - /* Use the requested sample rate if one was specified. */ - if (pDescriptorCapture->sampleRate != 0) { - ss.rate = pDescriptorCapture->sampleRate; - } - - if (ma_format_from_pulse(ss.format) == ma_format_unknown) { - if (ma_is_little_endian()) { - ss.format = MA_PA_SAMPLE_FLOAT32LE; - } else { - ss.format = MA_PA_SAMPLE_FLOAT32BE; - } - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] sample_spec.format not supported by miniaudio. Defaulting to PA_SAMPLE_FLOAT32.\n"); - } - if (ss.rate == 0) { - ss.rate = MA_DEFAULT_SAMPLE_RATE; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] sample_spec.rate = 0. Defaulting to %d.\n", ss.rate); - } - if (ss.channels == 0) { - ss.channels = MA_DEFAULT_CHANNELS; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] sample_spec.channels = 0. Defaulting to %d.\n", ss.channels); - } - - /* We now have enough information to calculate our actual period size in frames. */ - pDescriptorCapture->periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__pulse(pDescriptorCapture, ss.rate, pConfig->performanceProfile); - - attr = ma_device__pa_buffer_attr_new(pDescriptorCapture->periodSizeInFrames, pDescriptorCapture->periodCount, &ss); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Capture attr: maxlength=%d, tlength=%d, prebuf=%d, minreq=%d, fragsize=%d; periodSizeInFrames=%d\n", attr.maxlength, attr.tlength, attr.prebuf, attr.minreq, attr.fragsize, pDescriptorCapture->periodSizeInFrames); - - pDevice->pulse.pStreamCapture = ma_device__pa_stream_new__pulse(pDevice, pConfig->pulse.pStreamNameCapture, &ss, &cmap); - if (pDevice->pulse.pStreamCapture == NULL) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to create PulseAudio capture stream.\n"); - result = MA_ERROR; - goto on_error0; - } - - - /* The callback needs to be set before connecting the stream. */ - ((ma_pa_stream_set_read_callback_proc)pDevice->pContext->pulse.pa_stream_set_read_callback)((ma_pa_stream*)pDevice->pulse.pStreamCapture, ma_device_on_read__pulse, pDevice); - - /* State callback for checking when the device has been corked. */ - ((ma_pa_stream_set_suspended_callback_proc)pDevice->pContext->pulse.pa_stream_set_suspended_callback)((ma_pa_stream*)pDevice->pulse.pStreamCapture, ma_device_on_suspended__pulse, pDevice); - - /* Rerouting notification. */ - ((ma_pa_stream_set_moved_callback_proc)pDevice->pContext->pulse.pa_stream_set_moved_callback)((ma_pa_stream*)pDevice->pulse.pStreamCapture, ma_device_on_rerouted__pulse, pDevice); - - - /* Connect after we've got all of our internal state set up. */ - streamFlags = MA_PA_STREAM_START_CORKED | MA_PA_STREAM_ADJUST_LATENCY | MA_PA_STREAM_FIX_FORMAT | MA_PA_STREAM_FIX_RATE | MA_PA_STREAM_FIX_CHANNELS; - if (devCapture != NULL) { - streamFlags |= MA_PA_STREAM_DONT_MOVE; - } - - error = ((ma_pa_stream_connect_record_proc)pDevice->pContext->pulse.pa_stream_connect_record)((ma_pa_stream*)pDevice->pulse.pStreamCapture, devCapture, &attr, streamFlags); - if (error != MA_PA_OK) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to connect PulseAudio capture stream."); - result = ma_result_from_pulse(error); - goto on_error1; - } - - result = ma_wait_for_pa_stream_to_connect__pulse(pDevice->pContext, pDevice->pulse.pMainLoop, (ma_pa_stream*)pDevice->pulse.pStreamCapture); - if (result != MA_SUCCESS) { - goto on_error2; - } - - - /* Internal format. */ - pActualSS = ((ma_pa_stream_get_sample_spec_proc)pDevice->pContext->pulse.pa_stream_get_sample_spec)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - if (pActualSS != NULL) { - ss = *pActualSS; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Capture sample spec: format=%s, channels=%d, rate=%d\n", ma_get_format_name(ma_format_from_pulse(ss.format)), ss.channels, ss.rate); - } else { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Failed to retrieve capture sample spec.\n"); - } - - pDescriptorCapture->format = ma_format_from_pulse(ss.format); - pDescriptorCapture->channels = ss.channels; - pDescriptorCapture->sampleRate = ss.rate; - - if (pDescriptorCapture->format == ma_format_unknown || pDescriptorCapture->channels == 0 || pDescriptorCapture->sampleRate == 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Capture sample spec is invalid. Device unusable by miniaudio. format=%s, channels=%d, sampleRate=%d.\n", ma_get_format_name(pDescriptorCapture->format), pDescriptorCapture->channels, pDescriptorCapture->sampleRate); - result = MA_ERROR; - goto on_error4; - } - - /* Internal channel map. */ - - /* - Bug in PipeWire. There have been reports that PipeWire is returning AUX channels when reporting - the channel map. To somewhat workaround this, I'm hacking in a hard coded channel map for mono - and stereo. In this case it should be safe to assume mono = MONO and stereo = LEFT/RIGHT. For - all other channel counts we need to just put up with whatever PipeWire reports and hope it gets - fixed sooner than later. I might remove this hack later. - */ - if (pDescriptorCapture->channels > 2) { - pActualCMap = ((ma_pa_stream_get_channel_map_proc)pDevice->pContext->pulse.pa_stream_get_channel_map)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - if (pActualCMap != NULL) { - cmap = *pActualCMap; - } - - for (iChannel = 0; iChannel < pDescriptorCapture->channels; ++iChannel) { - pDescriptorCapture->channelMap[iChannel] = ma_channel_position_from_pulse(cmap.map[iChannel]); - } - } else { - /* Hack for mono and stereo. */ - if (pDescriptorCapture->channels == 1) { - pDescriptorCapture->channelMap[0] = MA_CHANNEL_MONO; - } else if (pDescriptorCapture->channels == 2) { - pDescriptorCapture->channelMap[0] = MA_CHANNEL_FRONT_LEFT; - pDescriptorCapture->channelMap[1] = MA_CHANNEL_FRONT_RIGHT; - } else { - MA_ASSERT(MA_FALSE); /* Should never hit this. */ - } - } - - - /* Buffer. */ - pActualAttr = ((ma_pa_stream_get_buffer_attr_proc)pDevice->pContext->pulse.pa_stream_get_buffer_attr)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - if (pActualAttr != NULL) { - attr = *pActualAttr; - } - - if (attr.fragsize > 0) { - pDescriptorCapture->periodCount = ma_max(attr.maxlength / attr.fragsize, 1); - } else { - pDescriptorCapture->periodCount = 1; - } - - pDescriptorCapture->periodSizeInFrames = attr.maxlength / ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels) / pDescriptorCapture->periodCount; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Capture actual attr: maxlength=%d, tlength=%d, prebuf=%d, minreq=%d, fragsize=%d; periodSizeInFrames=%d\n", attr.maxlength, attr.tlength, attr.prebuf, attr.minreq, attr.fragsize, pDescriptorCapture->periodSizeInFrames); - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - result = ma_context_get_sink_info__pulse(pDevice->pContext, devPlayback, &sinkInfo); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to retrieve sink info for playback device.\n"); - goto on_error2; - } - - ss = sinkInfo.sample_spec; - cmap = sinkInfo.channel_map; - - /* Use the requested sample rate if one was specified. */ - if (pDescriptorPlayback->sampleRate != 0) { - ss.rate = pDescriptorPlayback->sampleRate; - } - - if (ma_format_from_pulse(ss.format) == ma_format_unknown) { - if (ma_is_little_endian()) { - ss.format = MA_PA_SAMPLE_FLOAT32LE; - } else { - ss.format = MA_PA_SAMPLE_FLOAT32BE; - } - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] sample_spec.format not supported by miniaudio. Defaulting to PA_SAMPLE_FLOAT32.\n"); - } - if (ss.rate == 0) { - ss.rate = MA_DEFAULT_SAMPLE_RATE; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] sample_spec.rate = 0. Defaulting to %d.\n", ss.rate); - } - if (ss.channels == 0) { - ss.channels = MA_DEFAULT_CHANNELS; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] sample_spec.channels = 0. Defaulting to %d.\n", ss.channels); - } - - /* We now have enough information to calculate the actual buffer size in frames. */ - pDescriptorPlayback->periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__pulse(pDescriptorPlayback, ss.rate, pConfig->performanceProfile); - - attr = ma_device__pa_buffer_attr_new(pDescriptorPlayback->periodSizeInFrames, pDescriptorPlayback->periodCount, &ss); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Playback attr: maxlength=%d, tlength=%d, prebuf=%d, minreq=%d, fragsize=%d; periodSizeInFrames=%d\n", attr.maxlength, attr.tlength, attr.prebuf, attr.minreq, attr.fragsize, pDescriptorPlayback->periodSizeInFrames); - - pDevice->pulse.pStreamPlayback = ma_device__pa_stream_new__pulse(pDevice, pConfig->pulse.pStreamNamePlayback, &ss, &cmap); - if (pDevice->pulse.pStreamPlayback == NULL) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to create PulseAudio playback stream.\n"); - result = MA_ERROR; - goto on_error2; - } - - - /* - Note that this callback will be fired as soon as the stream is connected, even though it's started as corked. The callback needs to handle a - device state of ma_device_state_uninitialized. - */ - ((ma_pa_stream_set_write_callback_proc)pDevice->pContext->pulse.pa_stream_set_write_callback)((ma_pa_stream*)pDevice->pulse.pStreamPlayback, ma_device_on_write__pulse, pDevice); - - /* State callback for checking when the device has been corked. */ - ((ma_pa_stream_set_suspended_callback_proc)pDevice->pContext->pulse.pa_stream_set_suspended_callback)((ma_pa_stream*)pDevice->pulse.pStreamPlayback, ma_device_on_suspended__pulse, pDevice); - - /* Rerouting notification. */ - ((ma_pa_stream_set_moved_callback_proc)pDevice->pContext->pulse.pa_stream_set_moved_callback)((ma_pa_stream*)pDevice->pulse.pStreamPlayback, ma_device_on_rerouted__pulse, pDevice); - - - /* Connect after we've got all of our internal state set up. */ - streamFlags = MA_PA_STREAM_START_CORKED | MA_PA_STREAM_ADJUST_LATENCY | MA_PA_STREAM_FIX_FORMAT | MA_PA_STREAM_FIX_RATE | MA_PA_STREAM_FIX_CHANNELS; - if (devPlayback != NULL) { - streamFlags |= MA_PA_STREAM_DONT_MOVE; - } - - error = ((ma_pa_stream_connect_playback_proc)pDevice->pContext->pulse.pa_stream_connect_playback)((ma_pa_stream*)pDevice->pulse.pStreamPlayback, devPlayback, &attr, streamFlags, NULL, NULL); - if (error != MA_PA_OK) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to connect PulseAudio playback stream."); - result = ma_result_from_pulse(error); - goto on_error3; - } - - result = ma_wait_for_pa_stream_to_connect__pulse(pDevice->pContext, pDevice->pulse.pMainLoop, (ma_pa_stream*)pDevice->pulse.pStreamPlayback); - if (result != MA_SUCCESS) { - goto on_error3; - } - - - /* Internal format. */ - pActualSS = ((ma_pa_stream_get_sample_spec_proc)pDevice->pContext->pulse.pa_stream_get_sample_spec)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - if (pActualSS != NULL) { - ss = *pActualSS; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Playback sample spec: format=%s, channels=%d, rate=%d\n", ma_get_format_name(ma_format_from_pulse(ss.format)), ss.channels, ss.rate); - } else { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Failed to retrieve playback sample spec.\n"); - } - - pDescriptorPlayback->format = ma_format_from_pulse(ss.format); - pDescriptorPlayback->channels = ss.channels; - pDescriptorPlayback->sampleRate = ss.rate; - - if (pDescriptorPlayback->format == ma_format_unknown || pDescriptorPlayback->channels == 0 || pDescriptorPlayback->sampleRate == 0) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Playback sample spec is invalid. Device unusable by miniaudio. format=%s, channels=%d, sampleRate=%d.\n", ma_get_format_name(pDescriptorPlayback->format), pDescriptorPlayback->channels, pDescriptorPlayback->sampleRate); - result = MA_ERROR; - goto on_error4; - } - - /* Internal channel map. */ - - /* - Bug in PipeWire. There have been reports that PipeWire is returning AUX channels when reporting - the channel map. To somewhat workaround this, I'm hacking in a hard coded channel map for mono - and stereo. In this case it should be safe to assume mono = MONO and stereo = LEFT/RIGHT. For - all other channel counts we need to just put up with whatever PipeWire reports and hope it gets - fixed sooner than later. I might remove this hack later. - */ - if (pDescriptorPlayback->channels > 2) { - pActualCMap = ((ma_pa_stream_get_channel_map_proc)pDevice->pContext->pulse.pa_stream_get_channel_map)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - if (pActualCMap != NULL) { - cmap = *pActualCMap; - } - - for (iChannel = 0; iChannel < pDescriptorPlayback->channels; ++iChannel) { - pDescriptorPlayback->channelMap[iChannel] = ma_channel_position_from_pulse(cmap.map[iChannel]); - } - } else { - /* Hack for mono and stereo. */ - if (pDescriptorPlayback->channels == 1) { - pDescriptorPlayback->channelMap[0] = MA_CHANNEL_MONO; - } else if (pDescriptorPlayback->channels == 2) { - pDescriptorPlayback->channelMap[0] = MA_CHANNEL_FRONT_LEFT; - pDescriptorPlayback->channelMap[1] = MA_CHANNEL_FRONT_RIGHT; - } else { - MA_ASSERT(MA_FALSE); /* Should never hit this. */ - } - } - - - /* Buffer. */ - pActualAttr = ((ma_pa_stream_get_buffer_attr_proc)pDevice->pContext->pulse.pa_stream_get_buffer_attr)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - if (pActualAttr != NULL) { - attr = *pActualAttr; - } - - if (attr.tlength > 0) { - pDescriptorPlayback->periodCount = ma_max(attr.maxlength / attr.tlength, 1); - } else { - pDescriptorPlayback->periodCount = 1; - } - - pDescriptorPlayback->periodSizeInFrames = attr.maxlength / ma_get_bytes_per_frame(pDescriptorPlayback->format, pDescriptorPlayback->channels) / pDescriptorPlayback->periodCount; - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[PulseAudio] Playback actual attr: maxlength=%d, tlength=%d, prebuf=%d, minreq=%d, fragsize=%d; internalPeriodSizeInFrames=%d\n", attr.maxlength, attr.tlength, attr.prebuf, attr.minreq, attr.fragsize, pDescriptorPlayback->periodSizeInFrames); - } - - - /* - We need a ring buffer for handling duplex mode. We can use the main duplex ring buffer in the main - part of the ma_device struct. We cannot, however, depend on ma_device_init() initializing this for - us later on because that will only do it if it's a fully asynchronous backend - i.e. the - onDeviceDataLoop callback is NULL, which is not the case for PulseAudio. - */ - if (pConfig->deviceType == ma_device_type_duplex) { - ma_format rbFormat = (format != ma_format_unknown) ? format : pDescriptorCapture->format; - ma_uint32 rbChannels = (channels > 0) ? channels : pDescriptorCapture->channels; - ma_uint32 rbSampleRate = (sampleRate > 0) ? sampleRate : pDescriptorCapture->sampleRate; - - result = ma_duplex_rb_init(rbFormat, rbChannels, rbSampleRate, pDescriptorCapture->sampleRate, pDescriptorCapture->periodSizeInFrames, &pDevice->pContext->allocationCallbacks, &pDevice->duplexRB); - if (result != MA_SUCCESS) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to initialize ring buffer. %s.\n", ma_result_description(result)); - goto on_error4; - } - } - - return MA_SUCCESS; - - -on_error4: - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ((ma_pa_stream_disconnect_proc)pDevice->pContext->pulse.pa_stream_disconnect)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - } -on_error3: - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ((ma_pa_stream_unref_proc)pDevice->pContext->pulse.pa_stream_unref)((ma_pa_stream*)pDevice->pulse.pStreamPlayback); - } -on_error2: - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ((ma_pa_stream_disconnect_proc)pDevice->pContext->pulse.pa_stream_disconnect)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - } -on_error1: - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ((ma_pa_stream_unref_proc)pDevice->pContext->pulse.pa_stream_unref)((ma_pa_stream*)pDevice->pulse.pStreamCapture); - } -on_error0: - return result; -} - - -static void ma_pulse_operation_complete_callback(ma_pa_stream* pStream, int success, void* pUserData) -{ - ma_bool32* pIsSuccessful = (ma_bool32*)pUserData; - MA_ASSERT(pIsSuccessful != NULL); - - *pIsSuccessful = (ma_bool32)success; - - (void)pStream; /* Unused. */ -} - -static ma_result ma_device__cork_stream__pulse(ma_device* pDevice, ma_device_type deviceType, int cork) -{ - ma_context* pContext = pDevice->pContext; - ma_bool32 wasSuccessful; - ma_pa_stream* pStream; - ma_pa_operation* pOP; - ma_result result; - - /* This should not be called with a duplex device type. */ - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - wasSuccessful = MA_FALSE; - - pStream = (ma_pa_stream*)((deviceType == ma_device_type_capture) ? pDevice->pulse.pStreamCapture : pDevice->pulse.pStreamPlayback); - MA_ASSERT(pStream != NULL); - - pOP = ((ma_pa_stream_cork_proc)pContext->pulse.pa_stream_cork)(pStream, cork, ma_pulse_operation_complete_callback, &wasSuccessful); - if (pOP == NULL) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to cork PulseAudio stream."); - return MA_ERROR; - } - - result = ma_wait_for_operation_and_unref__pulse(pDevice->pContext, pDevice->pulse.pMainLoop, pOP); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] An error occurred while waiting for the PulseAudio stream to cork."); - return result; - } - - if (!wasSuccessful) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[PulseAudio] Failed to %s PulseAudio stream.", (cork) ? "stop" : "start"); - return MA_ERROR; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__pulse(ma_device* pDevice) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - result = ma_device__cork_stream__pulse(pDevice, ma_device_type_capture, 0); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - /* - We need to fill some data before uncorking. Not doing this will result in the write callback - never getting fired. We're not going to abort if writing fails because I still want the device - to get uncorked. - */ - ma_device_write_to_stream__pulse(pDevice, (ma_pa_stream*)(pDevice->pulse.pStreamPlayback), NULL); /* No need to check the result here. Always want to fall through an uncork.*/ - - result = ma_device__cork_stream__pulse(pDevice, ma_device_type_playback, 0); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__pulse(ma_device* pDevice) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - result = ma_device__cork_stream__pulse(pDevice, ma_device_type_capture, 1); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - /* - Ideally we would drain the device here, but there's been cases where PulseAudio seems to be - broken on some systems to the point where no audio processing seems to happen. When this - happens, draining never completes and we get stuck here. For now I'm disabling draining of - the device so we don't just freeze the application. - */ - #if 0 - ma_pa_operation* pOP = ((ma_pa_stream_drain_proc)pDevice->pContext->pulse.pa_stream_drain)((ma_pa_stream*)pDevice->pulse.pStreamPlayback, ma_pulse_operation_complete_callback, &wasSuccessful); - ma_wait_for_operation_and_unref__pulse(pDevice->pContext, pDevice->pulse.pMainLoop, pOP); - #endif - - result = ma_device__cork_stream__pulse(pDevice, ma_device_type_playback, 1); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_data_loop__pulse(ma_device* pDevice) -{ - int resultPA; - - MA_ASSERT(pDevice != NULL); - - /* NOTE: Don't start the device here. It'll be done at a higher level. */ - - /* - All data is handled through callbacks. All we need to do is iterate over the main loop and let - the callbacks deal with it. - */ - while (ma_device_get_state(pDevice) == ma_device_state_started) { - resultPA = ((ma_pa_mainloop_iterate_proc)pDevice->pContext->pulse.pa_mainloop_iterate)((ma_pa_mainloop*)pDevice->pulse.pMainLoop, 1, NULL); - if (resultPA < 0) { - break; - } - } - - /* NOTE: Don't stop the device here. It'll be done at a higher level. */ - return MA_SUCCESS; -} - -static ma_result ma_device_data_loop_wakeup__pulse(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - ((ma_pa_mainloop_wakeup_proc)pDevice->pContext->pulse.pa_mainloop_wakeup)((ma_pa_mainloop*)pDevice->pulse.pMainLoop); - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__pulse(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_pulseaudio); - - ((ma_pa_context_disconnect_proc)pContext->pulse.pa_context_disconnect)((ma_pa_context*)pContext->pulse.pPulseContext); - ((ma_pa_context_unref_proc)pContext->pulse.pa_context_unref)((ma_pa_context*)pContext->pulse.pPulseContext); - ((ma_pa_mainloop_free_proc)pContext->pulse.pa_mainloop_free)((ma_pa_mainloop*)pContext->pulse.pMainLoop); - - ma_free(pContext->pulse.pServerName, &pContext->allocationCallbacks); - ma_free(pContext->pulse.pApplicationName, &pContext->allocationCallbacks); - -#ifndef MA_NO_RUNTIME_LINKING - ma_dlclose(pContext, pContext->pulse.pulseSO); -#endif - - return MA_SUCCESS; -} - -static ma_result ma_context_init__pulse(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - ma_result result; -#ifndef MA_NO_RUNTIME_LINKING - const char* libpulseNames[] = { - "libpulse.so", - "libpulse.so.0" - }; - size_t i; - - for (i = 0; i < ma_countof(libpulseNames); ++i) { - pContext->pulse.pulseSO = ma_dlopen(pContext, libpulseNames[i]); - if (pContext->pulse.pulseSO != NULL) { - break; - } - } - - if (pContext->pulse.pulseSO == NULL) { - return MA_NO_BACKEND; - } - - pContext->pulse.pa_mainloop_new = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_mainloop_new"); - pContext->pulse.pa_mainloop_free = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_mainloop_free"); - pContext->pulse.pa_mainloop_quit = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_mainloop_quit"); - pContext->pulse.pa_mainloop_get_api = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_mainloop_get_api"); - pContext->pulse.pa_mainloop_iterate = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_mainloop_iterate"); - pContext->pulse.pa_mainloop_wakeup = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_mainloop_wakeup"); - pContext->pulse.pa_threaded_mainloop_new = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_new"); - pContext->pulse.pa_threaded_mainloop_free = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_free"); - pContext->pulse.pa_threaded_mainloop_start = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_start"); - pContext->pulse.pa_threaded_mainloop_stop = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_stop"); - pContext->pulse.pa_threaded_mainloop_lock = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_lock"); - pContext->pulse.pa_threaded_mainloop_unlock = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_unlock"); - pContext->pulse.pa_threaded_mainloop_wait = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_wait"); - pContext->pulse.pa_threaded_mainloop_signal = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_signal"); - pContext->pulse.pa_threaded_mainloop_accept = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_accept"); - pContext->pulse.pa_threaded_mainloop_get_retval = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_get_retval"); - pContext->pulse.pa_threaded_mainloop_get_api = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_get_api"); - pContext->pulse.pa_threaded_mainloop_in_thread = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_in_thread"); - pContext->pulse.pa_threaded_mainloop_set_name = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_threaded_mainloop_set_name"); - pContext->pulse.pa_context_new = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_new"); - pContext->pulse.pa_context_unref = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_unref"); - pContext->pulse.pa_context_connect = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_connect"); - pContext->pulse.pa_context_disconnect = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_disconnect"); - pContext->pulse.pa_context_set_state_callback = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_set_state_callback"); - pContext->pulse.pa_context_get_state = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_get_state"); - pContext->pulse.pa_context_get_sink_info_list = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_get_sink_info_list"); - pContext->pulse.pa_context_get_source_info_list = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_get_source_info_list"); - pContext->pulse.pa_context_get_sink_info_by_name = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_get_sink_info_by_name"); - pContext->pulse.pa_context_get_source_info_by_name = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_context_get_source_info_by_name"); - pContext->pulse.pa_operation_unref = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_operation_unref"); - pContext->pulse.pa_operation_get_state = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_operation_get_state"); - pContext->pulse.pa_channel_map_init_extend = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_channel_map_init_extend"); - pContext->pulse.pa_channel_map_valid = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_channel_map_valid"); - pContext->pulse.pa_channel_map_compatible = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_channel_map_compatible"); - pContext->pulse.pa_stream_new = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_new"); - pContext->pulse.pa_stream_unref = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_unref"); - pContext->pulse.pa_stream_connect_playback = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_connect_playback"); - pContext->pulse.pa_stream_connect_record = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_connect_record"); - pContext->pulse.pa_stream_disconnect = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_disconnect"); - pContext->pulse.pa_stream_get_state = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_get_state"); - pContext->pulse.pa_stream_get_sample_spec = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_get_sample_spec"); - pContext->pulse.pa_stream_get_channel_map = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_get_channel_map"); - pContext->pulse.pa_stream_get_buffer_attr = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_get_buffer_attr"); - pContext->pulse.pa_stream_set_buffer_attr = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_set_buffer_attr"); - pContext->pulse.pa_stream_get_device_name = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_get_device_name"); - pContext->pulse.pa_stream_set_write_callback = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_set_write_callback"); - pContext->pulse.pa_stream_set_read_callback = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_set_read_callback"); - pContext->pulse.pa_stream_set_suspended_callback = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_set_suspended_callback"); - pContext->pulse.pa_stream_set_moved_callback = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_set_moved_callback"); - pContext->pulse.pa_stream_is_suspended = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_is_suspended"); - pContext->pulse.pa_stream_flush = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_flush"); - pContext->pulse.pa_stream_drain = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_drain"); - pContext->pulse.pa_stream_is_corked = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_is_corked"); - pContext->pulse.pa_stream_cork = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_cork"); - pContext->pulse.pa_stream_trigger = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_trigger"); - pContext->pulse.pa_stream_begin_write = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_begin_write"); - pContext->pulse.pa_stream_write = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_write"); - pContext->pulse.pa_stream_peek = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_peek"); - pContext->pulse.pa_stream_drop = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_drop"); - pContext->pulse.pa_stream_writable_size = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_writable_size"); - pContext->pulse.pa_stream_readable_size = (ma_proc)ma_dlsym(pContext, pContext->pulse.pulseSO, "pa_stream_readable_size"); -#else - /* This strange assignment system is just for type safety. */ - ma_pa_mainloop_new_proc _pa_mainloop_new = pa_mainloop_new; - ma_pa_mainloop_free_proc _pa_mainloop_free = pa_mainloop_free; - ma_pa_mainloop_quit_proc _pa_mainloop_quit = pa_mainloop_quit; - ma_pa_mainloop_get_api_proc _pa_mainloop_get_api = pa_mainloop_get_api; - ma_pa_mainloop_iterate_proc _pa_mainloop_iterate = pa_mainloop_iterate; - ma_pa_mainloop_wakeup_proc _pa_mainloop_wakeup = pa_mainloop_wakeup; - ma_pa_threaded_mainloop_new_proc _pa_threaded_mainloop_new = pa_threaded_mainloop_new; - ma_pa_threaded_mainloop_free_proc _pa_threaded_mainloop_free = pa_threaded_mainloop_free; - ma_pa_threaded_mainloop_start_proc _pa_threaded_mainloop_start = pa_threaded_mainloop_start; - ma_pa_threaded_mainloop_stop_proc _pa_threaded_mainloop_stop = pa_threaded_mainloop_stop; - ma_pa_threaded_mainloop_lock_proc _pa_threaded_mainloop_lock = pa_threaded_mainloop_lock; - ma_pa_threaded_mainloop_unlock_proc _pa_threaded_mainloop_unlock = pa_threaded_mainloop_unlock; - ma_pa_threaded_mainloop_wait_proc _pa_threaded_mainloop_wait = pa_threaded_mainloop_wait; - ma_pa_threaded_mainloop_signal_proc _pa_threaded_mainloop_signal = pa_threaded_mainloop_signal; - ma_pa_threaded_mainloop_accept_proc _pa_threaded_mainloop_accept = pa_threaded_mainloop_accept; - ma_pa_threaded_mainloop_get_retval_proc _pa_threaded_mainloop_get_retval = pa_threaded_mainloop_get_retval; - ma_pa_threaded_mainloop_get_api_proc _pa_threaded_mainloop_get_api = pa_threaded_mainloop_get_api; - ma_pa_threaded_mainloop_in_thread_proc _pa_threaded_mainloop_in_thread = pa_threaded_mainloop_in_thread; - ma_pa_threaded_mainloop_set_name_proc _pa_threaded_mainloop_set_name = pa_threaded_mainloop_set_name; - ma_pa_context_new_proc _pa_context_new = pa_context_new; - ma_pa_context_unref_proc _pa_context_unref = pa_context_unref; - ma_pa_context_connect_proc _pa_context_connect = pa_context_connect; - ma_pa_context_disconnect_proc _pa_context_disconnect = pa_context_disconnect; - ma_pa_context_set_state_callback_proc _pa_context_set_state_callback = pa_context_set_state_callback; - ma_pa_context_get_state_proc _pa_context_get_state = pa_context_get_state; - ma_pa_context_get_sink_info_list_proc _pa_context_get_sink_info_list = pa_context_get_sink_info_list; - ma_pa_context_get_source_info_list_proc _pa_context_get_source_info_list = pa_context_get_source_info_list; - ma_pa_context_get_sink_info_by_name_proc _pa_context_get_sink_info_by_name = pa_context_get_sink_info_by_name; - ma_pa_context_get_source_info_by_name_proc _pa_context_get_source_info_by_name= pa_context_get_source_info_by_name; - ma_pa_operation_unref_proc _pa_operation_unref = pa_operation_unref; - ma_pa_operation_get_state_proc _pa_operation_get_state = pa_operation_get_state; - ma_pa_channel_map_init_extend_proc _pa_channel_map_init_extend = pa_channel_map_init_extend; - ma_pa_channel_map_valid_proc _pa_channel_map_valid = pa_channel_map_valid; - ma_pa_channel_map_compatible_proc _pa_channel_map_compatible = pa_channel_map_compatible; - ma_pa_stream_new_proc _pa_stream_new = pa_stream_new; - ma_pa_stream_unref_proc _pa_stream_unref = pa_stream_unref; - ma_pa_stream_connect_playback_proc _pa_stream_connect_playback = pa_stream_connect_playback; - ma_pa_stream_connect_record_proc _pa_stream_connect_record = pa_stream_connect_record; - ma_pa_stream_disconnect_proc _pa_stream_disconnect = pa_stream_disconnect; - ma_pa_stream_get_state_proc _pa_stream_get_state = pa_stream_get_state; - ma_pa_stream_get_sample_spec_proc _pa_stream_get_sample_spec = pa_stream_get_sample_spec; - ma_pa_stream_get_channel_map_proc _pa_stream_get_channel_map = pa_stream_get_channel_map; - ma_pa_stream_get_buffer_attr_proc _pa_stream_get_buffer_attr = pa_stream_get_buffer_attr; - ma_pa_stream_set_buffer_attr_proc _pa_stream_set_buffer_attr = pa_stream_set_buffer_attr; - ma_pa_stream_get_device_name_proc _pa_stream_get_device_name = pa_stream_get_device_name; - ma_pa_stream_set_write_callback_proc _pa_stream_set_write_callback = pa_stream_set_write_callback; - ma_pa_stream_set_read_callback_proc _pa_stream_set_read_callback = pa_stream_set_read_callback; - ma_pa_stream_set_suspended_callback_proc _pa_stream_set_suspended_callback = pa_stream_set_suspended_callback; - ma_pa_stream_set_moved_callback_proc _pa_stream_set_moved_callback = pa_stream_set_moved_callback; - ma_pa_stream_is_suspended_proc _pa_stream_is_suspended = pa_stream_is_suspended; - ma_pa_stream_flush_proc _pa_stream_flush = pa_stream_flush; - ma_pa_stream_drain_proc _pa_stream_drain = pa_stream_drain; - ma_pa_stream_is_corked_proc _pa_stream_is_corked = pa_stream_is_corked; - ma_pa_stream_cork_proc _pa_stream_cork = pa_stream_cork; - ma_pa_stream_trigger_proc _pa_stream_trigger = pa_stream_trigger; - ma_pa_stream_begin_write_proc _pa_stream_begin_write = pa_stream_begin_write; - ma_pa_stream_write_proc _pa_stream_write = pa_stream_write; - ma_pa_stream_peek_proc _pa_stream_peek = pa_stream_peek; - ma_pa_stream_drop_proc _pa_stream_drop = pa_stream_drop; - ma_pa_stream_writable_size_proc _pa_stream_writable_size = pa_stream_writable_size; - ma_pa_stream_readable_size_proc _pa_stream_readable_size = pa_stream_readable_size; - - pContext->pulse.pa_mainloop_new = (ma_proc)_pa_mainloop_new; - pContext->pulse.pa_mainloop_free = (ma_proc)_pa_mainloop_free; - pContext->pulse.pa_mainloop_quit = (ma_proc)_pa_mainloop_quit; - pContext->pulse.pa_mainloop_get_api = (ma_proc)_pa_mainloop_get_api; - pContext->pulse.pa_mainloop_iterate = (ma_proc)_pa_mainloop_iterate; - pContext->pulse.pa_mainloop_wakeup = (ma_proc)_pa_mainloop_wakeup; - pContext->pulse.pa_threaded_mainloop_new = (ma_proc)_pa_threaded_mainloop_new; - pContext->pulse.pa_threaded_mainloop_free = (ma_proc)_pa_threaded_mainloop_free; - pContext->pulse.pa_threaded_mainloop_start = (ma_proc)_pa_threaded_mainloop_start; - pContext->pulse.pa_threaded_mainloop_stop = (ma_proc)_pa_threaded_mainloop_stop; - pContext->pulse.pa_threaded_mainloop_lock = (ma_proc)_pa_threaded_mainloop_lock; - pContext->pulse.pa_threaded_mainloop_unlock = (ma_proc)_pa_threaded_mainloop_unlock; - pContext->pulse.pa_threaded_mainloop_wait = (ma_proc)_pa_threaded_mainloop_wait; - pContext->pulse.pa_threaded_mainloop_signal = (ma_proc)_pa_threaded_mainloop_signal; - pContext->pulse.pa_threaded_mainloop_accept = (ma_proc)_pa_threaded_mainloop_accept; - pContext->pulse.pa_threaded_mainloop_get_retval = (ma_proc)_pa_threaded_mainloop_get_retval; - pContext->pulse.pa_threaded_mainloop_get_api = (ma_proc)_pa_threaded_mainloop_get_api; - pContext->pulse.pa_threaded_mainloop_in_thread = (ma_proc)_pa_threaded_mainloop_in_thread; - pContext->pulse.pa_threaded_mainloop_set_name = (ma_proc)_pa_threaded_mainloop_set_name; - pContext->pulse.pa_context_new = (ma_proc)_pa_context_new; - pContext->pulse.pa_context_unref = (ma_proc)_pa_context_unref; - pContext->pulse.pa_context_connect = (ma_proc)_pa_context_connect; - pContext->pulse.pa_context_disconnect = (ma_proc)_pa_context_disconnect; - pContext->pulse.pa_context_set_state_callback = (ma_proc)_pa_context_set_state_callback; - pContext->pulse.pa_context_get_state = (ma_proc)_pa_context_get_state; - pContext->pulse.pa_context_get_sink_info_list = (ma_proc)_pa_context_get_sink_info_list; - pContext->pulse.pa_context_get_source_info_list = (ma_proc)_pa_context_get_source_info_list; - pContext->pulse.pa_context_get_sink_info_by_name = (ma_proc)_pa_context_get_sink_info_by_name; - pContext->pulse.pa_context_get_source_info_by_name = (ma_proc)_pa_context_get_source_info_by_name; - pContext->pulse.pa_operation_unref = (ma_proc)_pa_operation_unref; - pContext->pulse.pa_operation_get_state = (ma_proc)_pa_operation_get_state; - pContext->pulse.pa_channel_map_init_extend = (ma_proc)_pa_channel_map_init_extend; - pContext->pulse.pa_channel_map_valid = (ma_proc)_pa_channel_map_valid; - pContext->pulse.pa_channel_map_compatible = (ma_proc)_pa_channel_map_compatible; - pContext->pulse.pa_stream_new = (ma_proc)_pa_stream_new; - pContext->pulse.pa_stream_unref = (ma_proc)_pa_stream_unref; - pContext->pulse.pa_stream_connect_playback = (ma_proc)_pa_stream_connect_playback; - pContext->pulse.pa_stream_connect_record = (ma_proc)_pa_stream_connect_record; - pContext->pulse.pa_stream_disconnect = (ma_proc)_pa_stream_disconnect; - pContext->pulse.pa_stream_get_state = (ma_proc)_pa_stream_get_state; - pContext->pulse.pa_stream_get_sample_spec = (ma_proc)_pa_stream_get_sample_spec; - pContext->pulse.pa_stream_get_channel_map = (ma_proc)_pa_stream_get_channel_map; - pContext->pulse.pa_stream_get_buffer_attr = (ma_proc)_pa_stream_get_buffer_attr; - pContext->pulse.pa_stream_set_buffer_attr = (ma_proc)_pa_stream_set_buffer_attr; - pContext->pulse.pa_stream_get_device_name = (ma_proc)_pa_stream_get_device_name; - pContext->pulse.pa_stream_set_write_callback = (ma_proc)_pa_stream_set_write_callback; - pContext->pulse.pa_stream_set_read_callback = (ma_proc)_pa_stream_set_read_callback; - pContext->pulse.pa_stream_set_suspended_callback = (ma_proc)_pa_stream_set_suspended_callback; - pContext->pulse.pa_stream_set_moved_callback = (ma_proc)_pa_stream_set_moved_callback; - pContext->pulse.pa_stream_is_suspended = (ma_proc)_pa_stream_is_suspended; - pContext->pulse.pa_stream_flush = (ma_proc)_pa_stream_flush; - pContext->pulse.pa_stream_drain = (ma_proc)_pa_stream_drain; - pContext->pulse.pa_stream_is_corked = (ma_proc)_pa_stream_is_corked; - pContext->pulse.pa_stream_cork = (ma_proc)_pa_stream_cork; - pContext->pulse.pa_stream_trigger = (ma_proc)_pa_stream_trigger; - pContext->pulse.pa_stream_begin_write = (ma_proc)_pa_stream_begin_write; - pContext->pulse.pa_stream_write = (ma_proc)_pa_stream_write; - pContext->pulse.pa_stream_peek = (ma_proc)_pa_stream_peek; - pContext->pulse.pa_stream_drop = (ma_proc)_pa_stream_drop; - pContext->pulse.pa_stream_writable_size = (ma_proc)_pa_stream_writable_size; - pContext->pulse.pa_stream_readable_size = (ma_proc)_pa_stream_readable_size; -#endif - - /* We need to make a copy of the application and server names so we can pass them to the pa_context of each device. */ - pContext->pulse.pApplicationName = ma_copy_string(pConfig->pulse.pApplicationName, &pContext->allocationCallbacks); - if (pContext->pulse.pApplicationName == NULL && pConfig->pulse.pApplicationName != NULL) { - return MA_OUT_OF_MEMORY; - } - - pContext->pulse.pServerName = ma_copy_string(pConfig->pulse.pServerName, &pContext->allocationCallbacks); - if (pContext->pulse.pServerName == NULL && pConfig->pulse.pServerName != NULL) { - ma_free(pContext->pulse.pApplicationName, &pContext->allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - result = ma_init_pa_mainloop_and_pa_context__pulse(pContext, pConfig->pulse.pApplicationName, pConfig->pulse.pServerName, pConfig->pulse.tryAutoSpawn, &pContext->pulse.pMainLoop, &pContext->pulse.pPulseContext); - if (result != MA_SUCCESS) { - ma_free(pContext->pulse.pServerName, &pContext->allocationCallbacks); - ma_free(pContext->pulse.pApplicationName, &pContext->allocationCallbacks); - #ifndef MA_NO_RUNTIME_LINKING - ma_dlclose(pContext, pContext->pulse.pulseSO); - #endif - return result; - } - - /* With pa_mainloop we run a synchronous backend, but we implement our own main loop. */ - pCallbacks->onContextInit = ma_context_init__pulse; - pCallbacks->onContextUninit = ma_context_uninit__pulse; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__pulse; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__pulse; - pCallbacks->onDeviceInit = ma_device_init__pulse; - pCallbacks->onDeviceUninit = ma_device_uninit__pulse; - pCallbacks->onDeviceStart = ma_device_start__pulse; - pCallbacks->onDeviceStop = ma_device_stop__pulse; - pCallbacks->onDeviceRead = NULL; /* Not used because we're implementing onDeviceDataLoop. */ - pCallbacks->onDeviceWrite = NULL; /* Not used because we're implementing onDeviceDataLoop. */ - pCallbacks->onDeviceDataLoop = ma_device_data_loop__pulse; - pCallbacks->onDeviceDataLoopWakeup = ma_device_data_loop_wakeup__pulse; - - return MA_SUCCESS; -} -#endif - - -/****************************************************************************** - -JACK Backend - -******************************************************************************/ -#ifdef MA_HAS_JACK - -/* It is assumed jack.h is available when compile-time linking is being used. */ -#ifdef MA_NO_RUNTIME_LINKING -#include - -typedef jack_nframes_t ma_jack_nframes_t; -typedef jack_options_t ma_jack_options_t; -typedef jack_status_t ma_jack_status_t; -typedef jack_client_t ma_jack_client_t; -typedef jack_port_t ma_jack_port_t; -typedef JackProcessCallback ma_JackProcessCallback; -typedef JackBufferSizeCallback ma_JackBufferSizeCallback; -typedef JackShutdownCallback ma_JackShutdownCallback; -#define MA_JACK_DEFAULT_AUDIO_TYPE JACK_DEFAULT_AUDIO_TYPE -#define ma_JackNoStartServer JackNoStartServer -#define ma_JackPortIsInput JackPortIsInput -#define ma_JackPortIsOutput JackPortIsOutput -#define ma_JackPortIsPhysical JackPortIsPhysical -#else -typedef ma_uint32 ma_jack_nframes_t; -typedef int ma_jack_options_t; -typedef int ma_jack_status_t; -typedef struct ma_jack_client_t ma_jack_client_t; -typedef struct ma_jack_port_t ma_jack_port_t; -typedef int (* ma_JackProcessCallback) (ma_jack_nframes_t nframes, void* arg); -typedef int (* ma_JackBufferSizeCallback)(ma_jack_nframes_t nframes, void* arg); -typedef void (* ma_JackShutdownCallback) (void* arg); -#define MA_JACK_DEFAULT_AUDIO_TYPE "32 bit float mono audio" -#define ma_JackNoStartServer 1 -#define ma_JackPortIsInput 1 -#define ma_JackPortIsOutput 2 -#define ma_JackPortIsPhysical 4 -#endif - -typedef ma_jack_client_t* (* ma_jack_client_open_proc) (const char* client_name, ma_jack_options_t options, ma_jack_status_t* status, ...); -typedef int (* ma_jack_client_close_proc) (ma_jack_client_t* client); -typedef int (* ma_jack_client_name_size_proc) (void); -typedef int (* ma_jack_set_process_callback_proc) (ma_jack_client_t* client, ma_JackProcessCallback process_callback, void* arg); -typedef int (* ma_jack_set_buffer_size_callback_proc)(ma_jack_client_t* client, ma_JackBufferSizeCallback bufsize_callback, void* arg); -typedef void (* ma_jack_on_shutdown_proc) (ma_jack_client_t* client, ma_JackShutdownCallback function, void* arg); -typedef ma_jack_nframes_t (* ma_jack_get_sample_rate_proc) (ma_jack_client_t* client); -typedef ma_jack_nframes_t (* ma_jack_get_buffer_size_proc) (ma_jack_client_t* client); -typedef const char** (* ma_jack_get_ports_proc) (ma_jack_client_t* client, const char* port_name_pattern, const char* type_name_pattern, unsigned long flags); -typedef int (* ma_jack_activate_proc) (ma_jack_client_t* client); -typedef int (* ma_jack_deactivate_proc) (ma_jack_client_t* client); -typedef int (* ma_jack_connect_proc) (ma_jack_client_t* client, const char* source_port, const char* destination_port); -typedef ma_jack_port_t* (* ma_jack_port_register_proc) (ma_jack_client_t* client, const char* port_name, const char* port_type, unsigned long flags, unsigned long buffer_size); -typedef const char* (* ma_jack_port_name_proc) (const ma_jack_port_t* port); -typedef void* (* ma_jack_port_get_buffer_proc) (ma_jack_port_t* port, ma_jack_nframes_t nframes); -typedef void (* ma_jack_free_proc) (void* ptr); - -static ma_result ma_context_open_client__jack(ma_context* pContext, ma_jack_client_t** ppClient) -{ - size_t maxClientNameSize; - char clientName[256]; - ma_jack_status_t status; - ma_jack_client_t* pClient; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppClient != NULL); - - if (ppClient) { - *ppClient = NULL; - } - - maxClientNameSize = ((ma_jack_client_name_size_proc)pContext->jack.jack_client_name_size)(); /* Includes null terminator. */ - ma_strncpy_s(clientName, ma_min(sizeof(clientName), maxClientNameSize), (pContext->jack.pClientName != NULL) ? pContext->jack.pClientName : "miniaudio", (size_t)-1); - - pClient = ((ma_jack_client_open_proc)pContext->jack.jack_client_open)(clientName, (pContext->jack.tryStartServer) ? 0 : ma_JackNoStartServer, &status, NULL); - if (pClient == NULL) { - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - if (ppClient) { - *ppClient = pClient; - } - - return MA_SUCCESS; -} - - -static ma_result ma_context_enumerate_devices__jack(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_bool32 cbResult = MA_TRUE; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* Playback. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - deviceInfo.isDefault = MA_TRUE; /* JACK only uses default devices. */ - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - - /* Capture. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - deviceInfo.isDefault = MA_TRUE; /* JACK only uses default devices. */ - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - - (void)cbResult; /* For silencing a static analysis warning. */ - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__jack(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_jack_client_t* pClient; - ma_result result; - const char** ppPorts; - - MA_ASSERT(pContext != NULL); - - if (pDeviceID != NULL && pDeviceID->jack != 0) { - return MA_NO_DEVICE; /* Don't know the device. */ - } - - /* Name / Description */ - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - /* Jack only uses default devices. */ - pDeviceInfo->isDefault = MA_TRUE; - - /* Jack only supports f32 and has a specific channel count and sample rate. */ - pDeviceInfo->nativeDataFormats[0].format = ma_format_f32; - - /* The channel count and sample rate can only be determined by opening the device. */ - result = ma_context_open_client__jack(pContext, &pClient); - if (result != MA_SUCCESS) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[JACK] Failed to open client."); - return result; - } - - pDeviceInfo->nativeDataFormats[0].sampleRate = ((ma_jack_get_sample_rate_proc)pContext->jack.jack_get_sample_rate)((ma_jack_client_t*)pClient); - pDeviceInfo->nativeDataFormats[0].channels = 0; - - ppPorts = ((ma_jack_get_ports_proc)pContext->jack.jack_get_ports)((ma_jack_client_t*)pClient, NULL, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsPhysical | ((deviceType == ma_device_type_playback) ? ma_JackPortIsInput : ma_JackPortIsOutput)); - if (ppPorts == NULL) { - ((ma_jack_client_close_proc)pContext->jack.jack_client_close)((ma_jack_client_t*)pClient); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[JACK] Failed to query physical ports."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - while (ppPorts[pDeviceInfo->nativeDataFormats[0].channels] != NULL) { - pDeviceInfo->nativeDataFormats[0].channels += 1; - } - - pDeviceInfo->nativeDataFormats[0].flags = 0; - pDeviceInfo->nativeDataFormatCount = 1; - - ((ma_jack_free_proc)pContext->jack.jack_free)((void*)ppPorts); - ((ma_jack_client_close_proc)pContext->jack.jack_client_close)((ma_jack_client_t*)pClient); - - (void)pContext; - return MA_SUCCESS; -} - - -static ma_result ma_device_uninit__jack(ma_device* pDevice) -{ - ma_context* pContext; - - MA_ASSERT(pDevice != NULL); - - pContext = pDevice->pContext; - MA_ASSERT(pContext != NULL); - - if (pDevice->jack.pClient != NULL) { - ((ma_jack_client_close_proc)pContext->jack.jack_client_close)((ma_jack_client_t*)pDevice->jack.pClient); - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_free(pDevice->jack.pIntermediaryBufferCapture, &pDevice->pContext->allocationCallbacks); - ma_free(pDevice->jack.ppPortsCapture, &pDevice->pContext->allocationCallbacks); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_free(pDevice->jack.pIntermediaryBufferPlayback, &pDevice->pContext->allocationCallbacks); - ma_free(pDevice->jack.ppPortsPlayback, &pDevice->pContext->allocationCallbacks); - } - - return MA_SUCCESS; -} - -static void ma_device__jack_shutdown_callback(void* pUserData) -{ - /* JACK died. Stop the device. */ - ma_device* pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - ma_device_stop(pDevice); -} - -static int ma_device__jack_buffer_size_callback(ma_jack_nframes_t frameCount, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - size_t newBufferSize = frameCount * (pDevice->capture.internalChannels * ma_get_bytes_per_sample(pDevice->capture.internalFormat)); - float* pNewBuffer = (float*)ma_calloc(newBufferSize, &pDevice->pContext->allocationCallbacks); - if (pNewBuffer == NULL) { - return MA_OUT_OF_MEMORY; - } - - ma_free(pDevice->jack.pIntermediaryBufferCapture, &pDevice->pContext->allocationCallbacks); - - pDevice->jack.pIntermediaryBufferCapture = pNewBuffer; - pDevice->playback.internalPeriodSizeInFrames = frameCount; - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - size_t newBufferSize = frameCount * (pDevice->playback.internalChannels * ma_get_bytes_per_sample(pDevice->playback.internalFormat)); - float* pNewBuffer = (float*)ma_calloc(newBufferSize, &pDevice->pContext->allocationCallbacks); - if (pNewBuffer == NULL) { - return MA_OUT_OF_MEMORY; - } - - ma_free(pDevice->jack.pIntermediaryBufferPlayback, &pDevice->pContext->allocationCallbacks); - - pDevice->jack.pIntermediaryBufferPlayback = pNewBuffer; - pDevice->playback.internalPeriodSizeInFrames = frameCount; - } - - return 0; -} - -static int ma_device__jack_process_callback(ma_jack_nframes_t frameCount, void* pUserData) -{ - ma_device* pDevice; - ma_context* pContext; - ma_uint32 iChannel; - - pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - pContext = pDevice->pContext; - MA_ASSERT(pContext != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - /* Channels need to be interleaved. */ - for (iChannel = 0; iChannel < pDevice->capture.internalChannels; ++iChannel) { - const float* pSrc = (const float*)((ma_jack_port_get_buffer_proc)pContext->jack.jack_port_get_buffer)((ma_jack_port_t*)pDevice->jack.ppPortsCapture[iChannel], frameCount); - if (pSrc != NULL) { - float* pDst = pDevice->jack.pIntermediaryBufferCapture + iChannel; - ma_jack_nframes_t iFrame; - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - *pDst = *pSrc; - - pDst += pDevice->capture.internalChannels; - pSrc += 1; - } - } - } - - ma_device_handle_backend_data_callback(pDevice, NULL, pDevice->jack.pIntermediaryBufferCapture, frameCount); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_device_handle_backend_data_callback(pDevice, pDevice->jack.pIntermediaryBufferPlayback, NULL, frameCount); - - /* Channels need to be deinterleaved. */ - for (iChannel = 0; iChannel < pDevice->playback.internalChannels; ++iChannel) { - float* pDst = (float*)((ma_jack_port_get_buffer_proc)pContext->jack.jack_port_get_buffer)((ma_jack_port_t*)pDevice->jack.ppPortsPlayback[iChannel], frameCount); - if (pDst != NULL) { - const float* pSrc = pDevice->jack.pIntermediaryBufferPlayback + iChannel; - ma_jack_nframes_t iFrame; - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - *pDst = *pSrc; - - pDst += 1; - pSrc += pDevice->playback.internalChannels; - } - } - } - } - - return 0; -} - -static ma_result ma_device_init__jack(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - ma_uint32 periodSizeInFrames; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pDevice != NULL); - - if (pConfig->deviceType == ma_device_type_loopback) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Loopback mode not supported."); - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* Only supporting default devices with JACK. */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->pDeviceID != NULL && pDescriptorPlayback->pDeviceID->jack != 0) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->pDeviceID != NULL && pDescriptorCapture->pDeviceID->jack != 0)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Only default devices are supported."); - return MA_NO_DEVICE; - } - - /* No exclusive mode with the JACK backend. */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->shareMode == ma_share_mode_exclusive)) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Exclusive mode not supported."); - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - /* Open the client. */ - result = ma_context_open_client__jack(pDevice->pContext, (ma_jack_client_t**)&pDevice->jack.pClient); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to open client."); - return result; - } - - /* Callbacks. */ - if (((ma_jack_set_process_callback_proc)pDevice->pContext->jack.jack_set_process_callback)((ma_jack_client_t*)pDevice->jack.pClient, ma_device__jack_process_callback, pDevice) != 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to set process callback."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - if (((ma_jack_set_buffer_size_callback_proc)pDevice->pContext->jack.jack_set_buffer_size_callback)((ma_jack_client_t*)pDevice->jack.pClient, ma_device__jack_buffer_size_callback, pDevice) != 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to set buffer size callback."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - ((ma_jack_on_shutdown_proc)pDevice->pContext->jack.jack_on_shutdown)((ma_jack_client_t*)pDevice->jack.pClient, ma_device__jack_shutdown_callback, pDevice); - - - /* The buffer size in frames can change. */ - periodSizeInFrames = ((ma_jack_get_buffer_size_proc)pDevice->pContext->jack.jack_get_buffer_size)((ma_jack_client_t*)pDevice->jack.pClient); - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_uint32 iPort; - const char** ppPorts; - - pDescriptorCapture->format = ma_format_f32; - pDescriptorCapture->channels = 0; - pDescriptorCapture->sampleRate = ((ma_jack_get_sample_rate_proc)pDevice->pContext->jack.jack_get_sample_rate)((ma_jack_client_t*)pDevice->jack.pClient); - ma_channel_map_init_standard(ma_standard_channel_map_alsa, pDescriptorCapture->channelMap, ma_countof(pDescriptorCapture->channelMap), pDescriptorCapture->channels); - - ppPorts = ((ma_jack_get_ports_proc)pDevice->pContext->jack.jack_get_ports)((ma_jack_client_t*)pDevice->jack.pClient, NULL, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsPhysical | ma_JackPortIsOutput); - if (ppPorts == NULL) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to query physical ports."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - /* Need to count the number of ports first so we can allocate some memory. */ - while (ppPorts[pDescriptorCapture->channels] != NULL) { - pDescriptorCapture->channels += 1; - } - - pDevice->jack.ppPortsCapture = (ma_ptr*)ma_malloc(sizeof(*pDevice->jack.ppPortsCapture) * pDescriptorCapture->channels, &pDevice->pContext->allocationCallbacks); - if (pDevice->jack.ppPortsCapture == NULL) { - return MA_OUT_OF_MEMORY; - } - - for (iPort = 0; iPort < pDescriptorCapture->channels; iPort += 1) { - char name[64]; - ma_strcpy_s(name, sizeof(name), "capture"); - ma_itoa_s((int)iPort, name+7, sizeof(name)-7, 10); /* 7 = length of "capture" */ - - pDevice->jack.ppPortsCapture[iPort] = ((ma_jack_port_register_proc)pDevice->pContext->jack.jack_port_register)((ma_jack_client_t*)pDevice->jack.pClient, name, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsInput, 0); - if (pDevice->jack.ppPortsCapture[iPort] == NULL) { - ((ma_jack_free_proc)pDevice->pContext->jack.jack_free)((void*)ppPorts); - ma_device_uninit__jack(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to register ports."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - } - - ((ma_jack_free_proc)pDevice->pContext->jack.jack_free)((void*)ppPorts); - - pDescriptorCapture->periodSizeInFrames = periodSizeInFrames; - pDescriptorCapture->periodCount = 1; /* There's no notion of a period in JACK. Just set to 1. */ - - pDevice->jack.pIntermediaryBufferCapture = (float*)ma_calloc(pDescriptorCapture->periodSizeInFrames * ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels), &pDevice->pContext->allocationCallbacks); - if (pDevice->jack.pIntermediaryBufferCapture == NULL) { - ma_device_uninit__jack(pDevice); - return MA_OUT_OF_MEMORY; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_uint32 iPort; - const char** ppPorts; - - pDescriptorPlayback->format = ma_format_f32; - pDescriptorPlayback->channels = 0; - pDescriptorPlayback->sampleRate = ((ma_jack_get_sample_rate_proc)pDevice->pContext->jack.jack_get_sample_rate)((ma_jack_client_t*)pDevice->jack.pClient); - ma_channel_map_init_standard(ma_standard_channel_map_alsa, pDescriptorPlayback->channelMap, ma_countof(pDescriptorPlayback->channelMap), pDescriptorPlayback->channels); - - ppPorts = ((ma_jack_get_ports_proc)pDevice->pContext->jack.jack_get_ports)((ma_jack_client_t*)pDevice->jack.pClient, NULL, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsPhysical | ma_JackPortIsInput); - if (ppPorts == NULL) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to query physical ports."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - /* Need to count the number of ports first so we can allocate some memory. */ - while (ppPorts[pDescriptorPlayback->channels] != NULL) { - pDescriptorPlayback->channels += 1; - } - - pDevice->jack.ppPortsPlayback = (ma_ptr*)ma_malloc(sizeof(*pDevice->jack.ppPortsPlayback) * pDescriptorPlayback->channels, &pDevice->pContext->allocationCallbacks); - if (pDevice->jack.ppPortsPlayback == NULL) { - ma_free(pDevice->jack.ppPortsCapture, &pDevice->pContext->allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - for (iPort = 0; iPort < pDescriptorPlayback->channels; iPort += 1) { - char name[64]; - ma_strcpy_s(name, sizeof(name), "playback"); - ma_itoa_s((int)iPort, name+8, sizeof(name)-8, 10); /* 8 = length of "playback" */ - - pDevice->jack.ppPortsPlayback[iPort] = ((ma_jack_port_register_proc)pDevice->pContext->jack.jack_port_register)((ma_jack_client_t*)pDevice->jack.pClient, name, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsOutput, 0); - if (pDevice->jack.ppPortsPlayback[iPort] == NULL) { - ((ma_jack_free_proc)pDevice->pContext->jack.jack_free)((void*)ppPorts); - ma_device_uninit__jack(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to register ports."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - } - - ((ma_jack_free_proc)pDevice->pContext->jack.jack_free)((void*)ppPorts); - - pDescriptorPlayback->periodSizeInFrames = periodSizeInFrames; - pDescriptorPlayback->periodCount = 1; /* There's no notion of a period in JACK. Just set to 1. */ - - pDevice->jack.pIntermediaryBufferPlayback = (float*)ma_calloc(pDescriptorPlayback->periodSizeInFrames * ma_get_bytes_per_frame(pDescriptorPlayback->format, pDescriptorPlayback->channels), &pDevice->pContext->allocationCallbacks); - if (pDevice->jack.pIntermediaryBufferPlayback == NULL) { - ma_device_uninit__jack(pDevice); - return MA_OUT_OF_MEMORY; - } - } - - return MA_SUCCESS; -} - - -static ma_result ma_device_start__jack(ma_device* pDevice) -{ - ma_context* pContext = pDevice->pContext; - int resultJACK; - size_t i; - - resultJACK = ((ma_jack_activate_proc)pContext->jack.jack_activate)((ma_jack_client_t*)pDevice->jack.pClient); - if (resultJACK != 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to activate the JACK client."); - return MA_FAILED_TO_START_BACKEND_DEVICE; - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - const char** ppServerPorts = ((ma_jack_get_ports_proc)pContext->jack.jack_get_ports)((ma_jack_client_t*)pDevice->jack.pClient, NULL, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsPhysical | ma_JackPortIsOutput); - if (ppServerPorts == NULL) { - ((ma_jack_deactivate_proc)pContext->jack.jack_deactivate)((ma_jack_client_t*)pDevice->jack.pClient); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to retrieve physical ports."); - return MA_ERROR; - } - - for (i = 0; ppServerPorts[i] != NULL; ++i) { - const char* pServerPort = ppServerPorts[i]; - const char* pClientPort = ((ma_jack_port_name_proc)pContext->jack.jack_port_name)((ma_jack_port_t*)pDevice->jack.ppPortsCapture[i]); - - resultJACK = ((ma_jack_connect_proc)pContext->jack.jack_connect)((ma_jack_client_t*)pDevice->jack.pClient, pServerPort, pClientPort); - if (resultJACK != 0) { - ((ma_jack_free_proc)pContext->jack.jack_free)((void*)ppServerPorts); - ((ma_jack_deactivate_proc)pContext->jack.jack_deactivate)((ma_jack_client_t*)pDevice->jack.pClient); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to connect ports."); - return MA_ERROR; - } - } - - ((ma_jack_free_proc)pContext->jack.jack_free)((void*)ppServerPorts); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - const char** ppServerPorts = ((ma_jack_get_ports_proc)pContext->jack.jack_get_ports)((ma_jack_client_t*)pDevice->jack.pClient, NULL, MA_JACK_DEFAULT_AUDIO_TYPE, ma_JackPortIsPhysical | ma_JackPortIsInput); - if (ppServerPorts == NULL) { - ((ma_jack_deactivate_proc)pContext->jack.jack_deactivate)((ma_jack_client_t*)pDevice->jack.pClient); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to retrieve physical ports."); - return MA_ERROR; - } - - for (i = 0; ppServerPorts[i] != NULL; ++i) { - const char* pServerPort = ppServerPorts[i]; - const char* pClientPort = ((ma_jack_port_name_proc)pContext->jack.jack_port_name)((ma_jack_port_t*)pDevice->jack.ppPortsPlayback[i]); - - resultJACK = ((ma_jack_connect_proc)pContext->jack.jack_connect)((ma_jack_client_t*)pDevice->jack.pClient, pClientPort, pServerPort); - if (resultJACK != 0) { - ((ma_jack_free_proc)pContext->jack.jack_free)((void*)ppServerPorts); - ((ma_jack_deactivate_proc)pContext->jack.jack_deactivate)((ma_jack_client_t*)pDevice->jack.pClient); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] Failed to connect ports."); - return MA_ERROR; - } - } - - ((ma_jack_free_proc)pContext->jack.jack_free)((void*)ppServerPorts); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__jack(ma_device* pDevice) -{ - ma_context* pContext = pDevice->pContext; - - if (((ma_jack_deactivate_proc)pContext->jack.jack_deactivate)((ma_jack_client_t*)pDevice->jack.pClient) != 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[JACK] An error occurred when deactivating the JACK client."); - return MA_ERROR; - } - - ma_device__on_notification_stopped(pDevice); - - return MA_SUCCESS; -} - - -static ma_result ma_context_uninit__jack(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_jack); - - ma_free(pContext->jack.pClientName, &pContext->allocationCallbacks); - pContext->jack.pClientName = NULL; - -#ifndef MA_NO_RUNTIME_LINKING - ma_dlclose(pContext, pContext->jack.jackSO); -#endif - - return MA_SUCCESS; -} - -static ma_result ma_context_init__jack(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ -#ifndef MA_NO_RUNTIME_LINKING - const char* libjackNames[] = { -#if defined(MA_WIN32) - "libjack.dll", - "libjack64.dll" -#endif -#if defined(MA_UNIX) - "libjack.so", - "libjack.so.0" -#endif - }; - size_t i; - - for (i = 0; i < ma_countof(libjackNames); ++i) { - pContext->jack.jackSO = ma_dlopen(pContext, libjackNames[i]); - if (pContext->jack.jackSO != NULL) { - break; - } - } - - if (pContext->jack.jackSO == NULL) { - return MA_NO_BACKEND; - } - - pContext->jack.jack_client_open = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_client_open"); - pContext->jack.jack_client_close = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_client_close"); - pContext->jack.jack_client_name_size = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_client_name_size"); - pContext->jack.jack_set_process_callback = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_set_process_callback"); - pContext->jack.jack_set_buffer_size_callback = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_set_buffer_size_callback"); - pContext->jack.jack_on_shutdown = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_on_shutdown"); - pContext->jack.jack_get_sample_rate = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_get_sample_rate"); - pContext->jack.jack_get_buffer_size = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_get_buffer_size"); - pContext->jack.jack_get_ports = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_get_ports"); - pContext->jack.jack_activate = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_activate"); - pContext->jack.jack_deactivate = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_deactivate"); - pContext->jack.jack_connect = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_connect"); - pContext->jack.jack_port_register = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_port_register"); - pContext->jack.jack_port_name = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_port_name"); - pContext->jack.jack_port_get_buffer = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_port_get_buffer"); - pContext->jack.jack_free = (ma_proc)ma_dlsym(pContext, pContext->jack.jackSO, "jack_free"); -#else - /* - This strange assignment system is here just to ensure type safety of miniaudio's function pointer - types. If anything differs slightly the compiler should throw a warning. - */ - ma_jack_client_open_proc _jack_client_open = jack_client_open; - ma_jack_client_close_proc _jack_client_close = jack_client_close; - ma_jack_client_name_size_proc _jack_client_name_size = jack_client_name_size; - ma_jack_set_process_callback_proc _jack_set_process_callback = jack_set_process_callback; - ma_jack_set_buffer_size_callback_proc _jack_set_buffer_size_callback = jack_set_buffer_size_callback; - ma_jack_on_shutdown_proc _jack_on_shutdown = jack_on_shutdown; - ma_jack_get_sample_rate_proc _jack_get_sample_rate = jack_get_sample_rate; - ma_jack_get_buffer_size_proc _jack_get_buffer_size = jack_get_buffer_size; - ma_jack_get_ports_proc _jack_get_ports = jack_get_ports; - ma_jack_activate_proc _jack_activate = jack_activate; - ma_jack_deactivate_proc _jack_deactivate = jack_deactivate; - ma_jack_connect_proc _jack_connect = jack_connect; - ma_jack_port_register_proc _jack_port_register = jack_port_register; - ma_jack_port_name_proc _jack_port_name = jack_port_name; - ma_jack_port_get_buffer_proc _jack_port_get_buffer = jack_port_get_buffer; - ma_jack_free_proc _jack_free = jack_free; - - pContext->jack.jack_client_open = (ma_proc)_jack_client_open; - pContext->jack.jack_client_close = (ma_proc)_jack_client_close; - pContext->jack.jack_client_name_size = (ma_proc)_jack_client_name_size; - pContext->jack.jack_set_process_callback = (ma_proc)_jack_set_process_callback; - pContext->jack.jack_set_buffer_size_callback = (ma_proc)_jack_set_buffer_size_callback; - pContext->jack.jack_on_shutdown = (ma_proc)_jack_on_shutdown; - pContext->jack.jack_get_sample_rate = (ma_proc)_jack_get_sample_rate; - pContext->jack.jack_get_buffer_size = (ma_proc)_jack_get_buffer_size; - pContext->jack.jack_get_ports = (ma_proc)_jack_get_ports; - pContext->jack.jack_activate = (ma_proc)_jack_activate; - pContext->jack.jack_deactivate = (ma_proc)_jack_deactivate; - pContext->jack.jack_connect = (ma_proc)_jack_connect; - pContext->jack.jack_port_register = (ma_proc)_jack_port_register; - pContext->jack.jack_port_name = (ma_proc)_jack_port_name; - pContext->jack.jack_port_get_buffer = (ma_proc)_jack_port_get_buffer; - pContext->jack.jack_free = (ma_proc)_jack_free; -#endif - - if (pConfig->jack.pClientName != NULL) { - pContext->jack.pClientName = ma_copy_string(pConfig->jack.pClientName, &pContext->allocationCallbacks); - } - pContext->jack.tryStartServer = pConfig->jack.tryStartServer; - - /* - Getting here means the JACK library is installed, but it doesn't necessarily mean it's usable. We need to quickly test this by connecting - a temporary client. - */ - { - ma_jack_client_t* pDummyClient; - ma_result result = ma_context_open_client__jack(pContext, &pDummyClient); - if (result != MA_SUCCESS) { - ma_free(pContext->jack.pClientName, &pContext->allocationCallbacks); - #ifndef MA_NO_RUNTIME_LINKING - ma_dlclose(pContext, pContext->jack.jackSO); - #endif - return MA_NO_BACKEND; - } - - ((ma_jack_client_close_proc)pContext->jack.jack_client_close)((ma_jack_client_t*)pDummyClient); - } - - - pCallbacks->onContextInit = ma_context_init__jack; - pCallbacks->onContextUninit = ma_context_uninit__jack; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__jack; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__jack; - pCallbacks->onDeviceInit = ma_device_init__jack; - pCallbacks->onDeviceUninit = ma_device_uninit__jack; - pCallbacks->onDeviceStart = ma_device_start__jack; - pCallbacks->onDeviceStop = ma_device_stop__jack; - pCallbacks->onDeviceRead = NULL; /* Not used because JACK is asynchronous. */ - pCallbacks->onDeviceWrite = NULL; /* Not used because JACK is asynchronous. */ - pCallbacks->onDeviceDataLoop = NULL; /* Not used because JACK is asynchronous. */ - - return MA_SUCCESS; -} -#endif /* JACK */ - - - -/****************************************************************************** - -Core Audio Backend - -References -========== -- Technical Note TN2091: Device input using the HAL Output Audio Unit - https://developer.apple.com/library/archive/technotes/tn2091/_index.html - -******************************************************************************/ -#ifdef MA_HAS_COREAUDIO -#include - -#if defined(TARGET_OS_IPHONE) && TARGET_OS_IPHONE == 1 - #define MA_APPLE_MOBILE - #if defined(TARGET_OS_TV) && TARGET_OS_TV == 1 - #define MA_APPLE_TV - #endif - #if defined(TARGET_OS_WATCH) && TARGET_OS_WATCH == 1 - #define MA_APPLE_WATCH - #endif - #if __has_feature(objc_arc) - #define MA_BRIDGE_TRANSFER __bridge_transfer - #define MA_BRIDGE_RETAINED __bridge_retained - #else - #define MA_BRIDGE_TRANSFER - #define MA_BRIDGE_RETAINED - #endif -#else - #define MA_APPLE_DESKTOP -#endif - -#if defined(MA_APPLE_DESKTOP) -#include -#else -#include -#endif - -#include - -/* CoreFoundation */ -typedef Boolean (* ma_CFStringGetCString_proc)(CFStringRef theString, char* buffer, CFIndex bufferSize, CFStringEncoding encoding); -typedef void (* ma_CFRelease_proc)(CFTypeRef cf); - -/* CoreAudio */ -#if defined(MA_APPLE_DESKTOP) -typedef OSStatus (* ma_AudioObjectGetPropertyData_proc)(AudioObjectID inObjectID, const AudioObjectPropertyAddress* inAddress, UInt32 inQualifierDataSize, const void* inQualifierData, UInt32* ioDataSize, void* outData); -typedef OSStatus (* ma_AudioObjectGetPropertyDataSize_proc)(AudioObjectID inObjectID, const AudioObjectPropertyAddress* inAddress, UInt32 inQualifierDataSize, const void* inQualifierData, UInt32* outDataSize); -typedef OSStatus (* ma_AudioObjectSetPropertyData_proc)(AudioObjectID inObjectID, const AudioObjectPropertyAddress* inAddress, UInt32 inQualifierDataSize, const void* inQualifierData, UInt32 inDataSize, const void* inData); -typedef OSStatus (* ma_AudioObjectAddPropertyListener_proc)(AudioObjectID inObjectID, const AudioObjectPropertyAddress* inAddress, AudioObjectPropertyListenerProc inListener, void* inClientData); -typedef OSStatus (* ma_AudioObjectRemovePropertyListener_proc)(AudioObjectID inObjectID, const AudioObjectPropertyAddress* inAddress, AudioObjectPropertyListenerProc inListener, void* inClientData); -#endif - -/* AudioToolbox */ -typedef AudioComponent (* ma_AudioComponentFindNext_proc)(AudioComponent inComponent, const AudioComponentDescription* inDesc); -typedef OSStatus (* ma_AudioComponentInstanceDispose_proc)(AudioComponentInstance inInstance); -typedef OSStatus (* ma_AudioComponentInstanceNew_proc)(AudioComponent inComponent, AudioComponentInstance* outInstance); -typedef OSStatus (* ma_AudioOutputUnitStart_proc)(AudioUnit inUnit); -typedef OSStatus (* ma_AudioOutputUnitStop_proc)(AudioUnit inUnit); -typedef OSStatus (* ma_AudioUnitAddPropertyListener_proc)(AudioUnit inUnit, AudioUnitPropertyID inID, AudioUnitPropertyListenerProc inProc, void* inProcUserData); -typedef OSStatus (* ma_AudioUnitGetPropertyInfo_proc)(AudioUnit inUnit, AudioUnitPropertyID inID, AudioUnitScope inScope, AudioUnitElement inElement, UInt32* outDataSize, Boolean* outWriteable); -typedef OSStatus (* ma_AudioUnitGetProperty_proc)(AudioUnit inUnit, AudioUnitPropertyID inID, AudioUnitScope inScope, AudioUnitElement inElement, void* outData, UInt32* ioDataSize); -typedef OSStatus (* ma_AudioUnitSetProperty_proc)(AudioUnit inUnit, AudioUnitPropertyID inID, AudioUnitScope inScope, AudioUnitElement inElement, const void* inData, UInt32 inDataSize); -typedef OSStatus (* ma_AudioUnitInitialize_proc)(AudioUnit inUnit); -typedef OSStatus (* ma_AudioUnitRender_proc)(AudioUnit inUnit, AudioUnitRenderActionFlags* ioActionFlags, const AudioTimeStamp* inTimeStamp, UInt32 inOutputBusNumber, UInt32 inNumberFrames, AudioBufferList* ioData); - - -#define MA_COREAUDIO_OUTPUT_BUS 0 -#define MA_COREAUDIO_INPUT_BUS 1 - -#if defined(MA_APPLE_DESKTOP) -static ma_result ma_device_reinit_internal__coreaudio(ma_device* pDevice, ma_device_type deviceType, ma_bool32 disposePreviousAudioUnit); -#endif - -/* -Core Audio - -So far, Core Audio has been the worst backend to work with due to being both unintuitive and having almost no documentation -apart from comments in the headers (which admittedly are quite good). For my own purposes, and for anybody out there whose -needing to figure out how this darn thing works, I'm going to outline a few things here. - -Since miniaudio is a fairly low-level API, one of the things it needs is control over specific devices, and it needs to be -able to identify whether or not it can be used as playback and/or capture. The AudioObject API is the only one I've seen -that supports this level of detail. There was some public domain sample code I stumbled across that used the AudioComponent -and AudioUnit APIs, but I couldn't see anything that gave low-level control over device selection and capabilities (the -distinction between playback and capture in particular). Therefore, miniaudio is using the AudioObject API. - -Most (all?) functions in the AudioObject API take a AudioObjectID as it's input. This is the device identifier. When -retrieving global information, such as the device list, you use kAudioObjectSystemObject. When retrieving device-specific -data, you pass in the ID for that device. In order to retrieve device-specific IDs you need to enumerate over each of the -devices. This is done using the AudioObjectGetPropertyDataSize() and AudioObjectGetPropertyData() APIs which seem to be -the central APIs for retrieving information about the system and specific devices. - -To use the AudioObjectGetPropertyData() API you need to use the notion of a property address. A property address is a -structure with three variables and is used to identify which property you are getting or setting. The first is the "selector" -which is basically the specific property that you're wanting to retrieve or set. The second is the "scope", which is -typically set to kAudioObjectPropertyScopeGlobal, kAudioObjectPropertyScopeInput for input-specific properties and -kAudioObjectPropertyScopeOutput for output-specific properties. The last is the "element" which is always set to -kAudioObjectPropertyElementMain in miniaudio's case. I don't know of any cases where this would be set to anything different. - -Back to the earlier issue of device retrieval, you first use the AudioObjectGetPropertyDataSize() API to retrieve the size -of the raw data which is just a list of AudioDeviceID's. You use the kAudioObjectSystemObject AudioObjectID, and a property -address with the kAudioHardwarePropertyDevices selector and the kAudioObjectPropertyScopeGlobal scope. Once you have the -size, allocate a block of memory of that size and then call AudioObjectGetPropertyData(). The data is just a list of -AudioDeviceID's so just do "dataSize/sizeof(AudioDeviceID)" to know the device count. -*/ - -static ma_result ma_result_from_OSStatus(OSStatus status) -{ - switch (status) - { - case noErr: return MA_SUCCESS; - #if defined(MA_APPLE_DESKTOP) - case kAudioHardwareNotRunningError: return MA_DEVICE_NOT_STARTED; - case kAudioHardwareUnspecifiedError: return MA_ERROR; - case kAudioHardwareUnknownPropertyError: return MA_INVALID_ARGS; - case kAudioHardwareBadPropertySizeError: return MA_INVALID_OPERATION; - case kAudioHardwareIllegalOperationError: return MA_INVALID_OPERATION; - case kAudioHardwareBadObjectError: return MA_INVALID_ARGS; - case kAudioHardwareBadDeviceError: return MA_INVALID_ARGS; - case kAudioHardwareBadStreamError: return MA_INVALID_ARGS; - case kAudioHardwareUnsupportedOperationError: return MA_INVALID_OPERATION; - case kAudioDeviceUnsupportedFormatError: return MA_FORMAT_NOT_SUPPORTED; - case kAudioDevicePermissionsError: return MA_ACCESS_DENIED; - #endif - default: return MA_ERROR; - } -} - -#if 0 -static ma_channel ma_channel_from_AudioChannelBitmap(AudioChannelBitmap bit) -{ - switch (bit) - { - case kAudioChannelBit_Left: return MA_CHANNEL_LEFT; - case kAudioChannelBit_Right: return MA_CHANNEL_RIGHT; - case kAudioChannelBit_Center: return MA_CHANNEL_FRONT_CENTER; - case kAudioChannelBit_LFEScreen: return MA_CHANNEL_LFE; - case kAudioChannelBit_LeftSurround: return MA_CHANNEL_BACK_LEFT; - case kAudioChannelBit_RightSurround: return MA_CHANNEL_BACK_RIGHT; - case kAudioChannelBit_LeftCenter: return MA_CHANNEL_FRONT_LEFT_CENTER; - case kAudioChannelBit_RightCenter: return MA_CHANNEL_FRONT_RIGHT_CENTER; - case kAudioChannelBit_CenterSurround: return MA_CHANNEL_BACK_CENTER; - case kAudioChannelBit_LeftSurroundDirect: return MA_CHANNEL_SIDE_LEFT; - case kAudioChannelBit_RightSurroundDirect: return MA_CHANNEL_SIDE_RIGHT; - case kAudioChannelBit_TopCenterSurround: return MA_CHANNEL_TOP_CENTER; - case kAudioChannelBit_VerticalHeightLeft: return MA_CHANNEL_TOP_FRONT_LEFT; - case kAudioChannelBit_VerticalHeightCenter: return MA_CHANNEL_TOP_FRONT_CENTER; - case kAudioChannelBit_VerticalHeightRight: return MA_CHANNEL_TOP_FRONT_RIGHT; - case kAudioChannelBit_TopBackLeft: return MA_CHANNEL_TOP_BACK_LEFT; - case kAudioChannelBit_TopBackCenter: return MA_CHANNEL_TOP_BACK_CENTER; - case kAudioChannelBit_TopBackRight: return MA_CHANNEL_TOP_BACK_RIGHT; - default: return MA_CHANNEL_NONE; - } -} -#endif - -static ma_result ma_format_from_AudioStreamBasicDescription(const AudioStreamBasicDescription* pDescription, ma_format* pFormatOut) -{ - MA_ASSERT(pDescription != NULL); - MA_ASSERT(pFormatOut != NULL); - - *pFormatOut = ma_format_unknown; /* Safety. */ - - /* There's a few things miniaudio doesn't support. */ - if (pDescription->mFormatID != kAudioFormatLinearPCM) { - return MA_FORMAT_NOT_SUPPORTED; - } - - /* We don't support any non-packed formats that are aligned high. */ - if ((pDescription->mFormatFlags & kLinearPCMFormatFlagIsAlignedHigh) != 0) { - return MA_FORMAT_NOT_SUPPORTED; - } - - /* Only supporting native-endian. */ - if ((ma_is_little_endian() && (pDescription->mFormatFlags & kAudioFormatFlagIsBigEndian) != 0) || (ma_is_big_endian() && (pDescription->mFormatFlags & kAudioFormatFlagIsBigEndian) == 0)) { - return MA_FORMAT_NOT_SUPPORTED; - } - - /* We are not currently supporting non-interleaved formats (this will be added in a future version of miniaudio). */ - /*if ((pDescription->mFormatFlags & kAudioFormatFlagIsNonInterleaved) != 0) { - return MA_FORMAT_NOT_SUPPORTED; - }*/ - - if ((pDescription->mFormatFlags & kLinearPCMFormatFlagIsFloat) != 0) { - if (pDescription->mBitsPerChannel == 32) { - *pFormatOut = ma_format_f32; - return MA_SUCCESS; - } - } else { - if ((pDescription->mFormatFlags & kLinearPCMFormatFlagIsSignedInteger) != 0) { - if (pDescription->mBitsPerChannel == 16) { - *pFormatOut = ma_format_s16; - return MA_SUCCESS; - } else if (pDescription->mBitsPerChannel == 24) { - if (pDescription->mBytesPerFrame == (pDescription->mBitsPerChannel/8 * pDescription->mChannelsPerFrame)) { - *pFormatOut = ma_format_s24; - return MA_SUCCESS; - } else { - if (pDescription->mBytesPerFrame/pDescription->mChannelsPerFrame == sizeof(ma_int32)) { - /* TODO: Implement ma_format_s24_32. */ - /**pFormatOut = ma_format_s24_32;*/ - /*return MA_SUCCESS;*/ - return MA_FORMAT_NOT_SUPPORTED; - } - } - } else if (pDescription->mBitsPerChannel == 32) { - *pFormatOut = ma_format_s32; - return MA_SUCCESS; - } - } else { - if (pDescription->mBitsPerChannel == 8) { - *pFormatOut = ma_format_u8; - return MA_SUCCESS; - } - } - } - - /* Getting here means the format is not supported. */ - return MA_FORMAT_NOT_SUPPORTED; -} - -#if defined(MA_APPLE_DESKTOP) -static ma_channel ma_channel_from_AudioChannelLabel(AudioChannelLabel label) -{ - switch (label) - { - case kAudioChannelLabel_Unknown: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Unused: return MA_CHANNEL_NONE; - case kAudioChannelLabel_UseCoordinates: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Left: return MA_CHANNEL_LEFT; - case kAudioChannelLabel_Right: return MA_CHANNEL_RIGHT; - case kAudioChannelLabel_Center: return MA_CHANNEL_FRONT_CENTER; - case kAudioChannelLabel_LFEScreen: return MA_CHANNEL_LFE; - case kAudioChannelLabel_LeftSurround: return MA_CHANNEL_BACK_LEFT; - case kAudioChannelLabel_RightSurround: return MA_CHANNEL_BACK_RIGHT; - case kAudioChannelLabel_LeftCenter: return MA_CHANNEL_FRONT_LEFT_CENTER; - case kAudioChannelLabel_RightCenter: return MA_CHANNEL_FRONT_RIGHT_CENTER; - case kAudioChannelLabel_CenterSurround: return MA_CHANNEL_BACK_CENTER; - case kAudioChannelLabel_LeftSurroundDirect: return MA_CHANNEL_SIDE_LEFT; - case kAudioChannelLabel_RightSurroundDirect: return MA_CHANNEL_SIDE_RIGHT; - case kAudioChannelLabel_TopCenterSurround: return MA_CHANNEL_TOP_CENTER; - case kAudioChannelLabel_VerticalHeightLeft: return MA_CHANNEL_TOP_FRONT_LEFT; - case kAudioChannelLabel_VerticalHeightCenter: return MA_CHANNEL_TOP_FRONT_CENTER; - case kAudioChannelLabel_VerticalHeightRight: return MA_CHANNEL_TOP_FRONT_RIGHT; - case kAudioChannelLabel_TopBackLeft: return MA_CHANNEL_TOP_BACK_LEFT; - case kAudioChannelLabel_TopBackCenter: return MA_CHANNEL_TOP_BACK_CENTER; - case kAudioChannelLabel_TopBackRight: return MA_CHANNEL_TOP_BACK_RIGHT; - case kAudioChannelLabel_RearSurroundLeft: return MA_CHANNEL_BACK_LEFT; - case kAudioChannelLabel_RearSurroundRight: return MA_CHANNEL_BACK_RIGHT; - case kAudioChannelLabel_LeftWide: return MA_CHANNEL_SIDE_LEFT; - case kAudioChannelLabel_RightWide: return MA_CHANNEL_SIDE_RIGHT; - case kAudioChannelLabel_LFE2: return MA_CHANNEL_LFE; - case kAudioChannelLabel_LeftTotal: return MA_CHANNEL_LEFT; - case kAudioChannelLabel_RightTotal: return MA_CHANNEL_RIGHT; - case kAudioChannelLabel_HearingImpaired: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Narration: return MA_CHANNEL_MONO; - case kAudioChannelLabel_Mono: return MA_CHANNEL_MONO; - case kAudioChannelLabel_DialogCentricMix: return MA_CHANNEL_MONO; - case kAudioChannelLabel_CenterSurroundDirect: return MA_CHANNEL_BACK_CENTER; - case kAudioChannelLabel_Haptic: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Ambisonic_W: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Ambisonic_X: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Ambisonic_Y: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Ambisonic_Z: return MA_CHANNEL_NONE; - case kAudioChannelLabel_MS_Mid: return MA_CHANNEL_LEFT; - case kAudioChannelLabel_MS_Side: return MA_CHANNEL_RIGHT; - case kAudioChannelLabel_XY_X: return MA_CHANNEL_LEFT; - case kAudioChannelLabel_XY_Y: return MA_CHANNEL_RIGHT; - case kAudioChannelLabel_HeadphonesLeft: return MA_CHANNEL_LEFT; - case kAudioChannelLabel_HeadphonesRight: return MA_CHANNEL_RIGHT; - case kAudioChannelLabel_ClickTrack: return MA_CHANNEL_NONE; - case kAudioChannelLabel_ForeignLanguage: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Discrete: return MA_CHANNEL_NONE; - case kAudioChannelLabel_Discrete_0: return MA_CHANNEL_AUX_0; - case kAudioChannelLabel_Discrete_1: return MA_CHANNEL_AUX_1; - case kAudioChannelLabel_Discrete_2: return MA_CHANNEL_AUX_2; - case kAudioChannelLabel_Discrete_3: return MA_CHANNEL_AUX_3; - case kAudioChannelLabel_Discrete_4: return MA_CHANNEL_AUX_4; - case kAudioChannelLabel_Discrete_5: return MA_CHANNEL_AUX_5; - case kAudioChannelLabel_Discrete_6: return MA_CHANNEL_AUX_6; - case kAudioChannelLabel_Discrete_7: return MA_CHANNEL_AUX_7; - case kAudioChannelLabel_Discrete_8: return MA_CHANNEL_AUX_8; - case kAudioChannelLabel_Discrete_9: return MA_CHANNEL_AUX_9; - case kAudioChannelLabel_Discrete_10: return MA_CHANNEL_AUX_10; - case kAudioChannelLabel_Discrete_11: return MA_CHANNEL_AUX_11; - case kAudioChannelLabel_Discrete_12: return MA_CHANNEL_AUX_12; - case kAudioChannelLabel_Discrete_13: return MA_CHANNEL_AUX_13; - case kAudioChannelLabel_Discrete_14: return MA_CHANNEL_AUX_14; - case kAudioChannelLabel_Discrete_15: return MA_CHANNEL_AUX_15; - case kAudioChannelLabel_Discrete_65535: return MA_CHANNEL_NONE; - - #if 0 /* Introduced in a later version of macOS. */ - case kAudioChannelLabel_HOA_ACN: return MA_CHANNEL_NONE; - case kAudioChannelLabel_HOA_ACN_0: return MA_CHANNEL_AUX_0; - case kAudioChannelLabel_HOA_ACN_1: return MA_CHANNEL_AUX_1; - case kAudioChannelLabel_HOA_ACN_2: return MA_CHANNEL_AUX_2; - case kAudioChannelLabel_HOA_ACN_3: return MA_CHANNEL_AUX_3; - case kAudioChannelLabel_HOA_ACN_4: return MA_CHANNEL_AUX_4; - case kAudioChannelLabel_HOA_ACN_5: return MA_CHANNEL_AUX_5; - case kAudioChannelLabel_HOA_ACN_6: return MA_CHANNEL_AUX_6; - case kAudioChannelLabel_HOA_ACN_7: return MA_CHANNEL_AUX_7; - case kAudioChannelLabel_HOA_ACN_8: return MA_CHANNEL_AUX_8; - case kAudioChannelLabel_HOA_ACN_9: return MA_CHANNEL_AUX_9; - case kAudioChannelLabel_HOA_ACN_10: return MA_CHANNEL_AUX_10; - case kAudioChannelLabel_HOA_ACN_11: return MA_CHANNEL_AUX_11; - case kAudioChannelLabel_HOA_ACN_12: return MA_CHANNEL_AUX_12; - case kAudioChannelLabel_HOA_ACN_13: return MA_CHANNEL_AUX_13; - case kAudioChannelLabel_HOA_ACN_14: return MA_CHANNEL_AUX_14; - case kAudioChannelLabel_HOA_ACN_15: return MA_CHANNEL_AUX_15; - case kAudioChannelLabel_HOA_ACN_65024: return MA_CHANNEL_NONE; - #endif - - default: return MA_CHANNEL_NONE; - } -} - -static ma_result ma_get_channel_map_from_AudioChannelLayout(AudioChannelLayout* pChannelLayout, ma_channel* pChannelMap, size_t channelMapCap) -{ - MA_ASSERT(pChannelLayout != NULL); - - if (pChannelLayout->mChannelLayoutTag == kAudioChannelLayoutTag_UseChannelDescriptions) { - UInt32 iChannel; - for (iChannel = 0; iChannel < pChannelLayout->mNumberChannelDescriptions && iChannel < channelMapCap; ++iChannel) { - pChannelMap[iChannel] = ma_channel_from_AudioChannelLabel(pChannelLayout->mChannelDescriptions[iChannel].mChannelLabel); - } - } else -#if 0 - if (pChannelLayout->mChannelLayoutTag == kAudioChannelLayoutTag_UseChannelBitmap) { - /* This is the same kind of system that's used by Windows audio APIs. */ - UInt32 iChannel = 0; - UInt32 iBit; - AudioChannelBitmap bitmap = pChannelLayout->mChannelBitmap; - for (iBit = 0; iBit < 32 && iChannel < channelMapCap; ++iBit) { - AudioChannelBitmap bit = bitmap & (1 << iBit); - if (bit != 0) { - pChannelMap[iChannel++] = ma_channel_from_AudioChannelBit(bit); - } - } - } else -#endif - { - /* - Need to use the tag to determine the channel map. For now I'm just assuming a default channel map, but later on this should - be updated to determine the mapping based on the tag. - */ - UInt32 channelCount; - - /* Our channel map retrieval APIs below take 32-bit integers, so we'll want to clamp the channel map capacity. */ - if (channelMapCap > 0xFFFFFFFF) { - channelMapCap = 0xFFFFFFFF; - } - - channelCount = ma_min(AudioChannelLayoutTag_GetNumberOfChannels(pChannelLayout->mChannelLayoutTag), (UInt32)channelMapCap); - - switch (pChannelLayout->mChannelLayoutTag) - { - case kAudioChannelLayoutTag_Mono: - case kAudioChannelLayoutTag_Stereo: - case kAudioChannelLayoutTag_StereoHeadphones: - case kAudioChannelLayoutTag_MatrixStereo: - case kAudioChannelLayoutTag_MidSide: - case kAudioChannelLayoutTag_XY: - case kAudioChannelLayoutTag_Binaural: - case kAudioChannelLayoutTag_Ambisonic_B_Format: - { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, channelCount); - } break; - - case kAudioChannelLayoutTag_Octagonal: - { - pChannelMap[7] = MA_CHANNEL_SIDE_RIGHT; - pChannelMap[6] = MA_CHANNEL_SIDE_LEFT; - } MA_FALLTHROUGH; /* Intentional fallthrough. */ - case kAudioChannelLayoutTag_Hexagonal: - { - pChannelMap[5] = MA_CHANNEL_BACK_CENTER; - } MA_FALLTHROUGH; /* Intentional fallthrough. */ - case kAudioChannelLayoutTag_Pentagonal: - { - pChannelMap[4] = MA_CHANNEL_FRONT_CENTER; - } MA_FALLTHROUGH; /* Intentional fallthrough. */ - case kAudioChannelLayoutTag_Quadraphonic: - { - pChannelMap[3] = MA_CHANNEL_BACK_RIGHT; - pChannelMap[2] = MA_CHANNEL_BACK_LEFT; - pChannelMap[1] = MA_CHANNEL_RIGHT; - pChannelMap[0] = MA_CHANNEL_LEFT; - } break; - - /* TODO: Add support for more tags here. */ - - default: - { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, channelCount); - } break; - } - } - - return MA_SUCCESS; -} - -#if (defined(MAC_OS_VERSION_12_0) && MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_VERSION_12_0) || \ - (defined(__IPHONE_15_0) && __IPHONE_OS_VERSION_MAX_ALLOWED >= __IPHONE_15_0) -#define AUDIO_OBJECT_PROPERTY_ELEMENT kAudioObjectPropertyElementMain -#else -/* kAudioObjectPropertyElementMaster is deprecated. */ -#define AUDIO_OBJECT_PROPERTY_ELEMENT kAudioObjectPropertyElementMaster -#endif - -static ma_result ma_get_device_object_ids__coreaudio(ma_context* pContext, UInt32* pDeviceCount, AudioObjectID** ppDeviceObjectIDs) /* NOTE: Free the returned buffer with ma_free(). */ -{ - AudioObjectPropertyAddress propAddressDevices; - UInt32 deviceObjectsDataSize; - OSStatus status; - AudioObjectID* pDeviceObjectIDs; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDeviceCount != NULL); - MA_ASSERT(ppDeviceObjectIDs != NULL); - - /* Safety. */ - *pDeviceCount = 0; - *ppDeviceObjectIDs = NULL; - - propAddressDevices.mSelector = kAudioHardwarePropertyDevices; - propAddressDevices.mScope = kAudioObjectPropertyScopeGlobal; - propAddressDevices.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - status = ((ma_AudioObjectGetPropertyDataSize_proc)pContext->coreaudio.AudioObjectGetPropertyDataSize)(kAudioObjectSystemObject, &propAddressDevices, 0, NULL, &deviceObjectsDataSize); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - pDeviceObjectIDs = (AudioObjectID*)ma_malloc(deviceObjectsDataSize, &pContext->allocationCallbacks); - if (pDeviceObjectIDs == NULL) { - return MA_OUT_OF_MEMORY; - } - - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(kAudioObjectSystemObject, &propAddressDevices, 0, NULL, &deviceObjectsDataSize, pDeviceObjectIDs); - if (status != noErr) { - ma_free(pDeviceObjectIDs, &pContext->allocationCallbacks); - return ma_result_from_OSStatus(status); - } - - *pDeviceCount = deviceObjectsDataSize / sizeof(AudioObjectID); - *ppDeviceObjectIDs = pDeviceObjectIDs; - - return MA_SUCCESS; -} - -static ma_result ma_get_AudioObject_uid_as_CFStringRef(ma_context* pContext, AudioObjectID objectID, CFStringRef* pUID) -{ - AudioObjectPropertyAddress propAddress; - UInt32 dataSize; - OSStatus status; - - MA_ASSERT(pContext != NULL); - - propAddress.mSelector = kAudioDevicePropertyDeviceUID; - propAddress.mScope = kAudioObjectPropertyScopeGlobal; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - dataSize = sizeof(*pUID); - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(objectID, &propAddress, 0, NULL, &dataSize, pUID); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - return MA_SUCCESS; -} - -static ma_result ma_get_AudioObject_uid(ma_context* pContext, AudioObjectID objectID, size_t bufferSize, char* bufferOut) -{ - CFStringRef uid; - ma_result result; - - MA_ASSERT(pContext != NULL); - - result = ma_get_AudioObject_uid_as_CFStringRef(pContext, objectID, &uid); - if (result != MA_SUCCESS) { - return result; - } - - if (!((ma_CFStringGetCString_proc)pContext->coreaudio.CFStringGetCString)(uid, bufferOut, bufferSize, kCFStringEncodingUTF8)) { - return MA_ERROR; - } - - ((ma_CFRelease_proc)pContext->coreaudio.CFRelease)(uid); - return MA_SUCCESS; -} - -static ma_result ma_get_AudioObject_name(ma_context* pContext, AudioObjectID objectID, size_t bufferSize, char* bufferOut) -{ - AudioObjectPropertyAddress propAddress; - CFStringRef deviceName = NULL; - UInt32 dataSize; - OSStatus status; - - MA_ASSERT(pContext != NULL); - - propAddress.mSelector = kAudioDevicePropertyDeviceNameCFString; - propAddress.mScope = kAudioObjectPropertyScopeGlobal; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - dataSize = sizeof(deviceName); - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(objectID, &propAddress, 0, NULL, &dataSize, &deviceName); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - if (!((ma_CFStringGetCString_proc)pContext->coreaudio.CFStringGetCString)(deviceName, bufferOut, bufferSize, kCFStringEncodingUTF8)) { - return MA_ERROR; - } - - ((ma_CFRelease_proc)pContext->coreaudio.CFRelease)(deviceName); - return MA_SUCCESS; -} - -static ma_bool32 ma_does_AudioObject_support_scope(ma_context* pContext, AudioObjectID deviceObjectID, AudioObjectPropertyScope scope) -{ - AudioObjectPropertyAddress propAddress; - UInt32 dataSize; - OSStatus status; - AudioBufferList* pBufferList; - ma_bool32 isSupported; - - MA_ASSERT(pContext != NULL); - - /* To know whether or not a device is an input device we need ot look at the stream configuration. If it has an output channel it's a playback device. */ - propAddress.mSelector = kAudioDevicePropertyStreamConfiguration; - propAddress.mScope = scope; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - status = ((ma_AudioObjectGetPropertyDataSize_proc)pContext->coreaudio.AudioObjectGetPropertyDataSize)(deviceObjectID, &propAddress, 0, NULL, &dataSize); - if (status != noErr) { - return MA_FALSE; - } - - pBufferList = (AudioBufferList*)ma_malloc(dataSize, &pContext->allocationCallbacks); - if (pBufferList == NULL) { - return MA_FALSE; /* Out of memory. */ - } - - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(deviceObjectID, &propAddress, 0, NULL, &dataSize, pBufferList); - if (status != noErr) { - ma_free(pBufferList, &pContext->allocationCallbacks); - return MA_FALSE; - } - - isSupported = MA_FALSE; - if (pBufferList->mNumberBuffers > 0) { - isSupported = MA_TRUE; - } - - ma_free(pBufferList, &pContext->allocationCallbacks); - return isSupported; -} - -static ma_bool32 ma_does_AudioObject_support_playback(ma_context* pContext, AudioObjectID deviceObjectID) -{ - return ma_does_AudioObject_support_scope(pContext, deviceObjectID, kAudioObjectPropertyScopeOutput); -} - -static ma_bool32 ma_does_AudioObject_support_capture(ma_context* pContext, AudioObjectID deviceObjectID) -{ - return ma_does_AudioObject_support_scope(pContext, deviceObjectID, kAudioObjectPropertyScopeInput); -} - - -static ma_result ma_get_AudioObject_stream_descriptions(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, UInt32* pDescriptionCount, AudioStreamRangedDescription** ppDescriptions) /* NOTE: Free the returned pointer with ma_free(). */ -{ - AudioObjectPropertyAddress propAddress; - UInt32 dataSize; - OSStatus status; - AudioStreamRangedDescription* pDescriptions; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDescriptionCount != NULL); - MA_ASSERT(ppDescriptions != NULL); - - /* - TODO: Experiment with kAudioStreamPropertyAvailablePhysicalFormats instead of (or in addition to) kAudioStreamPropertyAvailableVirtualFormats. My - MacBook Pro uses s24/32 format, however, which miniaudio does not currently support. - */ - propAddress.mSelector = kAudioStreamPropertyAvailableVirtualFormats; /*kAudioStreamPropertyAvailablePhysicalFormats;*/ - propAddress.mScope = (deviceType == ma_device_type_playback) ? kAudioObjectPropertyScopeOutput : kAudioObjectPropertyScopeInput; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - status = ((ma_AudioObjectGetPropertyDataSize_proc)pContext->coreaudio.AudioObjectGetPropertyDataSize)(deviceObjectID, &propAddress, 0, NULL, &dataSize); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - pDescriptions = (AudioStreamRangedDescription*)ma_malloc(dataSize, &pContext->allocationCallbacks); - if (pDescriptions == NULL) { - return MA_OUT_OF_MEMORY; - } - - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(deviceObjectID, &propAddress, 0, NULL, &dataSize, pDescriptions); - if (status != noErr) { - ma_free(pDescriptions, &pContext->allocationCallbacks); - return ma_result_from_OSStatus(status); - } - - *pDescriptionCount = dataSize / sizeof(*pDescriptions); - *ppDescriptions = pDescriptions; - return MA_SUCCESS; -} - - -static ma_result ma_get_AudioObject_channel_layout(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, AudioChannelLayout** ppChannelLayout) /* NOTE: Free the returned pointer with ma_free(). */ -{ - AudioObjectPropertyAddress propAddress; - UInt32 dataSize; - OSStatus status; - AudioChannelLayout* pChannelLayout; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(ppChannelLayout != NULL); - - *ppChannelLayout = NULL; /* Safety. */ - - propAddress.mSelector = kAudioDevicePropertyPreferredChannelLayout; - propAddress.mScope = (deviceType == ma_device_type_playback) ? kAudioObjectPropertyScopeOutput : kAudioObjectPropertyScopeInput; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - status = ((ma_AudioObjectGetPropertyDataSize_proc)pContext->coreaudio.AudioObjectGetPropertyDataSize)(deviceObjectID, &propAddress, 0, NULL, &dataSize); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - pChannelLayout = (AudioChannelLayout*)ma_malloc(dataSize, &pContext->allocationCallbacks); - if (pChannelLayout == NULL) { - return MA_OUT_OF_MEMORY; - } - - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(deviceObjectID, &propAddress, 0, NULL, &dataSize, pChannelLayout); - if (status != noErr) { - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return ma_result_from_OSStatus(status); - } - - *ppChannelLayout = pChannelLayout; - return MA_SUCCESS; -} - -static ma_result ma_get_AudioObject_channel_count(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, ma_uint32* pChannelCount) -{ - AudioChannelLayout* pChannelLayout; - ma_result result; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pChannelCount != NULL); - - *pChannelCount = 0; /* Safety. */ - - result = ma_get_AudioObject_channel_layout(pContext, deviceObjectID, deviceType, &pChannelLayout); - if (result != MA_SUCCESS) { - return result; - } - - if (pChannelLayout->mChannelLayoutTag == kAudioChannelLayoutTag_UseChannelDescriptions) { - *pChannelCount = pChannelLayout->mNumberChannelDescriptions; - } else if (pChannelLayout->mChannelLayoutTag == kAudioChannelLayoutTag_UseChannelBitmap) { - *pChannelCount = ma_count_set_bits(pChannelLayout->mChannelBitmap); - } else { - *pChannelCount = AudioChannelLayoutTag_GetNumberOfChannels(pChannelLayout->mChannelLayoutTag); - } - - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return MA_SUCCESS; -} - -#if 0 -static ma_result ma_get_AudioObject_channel_map(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, ma_channel* pChannelMap, size_t channelMapCap) -{ - AudioChannelLayout* pChannelLayout; - ma_result result; - - MA_ASSERT(pContext != NULL); - - result = ma_get_AudioObject_channel_layout(pContext, deviceObjectID, deviceType, &pChannelLayout); - if (result != MA_SUCCESS) { - return result; /* Rather than always failing here, would it be more robust to simply assume a default? */ - } - - result = ma_get_channel_map_from_AudioChannelLayout(pChannelLayout, pChannelMap, channelMapCap); - if (result != MA_SUCCESS) { - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return result; - } - - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return result; -} -#endif - -static ma_result ma_get_AudioObject_sample_rates(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, UInt32* pSampleRateRangesCount, AudioValueRange** ppSampleRateRanges) /* NOTE: Free the returned pointer with ma_free(). */ -{ - AudioObjectPropertyAddress propAddress; - UInt32 dataSize; - OSStatus status; - AudioValueRange* pSampleRateRanges; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pSampleRateRangesCount != NULL); - MA_ASSERT(ppSampleRateRanges != NULL); - - /* Safety. */ - *pSampleRateRangesCount = 0; - *ppSampleRateRanges = NULL; - - propAddress.mSelector = kAudioDevicePropertyAvailableNominalSampleRates; - propAddress.mScope = (deviceType == ma_device_type_playback) ? kAudioObjectPropertyScopeOutput : kAudioObjectPropertyScopeInput; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - status = ((ma_AudioObjectGetPropertyDataSize_proc)pContext->coreaudio.AudioObjectGetPropertyDataSize)(deviceObjectID, &propAddress, 0, NULL, &dataSize); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - pSampleRateRanges = (AudioValueRange*)ma_malloc(dataSize, &pContext->allocationCallbacks); - if (pSampleRateRanges == NULL) { - return MA_OUT_OF_MEMORY; - } - - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(deviceObjectID, &propAddress, 0, NULL, &dataSize, pSampleRateRanges); - if (status != noErr) { - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - return ma_result_from_OSStatus(status); - } - - *pSampleRateRangesCount = dataSize / sizeof(*pSampleRateRanges); - *ppSampleRateRanges = pSampleRateRanges; - return MA_SUCCESS; -} - -#if 0 -static ma_result ma_get_AudioObject_get_closest_sample_rate(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, ma_uint32 sampleRateIn, ma_uint32* pSampleRateOut) -{ - UInt32 sampleRateRangeCount; - AudioValueRange* pSampleRateRanges; - ma_result result; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pSampleRateOut != NULL); - - *pSampleRateOut = 0; /* Safety. */ - - result = ma_get_AudioObject_sample_rates(pContext, deviceObjectID, deviceType, &sampleRateRangeCount, &pSampleRateRanges); - if (result != MA_SUCCESS) { - return result; - } - - if (sampleRateRangeCount == 0) { - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - return MA_ERROR; /* Should never hit this case should we? */ - } - - if (sampleRateIn == 0) { - /* Search in order of miniaudio's preferred priority. */ - UInt32 iMALSampleRate; - for (iMALSampleRate = 0; iMALSampleRate < ma_countof(g_maStandardSampleRatePriorities); ++iMALSampleRate) { - ma_uint32 malSampleRate = g_maStandardSampleRatePriorities[iMALSampleRate]; - UInt32 iCASampleRate; - for (iCASampleRate = 0; iCASampleRate < sampleRateRangeCount; ++iCASampleRate) { - AudioValueRange caSampleRate = pSampleRateRanges[iCASampleRate]; - if (caSampleRate.mMinimum <= malSampleRate && caSampleRate.mMaximum >= malSampleRate) { - *pSampleRateOut = malSampleRate; - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - return MA_SUCCESS; - } - } - } - - /* - If we get here it means none of miniaudio's standard sample rates matched any of the supported sample rates from the device. In this - case we just fall back to the first one reported by Core Audio. - */ - MA_ASSERT(sampleRateRangeCount > 0); - - *pSampleRateOut = pSampleRateRanges[0].mMinimum; - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - return MA_SUCCESS; - } else { - /* Find the closest match to this sample rate. */ - UInt32 currentAbsoluteDifference = INT32_MAX; - UInt32 iCurrentClosestRange = (UInt32)-1; - UInt32 iRange; - for (iRange = 0; iRange < sampleRateRangeCount; ++iRange) { - if (pSampleRateRanges[iRange].mMinimum <= sampleRateIn && pSampleRateRanges[iRange].mMaximum >= sampleRateIn) { - *pSampleRateOut = sampleRateIn; - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - return MA_SUCCESS; - } else { - UInt32 absoluteDifference; - if (pSampleRateRanges[iRange].mMinimum > sampleRateIn) { - absoluteDifference = pSampleRateRanges[iRange].mMinimum - sampleRateIn; - } else { - absoluteDifference = sampleRateIn - pSampleRateRanges[iRange].mMaximum; - } - - if (currentAbsoluteDifference > absoluteDifference) { - currentAbsoluteDifference = absoluteDifference; - iCurrentClosestRange = iRange; - } - } - } - - MA_ASSERT(iCurrentClosestRange != (UInt32)-1); - - *pSampleRateOut = pSampleRateRanges[iCurrentClosestRange].mMinimum; - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - return MA_SUCCESS; - } - - /* Should never get here, but it would mean we weren't able to find any suitable sample rates. */ - /*ma_free(pSampleRateRanges, &pContext->allocationCallbacks);*/ - /*return MA_ERROR;*/ -} -#endif - -static ma_result ma_get_AudioObject_closest_buffer_size_in_frames(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, ma_uint32 bufferSizeInFramesIn, ma_uint32* pBufferSizeInFramesOut) -{ - AudioObjectPropertyAddress propAddress; - AudioValueRange bufferSizeRange; - UInt32 dataSize; - OSStatus status; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pBufferSizeInFramesOut != NULL); - - *pBufferSizeInFramesOut = 0; /* Safety. */ - - propAddress.mSelector = kAudioDevicePropertyBufferFrameSizeRange; - propAddress.mScope = (deviceType == ma_device_type_playback) ? kAudioObjectPropertyScopeOutput : kAudioObjectPropertyScopeInput; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - dataSize = sizeof(bufferSizeRange); - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(deviceObjectID, &propAddress, 0, NULL, &dataSize, &bufferSizeRange); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - /* This is just a clamp. */ - if (bufferSizeInFramesIn < bufferSizeRange.mMinimum) { - *pBufferSizeInFramesOut = (ma_uint32)bufferSizeRange.mMinimum; - } else if (bufferSizeInFramesIn > bufferSizeRange.mMaximum) { - *pBufferSizeInFramesOut = (ma_uint32)bufferSizeRange.mMaximum; - } else { - *pBufferSizeInFramesOut = bufferSizeInFramesIn; - } - - return MA_SUCCESS; -} - -static ma_result ma_set_AudioObject_buffer_size_in_frames(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, ma_uint32* pPeriodSizeInOut) -{ - ma_result result; - ma_uint32 chosenBufferSizeInFrames; - AudioObjectPropertyAddress propAddress; - UInt32 dataSize; - OSStatus status; - - MA_ASSERT(pContext != NULL); - - result = ma_get_AudioObject_closest_buffer_size_in_frames(pContext, deviceObjectID, deviceType, *pPeriodSizeInOut, &chosenBufferSizeInFrames); - if (result != MA_SUCCESS) { - return result; - } - - /* Try setting the size of the buffer... If this fails we just use whatever is currently set. */ - propAddress.mSelector = kAudioDevicePropertyBufferFrameSize; - propAddress.mScope = (deviceType == ma_device_type_playback) ? kAudioObjectPropertyScopeOutput : kAudioObjectPropertyScopeInput; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - ((ma_AudioObjectSetPropertyData_proc)pContext->coreaudio.AudioObjectSetPropertyData)(deviceObjectID, &propAddress, 0, NULL, sizeof(chosenBufferSizeInFrames), &chosenBufferSizeInFrames); - - /* Get the actual size of the buffer. */ - dataSize = sizeof(*pPeriodSizeInOut); - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(deviceObjectID, &propAddress, 0, NULL, &dataSize, &chosenBufferSizeInFrames); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - *pPeriodSizeInOut = chosenBufferSizeInFrames; - return MA_SUCCESS; -} - -static ma_result ma_find_default_AudioObjectID(ma_context* pContext, ma_device_type deviceType, AudioObjectID* pDeviceObjectID) -{ - AudioObjectPropertyAddress propAddressDefaultDevice; - UInt32 defaultDeviceObjectIDSize = sizeof(AudioObjectID); - AudioObjectID defaultDeviceObjectID; - OSStatus status; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDeviceObjectID != NULL); - - /* Safety. */ - *pDeviceObjectID = 0; - - propAddressDefaultDevice.mScope = kAudioObjectPropertyScopeGlobal; - propAddressDefaultDevice.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - if (deviceType == ma_device_type_playback) { - propAddressDefaultDevice.mSelector = kAudioHardwarePropertyDefaultOutputDevice; - } else { - propAddressDefaultDevice.mSelector = kAudioHardwarePropertyDefaultInputDevice; - } - - defaultDeviceObjectIDSize = sizeof(AudioObjectID); - status = ((ma_AudioObjectGetPropertyData_proc)pContext->coreaudio.AudioObjectGetPropertyData)(kAudioObjectSystemObject, &propAddressDefaultDevice, 0, NULL, &defaultDeviceObjectIDSize, &defaultDeviceObjectID); - if (status == noErr) { - *pDeviceObjectID = defaultDeviceObjectID; - return MA_SUCCESS; - } - - /* If we get here it means we couldn't find the device. */ - return MA_NO_DEVICE; -} - -static ma_result ma_find_AudioObjectID(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, AudioObjectID* pDeviceObjectID) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDeviceObjectID != NULL); - - /* Safety. */ - *pDeviceObjectID = 0; - - if (pDeviceID == NULL) { - /* Default device. */ - return ma_find_default_AudioObjectID(pContext, deviceType, pDeviceObjectID); - } else { - /* Explicit device. */ - UInt32 deviceCount; - AudioObjectID* pDeviceObjectIDs; - ma_result result; - UInt32 iDevice; - - result = ma_get_device_object_ids__coreaudio(pContext, &deviceCount, &pDeviceObjectIDs); - if (result != MA_SUCCESS) { - return result; - } - - for (iDevice = 0; iDevice < deviceCount; ++iDevice) { - AudioObjectID deviceObjectID = pDeviceObjectIDs[iDevice]; - - char uid[256]; - if (ma_get_AudioObject_uid(pContext, deviceObjectID, sizeof(uid), uid) != MA_SUCCESS) { - continue; - } - - if (deviceType == ma_device_type_playback) { - if (ma_does_AudioObject_support_playback(pContext, deviceObjectID)) { - if (strcmp(uid, pDeviceID->coreaudio) == 0) { - *pDeviceObjectID = deviceObjectID; - ma_free(pDeviceObjectIDs, &pContext->allocationCallbacks); - return MA_SUCCESS; - } - } - } else { - if (ma_does_AudioObject_support_capture(pContext, deviceObjectID)) { - if (strcmp(uid, pDeviceID->coreaudio) == 0) { - *pDeviceObjectID = deviceObjectID; - ma_free(pDeviceObjectIDs, &pContext->allocationCallbacks); - return MA_SUCCESS; - } - } - } - } - - ma_free(pDeviceObjectIDs, &pContext->allocationCallbacks); - } - - /* If we get here it means we couldn't find the device. */ - return MA_NO_DEVICE; -} - - -static ma_result ma_find_best_format__coreaudio(ma_context* pContext, AudioObjectID deviceObjectID, ma_device_type deviceType, ma_format format, ma_uint32 channels, ma_uint32 sampleRate, const AudioStreamBasicDescription* pOrigFormat, AudioStreamBasicDescription* pFormat) -{ - UInt32 deviceFormatDescriptionCount; - AudioStreamRangedDescription* pDeviceFormatDescriptions; - ma_result result; - ma_uint32 desiredSampleRate; - ma_uint32 desiredChannelCount; - ma_format desiredFormat; - AudioStreamBasicDescription bestDeviceFormatSoFar; - ma_bool32 hasSupportedFormat; - UInt32 iFormat; - - result = ma_get_AudioObject_stream_descriptions(pContext, deviceObjectID, deviceType, &deviceFormatDescriptionCount, &pDeviceFormatDescriptions); - if (result != MA_SUCCESS) { - return result; - } - - desiredSampleRate = sampleRate; - if (desiredSampleRate == 0) { - desiredSampleRate = pOrigFormat->mSampleRate; - } - - desiredChannelCount = channels; - if (desiredChannelCount == 0) { - desiredChannelCount = pOrigFormat->mChannelsPerFrame; - } - - desiredFormat = format; - if (desiredFormat == ma_format_unknown) { - result = ma_format_from_AudioStreamBasicDescription(pOrigFormat, &desiredFormat); - if (result != MA_SUCCESS || desiredFormat == ma_format_unknown) { - desiredFormat = g_maFormatPriorities[0]; - } - } - - /* - If we get here it means we don't have an exact match to what the client is asking for. We'll need to find the closest one. The next - loop will check for formats that have the same sample rate to what we're asking for. If there is, we prefer that one in all cases. - */ - MA_ZERO_OBJECT(&bestDeviceFormatSoFar); - - hasSupportedFormat = MA_FALSE; - for (iFormat = 0; iFormat < deviceFormatDescriptionCount; ++iFormat) { - ma_format format; - ma_result formatResult = ma_format_from_AudioStreamBasicDescription(&pDeviceFormatDescriptions[iFormat].mFormat, &format); - if (formatResult == MA_SUCCESS && format != ma_format_unknown) { - hasSupportedFormat = MA_TRUE; - bestDeviceFormatSoFar = pDeviceFormatDescriptions[iFormat].mFormat; - break; - } - } - - if (!hasSupportedFormat) { - ma_free(pDeviceFormatDescriptions, &pContext->allocationCallbacks); - return MA_FORMAT_NOT_SUPPORTED; - } - - - for (iFormat = 0; iFormat < deviceFormatDescriptionCount; ++iFormat) { - AudioStreamBasicDescription thisDeviceFormat = pDeviceFormatDescriptions[iFormat].mFormat; - ma_format thisSampleFormat; - ma_result formatResult; - ma_format bestSampleFormatSoFar; - - /* If the format is not supported by miniaudio we need to skip this one entirely. */ - formatResult = ma_format_from_AudioStreamBasicDescription(&pDeviceFormatDescriptions[iFormat].mFormat, &thisSampleFormat); - if (formatResult != MA_SUCCESS || thisSampleFormat == ma_format_unknown) { - continue; /* The format is not supported by miniaudio. Skip. */ - } - - ma_format_from_AudioStreamBasicDescription(&bestDeviceFormatSoFar, &bestSampleFormatSoFar); - - /* Getting here means the format is supported by miniaudio which makes this format a candidate. */ - if (thisDeviceFormat.mSampleRate != desiredSampleRate) { - /* - The sample rate does not match, but this format could still be usable, although it's a very low priority. If the best format - so far has an equal sample rate we can just ignore this one. - */ - if (bestDeviceFormatSoFar.mSampleRate == desiredSampleRate) { - continue; /* The best sample rate so far has the same sample rate as what we requested which means it's still the best so far. Skip this format. */ - } else { - /* In this case, neither the best format so far nor this one have the same sample rate. Check the channel count next. */ - if (thisDeviceFormat.mChannelsPerFrame != desiredChannelCount) { - /* This format has a different sample rate _and_ a different channel count. */ - if (bestDeviceFormatSoFar.mChannelsPerFrame == desiredChannelCount) { - continue; /* No change to the best format. */ - } else { - /* - Both this format and the best so far have different sample rates and different channel counts. Whichever has the - best format is the new best. - */ - if (ma_get_format_priority_index(thisSampleFormat) < ma_get_format_priority_index(bestSampleFormatSoFar)) { - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } else { - continue; /* No change to the best format. */ - } - } - } else { - /* This format has a different sample rate but the desired channel count. */ - if (bestDeviceFormatSoFar.mChannelsPerFrame == desiredChannelCount) { - /* Both this format and the best so far have the desired channel count. Whichever has the best format is the new best. */ - if (ma_get_format_priority_index(thisSampleFormat) < ma_get_format_priority_index(bestSampleFormatSoFar)) { - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } else { - continue; /* No change to the best format for now. */ - } - } else { - /* This format has the desired channel count, but the best so far does not. We have a new best. */ - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } - } - } - } else { - /* - The sample rates match which makes this format a very high priority contender. If the best format so far has a different - sample rate it needs to be replaced with this one. - */ - if (bestDeviceFormatSoFar.mSampleRate != desiredSampleRate) { - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } else { - /* In this case both this format and the best format so far have the same sample rate. Check the channel count next. */ - if (thisDeviceFormat.mChannelsPerFrame == desiredChannelCount) { - /* - In this case this format has the same channel count as what the client is requesting. If the best format so far has - a different count, this one becomes the new best. - */ - if (bestDeviceFormatSoFar.mChannelsPerFrame != desiredChannelCount) { - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } else { - /* In this case both this format and the best so far have the ideal sample rate and channel count. Check the format. */ - if (thisSampleFormat == desiredFormat) { - bestDeviceFormatSoFar = thisDeviceFormat; - break; /* Found the exact match. */ - } else { - /* The formats are different. The new best format is the one with the highest priority format according to miniaudio. */ - if (ma_get_format_priority_index(thisSampleFormat) < ma_get_format_priority_index(bestSampleFormatSoFar)) { - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } else { - continue; /* No change to the best format for now. */ - } - } - } - } else { - /* - In this case the channel count is different to what the client has requested. If the best so far has the same channel - count as the requested count then it remains the best. - */ - if (bestDeviceFormatSoFar.mChannelsPerFrame == desiredChannelCount) { - continue; - } else { - /* - This is the case where both have the same sample rate (good) but different channel counts. Right now both have about - the same priority, but we need to compare the format now. - */ - if (thisSampleFormat == bestSampleFormatSoFar) { - if (ma_get_format_priority_index(thisSampleFormat) < ma_get_format_priority_index(bestSampleFormatSoFar)) { - bestDeviceFormatSoFar = thisDeviceFormat; - continue; - } else { - continue; /* No change to the best format for now. */ - } - } - } - } - } - } - } - - *pFormat = bestDeviceFormatSoFar; - - ma_free(pDeviceFormatDescriptions, &pContext->allocationCallbacks); - return MA_SUCCESS; -} - -static ma_result ma_get_AudioUnit_channel_map(ma_context* pContext, AudioUnit audioUnit, ma_device_type deviceType, ma_channel* pChannelMap, size_t channelMapCap) -{ - AudioUnitScope deviceScope; - AudioUnitElement deviceBus; - UInt32 channelLayoutSize; - OSStatus status; - AudioChannelLayout* pChannelLayout; - ma_result result; - - MA_ASSERT(pContext != NULL); - - if (deviceType == ma_device_type_playback) { - deviceScope = kAudioUnitScope_Input; - deviceBus = MA_COREAUDIO_OUTPUT_BUS; - } else { - deviceScope = kAudioUnitScope_Output; - deviceBus = MA_COREAUDIO_INPUT_BUS; - } - - status = ((ma_AudioUnitGetPropertyInfo_proc)pContext->coreaudio.AudioUnitGetPropertyInfo)(audioUnit, kAudioUnitProperty_AudioChannelLayout, deviceScope, deviceBus, &channelLayoutSize, NULL); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - pChannelLayout = (AudioChannelLayout*)ma_malloc(channelLayoutSize, &pContext->allocationCallbacks); - if (pChannelLayout == NULL) { - return MA_OUT_OF_MEMORY; - } - - status = ((ma_AudioUnitGetProperty_proc)pContext->coreaudio.AudioUnitGetProperty)(audioUnit, kAudioUnitProperty_AudioChannelLayout, deviceScope, deviceBus, pChannelLayout, &channelLayoutSize); - if (status != noErr) { - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return ma_result_from_OSStatus(status); - } - - result = ma_get_channel_map_from_AudioChannelLayout(pChannelLayout, pChannelMap, channelMapCap); - if (result != MA_SUCCESS) { - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return result; - } - - ma_free(pChannelLayout, &pContext->allocationCallbacks); - return MA_SUCCESS; -} -#endif /* MA_APPLE_DESKTOP */ - - -#if !defined(MA_APPLE_DESKTOP) -static void ma_AVAudioSessionPortDescription_to_device_info(AVAudioSessionPortDescription* pPortDesc, ma_device_info* pInfo) -{ - MA_ZERO_OBJECT(pInfo); - ma_strncpy_s(pInfo->name, sizeof(pInfo->name), [pPortDesc.portName UTF8String], (size_t)-1); - ma_strncpy_s(pInfo->id.coreaudio, sizeof(pInfo->id.coreaudio), [pPortDesc.UID UTF8String], (size_t)-1); -} -#endif - -static ma_result ma_context_enumerate_devices__coreaudio(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ -#if defined(MA_APPLE_DESKTOP) - UInt32 deviceCount; - AudioObjectID* pDeviceObjectIDs; - AudioObjectID defaultDeviceObjectIDPlayback; - AudioObjectID defaultDeviceObjectIDCapture; - ma_result result; - UInt32 iDevice; - - ma_find_default_AudioObjectID(pContext, ma_device_type_playback, &defaultDeviceObjectIDPlayback); /* OK if this fails. */ - ma_find_default_AudioObjectID(pContext, ma_device_type_capture, &defaultDeviceObjectIDCapture); /* OK if this fails. */ - - result = ma_get_device_object_ids__coreaudio(pContext, &deviceCount, &pDeviceObjectIDs); - if (result != MA_SUCCESS) { - return result; - } - - for (iDevice = 0; iDevice < deviceCount; ++iDevice) { - AudioObjectID deviceObjectID = pDeviceObjectIDs[iDevice]; - ma_device_info info; - - MA_ZERO_OBJECT(&info); - if (ma_get_AudioObject_uid(pContext, deviceObjectID, sizeof(info.id.coreaudio), info.id.coreaudio) != MA_SUCCESS) { - continue; - } - if (ma_get_AudioObject_name(pContext, deviceObjectID, sizeof(info.name), info.name) != MA_SUCCESS) { - continue; - } - - if (ma_does_AudioObject_support_playback(pContext, deviceObjectID)) { - if (deviceObjectID == defaultDeviceObjectIDPlayback) { - info.isDefault = MA_TRUE; - } - - if (!callback(pContext, ma_device_type_playback, &info, pUserData)) { - break; - } - } - if (ma_does_AudioObject_support_capture(pContext, deviceObjectID)) { - if (deviceObjectID == defaultDeviceObjectIDCapture) { - info.isDefault = MA_TRUE; - } - - if (!callback(pContext, ma_device_type_capture, &info, pUserData)) { - break; - } - } - } - - ma_free(pDeviceObjectIDs, &pContext->allocationCallbacks); -#else - ma_device_info info; - NSArray *pInputs = [[[AVAudioSession sharedInstance] currentRoute] inputs]; - NSArray *pOutputs = [[[AVAudioSession sharedInstance] currentRoute] outputs]; - - for (AVAudioSessionPortDescription* pPortDesc in pOutputs) { - ma_AVAudioSessionPortDescription_to_device_info(pPortDesc, &info); - if (!callback(pContext, ma_device_type_playback, &info, pUserData)) { - return MA_SUCCESS; - } - } - - for (AVAudioSessionPortDescription* pPortDesc in pInputs) { - ma_AVAudioSessionPortDescription_to_device_info(pPortDesc, &info); - if (!callback(pContext, ma_device_type_capture, &info, pUserData)) { - return MA_SUCCESS; - } - } -#endif - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__coreaudio(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_result result; - - MA_ASSERT(pContext != NULL); - -#if defined(MA_APPLE_DESKTOP) - /* Desktop */ - { - AudioObjectID deviceObjectID; - AudioObjectID defaultDeviceObjectID; - UInt32 streamDescriptionCount; - AudioStreamRangedDescription* pStreamDescriptions; - UInt32 iStreamDescription; - UInt32 sampleRateRangeCount; - AudioValueRange* pSampleRateRanges; - - ma_find_default_AudioObjectID(pContext, deviceType, &defaultDeviceObjectID); /* OK if this fails. */ - - result = ma_find_AudioObjectID(pContext, deviceType, pDeviceID, &deviceObjectID); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_get_AudioObject_uid(pContext, deviceObjectID, sizeof(pDeviceInfo->id.coreaudio), pDeviceInfo->id.coreaudio); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_get_AudioObject_name(pContext, deviceObjectID, sizeof(pDeviceInfo->name), pDeviceInfo->name); - if (result != MA_SUCCESS) { - return result; - } - - if (deviceObjectID == defaultDeviceObjectID) { - pDeviceInfo->isDefault = MA_TRUE; - } - - /* - There could be a large number of permutations here. Fortunately there is only a single channel count - being reported which reduces this quite a bit. For sample rates we're only reporting those that are - one of miniaudio's recognized "standard" rates. If there are still more formats than can fit into - our fixed sized array we'll just need to truncate them. This is unlikely and will probably only happen - if some driver performs software data conversion and therefore reports every possible format and - sample rate. - */ - pDeviceInfo->nativeDataFormatCount = 0; - - /* Formats. */ - { - ma_format uniqueFormats[ma_format_count]; - ma_uint32 uniqueFormatCount = 0; - ma_uint32 channels; - - /* Channels. */ - result = ma_get_AudioObject_channel_count(pContext, deviceObjectID, deviceType, &channels); - if (result != MA_SUCCESS) { - return result; - } - - /* Formats. */ - result = ma_get_AudioObject_stream_descriptions(pContext, deviceObjectID, deviceType, &streamDescriptionCount, &pStreamDescriptions); - if (result != MA_SUCCESS) { - return result; - } - - for (iStreamDescription = 0; iStreamDescription < streamDescriptionCount; ++iStreamDescription) { - ma_format format; - ma_bool32 hasFormatBeenHandled = MA_FALSE; - ma_uint32 iOutputFormat; - ma_uint32 iSampleRate; - - result = ma_format_from_AudioStreamBasicDescription(&pStreamDescriptions[iStreamDescription].mFormat, &format); - if (result != MA_SUCCESS) { - continue; - } - - MA_ASSERT(format != ma_format_unknown); - - /* Make sure the format isn't already in the output list. */ - for (iOutputFormat = 0; iOutputFormat < uniqueFormatCount; ++iOutputFormat) { - if (uniqueFormats[iOutputFormat] == format) { - hasFormatBeenHandled = MA_TRUE; - break; - } - } - - /* If we've already handled this format just skip it. */ - if (hasFormatBeenHandled) { - continue; - } - - uniqueFormats[uniqueFormatCount] = format; - uniqueFormatCount += 1; - - /* Sample Rates */ - result = ma_get_AudioObject_sample_rates(pContext, deviceObjectID, deviceType, &sampleRateRangeCount, &pSampleRateRanges); - if (result != MA_SUCCESS) { - return result; - } - - /* - Annoyingly Core Audio reports a sample rate range. We just get all the standard rates that are - between this range. - */ - for (iSampleRate = 0; iSampleRate < sampleRateRangeCount; ++iSampleRate) { - ma_uint32 iStandardSampleRate; - for (iStandardSampleRate = 0; iStandardSampleRate < ma_countof(g_maStandardSampleRatePriorities); iStandardSampleRate += 1) { - ma_uint32 standardSampleRate = g_maStandardSampleRatePriorities[iStandardSampleRate]; - if (standardSampleRate >= pSampleRateRanges[iSampleRate].mMinimum && standardSampleRate <= pSampleRateRanges[iSampleRate].mMaximum) { - /* We have a new data format. Add it to the list. */ - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = format; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = standardSampleRate; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = 0; - pDeviceInfo->nativeDataFormatCount += 1; - - if (pDeviceInfo->nativeDataFormatCount >= ma_countof(pDeviceInfo->nativeDataFormats)) { - break; /* No more room for any more formats. */ - } - } - } - } - - ma_free(pSampleRateRanges, &pContext->allocationCallbacks); - - if (pDeviceInfo->nativeDataFormatCount >= ma_countof(pDeviceInfo->nativeDataFormats)) { - break; /* No more room for any more formats. */ - } - } - - ma_free(pStreamDescriptions, &pContext->allocationCallbacks); - } - } -#else - /* Mobile */ - { - AudioComponentDescription desc; - AudioComponent component; - AudioUnit audioUnit; - OSStatus status; - AudioUnitScope formatScope; - AudioUnitElement formatElement; - AudioStreamBasicDescription bestFormat; - UInt32 propSize; - - /* We want to ensure we use a consistent device name to device enumeration. */ - if (pDeviceID != NULL && pDeviceID->coreaudio[0] != '\0') { - ma_bool32 found = MA_FALSE; - if (deviceType == ma_device_type_playback) { - NSArray *pOutputs = [[[AVAudioSession sharedInstance] currentRoute] outputs]; - for (AVAudioSessionPortDescription* pPortDesc in pOutputs) { - if (strcmp(pDeviceID->coreaudio, [pPortDesc.UID UTF8String]) == 0) { - ma_AVAudioSessionPortDescription_to_device_info(pPortDesc, pDeviceInfo); - found = MA_TRUE; - break; - } - } - } else { - NSArray *pInputs = [[[AVAudioSession sharedInstance] currentRoute] inputs]; - for (AVAudioSessionPortDescription* pPortDesc in pInputs) { - if (strcmp(pDeviceID->coreaudio, [pPortDesc.UID UTF8String]) == 0) { - ma_AVAudioSessionPortDescription_to_device_info(pPortDesc, pDeviceInfo); - found = MA_TRUE; - break; - } - } - } - - if (!found) { - return MA_DOES_NOT_EXIST; - } - } else { - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - } - - - /* - Retrieving device information is more annoying on mobile than desktop. For simplicity I'm locking this down to whatever format is - reported on a temporary I/O unit. The problem, however, is that this doesn't return a value for the sample rate which we need to - retrieve from the AVAudioSession shared instance. - */ - desc.componentType = kAudioUnitType_Output; - desc.componentSubType = kAudioUnitSubType_RemoteIO; - desc.componentManufacturer = kAudioUnitManufacturer_Apple; - desc.componentFlags = 0; - desc.componentFlagsMask = 0; - - component = ((ma_AudioComponentFindNext_proc)pContext->coreaudio.AudioComponentFindNext)(NULL, &desc); - if (component == NULL) { - return MA_FAILED_TO_INIT_BACKEND; - } - - status = ((ma_AudioComponentInstanceNew_proc)pContext->coreaudio.AudioComponentInstanceNew)(component, &audioUnit); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - formatScope = (deviceType == ma_device_type_playback) ? kAudioUnitScope_Input : kAudioUnitScope_Output; - formatElement = (deviceType == ma_device_type_playback) ? MA_COREAUDIO_OUTPUT_BUS : MA_COREAUDIO_INPUT_BUS; - - propSize = sizeof(bestFormat); - status = ((ma_AudioUnitGetProperty_proc)pContext->coreaudio.AudioUnitGetProperty)(audioUnit, kAudioUnitProperty_StreamFormat, formatScope, formatElement, &bestFormat, &propSize); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(audioUnit); - return ma_result_from_OSStatus(status); - } - - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(audioUnit); - audioUnit = NULL; - - /* Only a single format is being reported for iOS. */ - pDeviceInfo->nativeDataFormatCount = 1; - - result = ma_format_from_AudioStreamBasicDescription(&bestFormat, &pDeviceInfo->nativeDataFormats[0].format); - if (result != MA_SUCCESS) { - return result; - } - - pDeviceInfo->nativeDataFormats[0].channels = bestFormat.mChannelsPerFrame; - - /* - It looks like Apple are wanting to push the whole AVAudioSession thing. Thus, we need to use that to determine device settings. To do - this we just get the shared instance and inspect. - */ - @autoreleasepool { - AVAudioSession* pAudioSession = [AVAudioSession sharedInstance]; - MA_ASSERT(pAudioSession != NULL); - - pDeviceInfo->nativeDataFormats[0].sampleRate = (ma_uint32)pAudioSession.sampleRate; - } - } -#endif - - (void)pDeviceInfo; /* Unused. */ - return MA_SUCCESS; -} - -static AudioBufferList* ma_allocate_AudioBufferList__coreaudio(ma_uint32 sizeInFrames, ma_format format, ma_uint32 channels, ma_stream_layout layout, const ma_allocation_callbacks* pAllocationCallbacks) -{ - AudioBufferList* pBufferList; - UInt32 audioBufferSizeInBytes; - size_t allocationSize; - - MA_ASSERT(sizeInFrames > 0); - MA_ASSERT(format != ma_format_unknown); - MA_ASSERT(channels > 0); - - allocationSize = sizeof(AudioBufferList) - sizeof(AudioBuffer); /* Subtract sizeof(AudioBuffer) because that part is dynamically sized. */ - if (layout == ma_stream_layout_interleaved) { - /* Interleaved case. This is the simple case because we just have one buffer. */ - allocationSize += sizeof(AudioBuffer) * 1; - } else { - /* Non-interleaved case. This is the more complex case because there's more than one buffer. */ - allocationSize += sizeof(AudioBuffer) * channels; - } - - allocationSize += sizeInFrames * ma_get_bytes_per_frame(format, channels); - - pBufferList = (AudioBufferList*)ma_malloc(allocationSize, pAllocationCallbacks); - if (pBufferList == NULL) { - return NULL; - } - - audioBufferSizeInBytes = (UInt32)(sizeInFrames * ma_get_bytes_per_sample(format)); - - if (layout == ma_stream_layout_interleaved) { - pBufferList->mNumberBuffers = 1; - pBufferList->mBuffers[0].mNumberChannels = channels; - pBufferList->mBuffers[0].mDataByteSize = audioBufferSizeInBytes * channels; - pBufferList->mBuffers[0].mData = (ma_uint8*)pBufferList + sizeof(AudioBufferList); - } else { - ma_uint32 iBuffer; - pBufferList->mNumberBuffers = channels; - for (iBuffer = 0; iBuffer < pBufferList->mNumberBuffers; ++iBuffer) { - pBufferList->mBuffers[iBuffer].mNumberChannels = 1; - pBufferList->mBuffers[iBuffer].mDataByteSize = audioBufferSizeInBytes; - pBufferList->mBuffers[iBuffer].mData = (ma_uint8*)pBufferList + ((sizeof(AudioBufferList) - sizeof(AudioBuffer)) + (sizeof(AudioBuffer) * channels)) + (audioBufferSizeInBytes * iBuffer); - } - } - - return pBufferList; -} - -static ma_result ma_device_realloc_AudioBufferList__coreaudio(ma_device* pDevice, ma_uint32 sizeInFrames, ma_format format, ma_uint32 channels, ma_stream_layout layout) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(format != ma_format_unknown); - MA_ASSERT(channels > 0); - - /* Only resize the buffer if necessary. */ - if (pDevice->coreaudio.audioBufferCapInFrames < sizeInFrames) { - AudioBufferList* pNewAudioBufferList; - - pNewAudioBufferList = ma_allocate_AudioBufferList__coreaudio(sizeInFrames, format, channels, layout, &pDevice->pContext->allocationCallbacks); - if (pNewAudioBufferList == NULL) { - return MA_OUT_OF_MEMORY; - } - - /* At this point we'll have a new AudioBufferList and we can free the old one. */ - ma_free(pDevice->coreaudio.pAudioBufferList, &pDevice->pContext->allocationCallbacks); - pDevice->coreaudio.pAudioBufferList = pNewAudioBufferList; - pDevice->coreaudio.audioBufferCapInFrames = sizeInFrames; - } - - /* Getting here means the capacity of the audio is fine. */ - return MA_SUCCESS; -} - - -static OSStatus ma_on_output__coreaudio(void* pUserData, AudioUnitRenderActionFlags* pActionFlags, const AudioTimeStamp* pTimeStamp, UInt32 busNumber, UInt32 frameCount, AudioBufferList* pBufferList) -{ - ma_device* pDevice = (ma_device*)pUserData; - ma_stream_layout layout; - - MA_ASSERT(pDevice != NULL); - - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "INFO: Output Callback: busNumber=%d, frameCount=%d, mNumberBuffers=%d\n", (int)busNumber, (int)frameCount, (int)pBufferList->mNumberBuffers);*/ - - /* We need to check whether or not we are outputting interleaved or non-interleaved samples. The way we do this is slightly different for each type. */ - layout = ma_stream_layout_interleaved; - if (pBufferList->mBuffers[0].mNumberChannels != pDevice->playback.internalChannels) { - layout = ma_stream_layout_deinterleaved; - } - - if (layout == ma_stream_layout_interleaved) { - /* For now we can assume everything is interleaved. */ - UInt32 iBuffer; - for (iBuffer = 0; iBuffer < pBufferList->mNumberBuffers; ++iBuffer) { - if (pBufferList->mBuffers[iBuffer].mNumberChannels == pDevice->playback.internalChannels) { - ma_uint32 frameCountForThisBuffer = pBufferList->mBuffers[iBuffer].mDataByteSize / ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - if (frameCountForThisBuffer > 0) { - ma_device_handle_backend_data_callback(pDevice, pBufferList->mBuffers[iBuffer].mData, NULL, frameCountForThisBuffer); - } - - /*a_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, " frameCount=%d, mNumberChannels=%d, mDataByteSize=%d\n", (int)frameCount, (int)pBufferList->mBuffers[iBuffer].mNumberChannels, (int)pBufferList->mBuffers[iBuffer].mDataByteSize);*/ - } else { - /* - This case is where the number of channels in the output buffer do not match our internal channels. It could mean that it's - not interleaved, in which case we can't handle right now since miniaudio does not yet support non-interleaved streams. We just - output silence here. - */ - MA_ZERO_MEMORY(pBufferList->mBuffers[iBuffer].mData, pBufferList->mBuffers[iBuffer].mDataByteSize); - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, " WARNING: Outputting silence. frameCount=%d, mNumberChannels=%d, mDataByteSize=%d\n", (int)frameCount, (int)pBufferList->mBuffers[iBuffer].mNumberChannels, (int)pBufferList->mBuffers[iBuffer].mDataByteSize);*/ - } - } - } else { - /* This is the deinterleaved case. We need to update each buffer in groups of internalChannels. This assumes each buffer is the same size. */ - MA_ASSERT(pDevice->playback.internalChannels <= MA_MAX_CHANNELS); /* This should heve been validated at initialization time. */ - - /* - For safety we'll check that the internal channels is a multiple of the buffer count. If it's not it means something - very strange has happened and we're not going to support it. - */ - if ((pBufferList->mNumberBuffers % pDevice->playback.internalChannels) == 0) { - ma_uint8 tempBuffer[4096]; - UInt32 iBuffer; - - for (iBuffer = 0; iBuffer < pBufferList->mNumberBuffers; iBuffer += pDevice->playback.internalChannels) { - ma_uint32 frameCountPerBuffer = pBufferList->mBuffers[iBuffer].mDataByteSize / ma_get_bytes_per_sample(pDevice->playback.internalFormat); - ma_uint32 framesRemaining = frameCountPerBuffer; - - while (framesRemaining > 0) { - void* ppDeinterleavedBuffers[MA_MAX_CHANNELS]; - ma_uint32 iChannel; - ma_uint32 framesToRead = sizeof(tempBuffer) / ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - if (framesToRead > framesRemaining) { - framesToRead = framesRemaining; - } - - ma_device_handle_backend_data_callback(pDevice, tempBuffer, NULL, framesToRead); - - for (iChannel = 0; iChannel < pDevice->playback.internalChannels; ++iChannel) { - ppDeinterleavedBuffers[iChannel] = (void*)ma_offset_ptr(pBufferList->mBuffers[iBuffer+iChannel].mData, (frameCountPerBuffer - framesRemaining) * ma_get_bytes_per_sample(pDevice->playback.internalFormat)); - } - - ma_deinterleave_pcm_frames(pDevice->playback.internalFormat, pDevice->playback.internalChannels, framesToRead, tempBuffer, ppDeinterleavedBuffers); - - framesRemaining -= framesToRead; - } - } - } - } - - (void)pActionFlags; - (void)pTimeStamp; - (void)busNumber; - (void)frameCount; - - return noErr; -} - -static OSStatus ma_on_input__coreaudio(void* pUserData, AudioUnitRenderActionFlags* pActionFlags, const AudioTimeStamp* pTimeStamp, UInt32 busNumber, UInt32 frameCount, AudioBufferList* pUnusedBufferList) -{ - ma_device* pDevice = (ma_device*)pUserData; - AudioBufferList* pRenderedBufferList; - ma_result result; - ma_stream_layout layout; - ma_uint32 iBuffer; - OSStatus status; - - MA_ASSERT(pDevice != NULL); - - pRenderedBufferList = (AudioBufferList*)pDevice->coreaudio.pAudioBufferList; - MA_ASSERT(pRenderedBufferList); - - /* We need to check whether or not we are outputting interleaved or non-interleaved samples. The way we do this is slightly different for each type. */ - layout = ma_stream_layout_interleaved; - if (pRenderedBufferList->mBuffers[0].mNumberChannels != pDevice->capture.internalChannels) { - layout = ma_stream_layout_deinterleaved; - } - - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "INFO: Input Callback: busNumber=%d, frameCount=%d, mNumberBuffers=%d\n", (int)busNumber, (int)frameCount, (int)pRenderedBufferList->mNumberBuffers);*/ - - /* - There has been a situation reported where frame count passed into this function is greater than the capacity of - our capture buffer. There doesn't seem to be a reliable way to determine what the maximum frame count will be, - so we need to instead resort to dynamically reallocating our buffer to ensure it's large enough to capture the - number of frames requested by this callback. - */ - result = ma_device_realloc_AudioBufferList__coreaudio(pDevice, frameCount, pDevice->capture.internalFormat, pDevice->capture.internalChannels, layout); - if (result != MA_SUCCESS) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "Failed to allocate AudioBufferList for capture.\n"); - return noErr; - } - - pRenderedBufferList = (AudioBufferList*)pDevice->coreaudio.pAudioBufferList; - MA_ASSERT(pRenderedBufferList); - - /* - When you call AudioUnitRender(), Core Audio tries to be helpful by setting the mDataByteSize to the number of bytes - that were actually rendered. The problem with this is that the next call can fail with -50 due to the size no longer - being set to the capacity of the buffer, but instead the size in bytes of the previous render. This will cause a - problem when a future call to this callback specifies a larger number of frames. - - To work around this we need to explicitly set the size of each buffer to their respective size in bytes. - */ - for (iBuffer = 0; iBuffer < pRenderedBufferList->mNumberBuffers; ++iBuffer) { - pRenderedBufferList->mBuffers[iBuffer].mDataByteSize = pDevice->coreaudio.audioBufferCapInFrames * ma_get_bytes_per_sample(pDevice->capture.internalFormat) * pRenderedBufferList->mBuffers[iBuffer].mNumberChannels; - } - - status = ((ma_AudioUnitRender_proc)pDevice->pContext->coreaudio.AudioUnitRender)((AudioUnit)pDevice->coreaudio.audioUnitCapture, pActionFlags, pTimeStamp, busNumber, frameCount, pRenderedBufferList); - if (status != noErr) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, " ERROR: AudioUnitRender() failed with %d.\n", (int)status); - return status; - } - - if (layout == ma_stream_layout_interleaved) { - for (iBuffer = 0; iBuffer < pRenderedBufferList->mNumberBuffers; ++iBuffer) { - if (pRenderedBufferList->mBuffers[iBuffer].mNumberChannels == pDevice->capture.internalChannels) { - ma_device_handle_backend_data_callback(pDevice, NULL, pRenderedBufferList->mBuffers[iBuffer].mData, frameCount); - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, " mDataByteSize=%d.\n", (int)pRenderedBufferList->mBuffers[iBuffer].mDataByteSize);*/ - } else { - /* - This case is where the number of channels in the output buffer do not match our internal channels. It could mean that it's - not interleaved, in which case we can't handle right now since miniaudio does not yet support non-interleaved streams. - */ - ma_uint8 silentBuffer[4096]; - ma_uint32 framesRemaining; - - MA_ZERO_MEMORY(silentBuffer, sizeof(silentBuffer)); - - framesRemaining = frameCount; - while (framesRemaining > 0) { - ma_uint32 framesToSend = sizeof(silentBuffer) / ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - if (framesToSend > framesRemaining) { - framesToSend = framesRemaining; - } - - ma_device_handle_backend_data_callback(pDevice, NULL, silentBuffer, framesToSend); - - framesRemaining -= framesToSend; - } - - /*ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, " WARNING: Outputting silence. frameCount=%d, mNumberChannels=%d, mDataByteSize=%d\n", (int)frameCount, (int)pRenderedBufferList->mBuffers[iBuffer].mNumberChannels, (int)pRenderedBufferList->mBuffers[iBuffer].mDataByteSize);*/ - } - } - } else { - /* This is the deinterleaved case. We need to interleave the audio data before sending it to the client. This assumes each buffer is the same size. */ - MA_ASSERT(pDevice->capture.internalChannels <= MA_MAX_CHANNELS); /* This should have been validated at initialization time. */ - - /* - For safety we'll check that the internal channels is a multiple of the buffer count. If it's not it means something - very strange has happened and we're not going to support it. - */ - if ((pRenderedBufferList->mNumberBuffers % pDevice->capture.internalChannels) == 0) { - ma_uint8 tempBuffer[4096]; - for (iBuffer = 0; iBuffer < pRenderedBufferList->mNumberBuffers; iBuffer += pDevice->capture.internalChannels) { - ma_uint32 framesRemaining = frameCount; - while (framesRemaining > 0) { - void* ppDeinterleavedBuffers[MA_MAX_CHANNELS]; - ma_uint32 iChannel; - ma_uint32 framesToSend = sizeof(tempBuffer) / ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - if (framesToSend > framesRemaining) { - framesToSend = framesRemaining; - } - - for (iChannel = 0; iChannel < pDevice->capture.internalChannels; ++iChannel) { - ppDeinterleavedBuffers[iChannel] = (void*)ma_offset_ptr(pRenderedBufferList->mBuffers[iBuffer+iChannel].mData, (frameCount - framesRemaining) * ma_get_bytes_per_sample(pDevice->capture.internalFormat)); - } - - ma_interleave_pcm_frames(pDevice->capture.internalFormat, pDevice->capture.internalChannels, framesToSend, (const void**)ppDeinterleavedBuffers, tempBuffer); - ma_device_handle_backend_data_callback(pDevice, NULL, tempBuffer, framesToSend); - - framesRemaining -= framesToSend; - } - } - } - } - - (void)pActionFlags; - (void)pTimeStamp; - (void)busNumber; - (void)frameCount; - (void)pUnusedBufferList; - - return noErr; -} - -static void on_start_stop__coreaudio(void* pUserData, AudioUnit audioUnit, AudioUnitPropertyID propertyID, AudioUnitScope scope, AudioUnitElement element) -{ - ma_device* pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - /* Don't do anything if it looks like we're just reinitializing due to a device switch. */ - if (((audioUnit == pDevice->coreaudio.audioUnitPlayback) && pDevice->coreaudio.isSwitchingPlaybackDevice) || - ((audioUnit == pDevice->coreaudio.audioUnitCapture) && pDevice->coreaudio.isSwitchingCaptureDevice)) { - return; - } - - /* - There's been a report of a deadlock here when triggered by ma_device_uninit(). It looks like - AudioUnitGetProprty (called below) and AudioComponentInstanceDispose (called in ma_device_uninit) - can try waiting on the same lock. I'm going to try working around this by not calling any Core - Audio APIs in the callback when the device has been stopped or uninitialized. - */ - if (ma_device_get_state(pDevice) == ma_device_state_uninitialized || ma_device_get_state(pDevice) == ma_device_state_stopping || ma_device_get_state(pDevice) == ma_device_state_stopped) { - ma_device__on_notification_stopped(pDevice); - } else { - UInt32 isRunning; - UInt32 isRunningSize = sizeof(isRunning); - OSStatus status = ((ma_AudioUnitGetProperty_proc)pDevice->pContext->coreaudio.AudioUnitGetProperty)(audioUnit, kAudioOutputUnitProperty_IsRunning, scope, element, &isRunning, &isRunningSize); - if (status != noErr) { - goto done; /* Don't really know what to do in this case... just ignore it, I suppose... */ - } - - if (!isRunning) { - /* - The stop event is a bit annoying in Core Audio because it will be called when we automatically switch the default device. Some scenarios to consider: - - 1) When the device is unplugged, this will be called _before_ the default device change notification. - 2) When the device is changed via the default device change notification, this will be called _after_ the switch. - - For case #1, we just check if there's a new default device available. If so, we just ignore the stop event. For case #2 we check a flag. - */ - if (((audioUnit == pDevice->coreaudio.audioUnitPlayback) && pDevice->coreaudio.isDefaultPlaybackDevice) || - ((audioUnit == pDevice->coreaudio.audioUnitCapture) && pDevice->coreaudio.isDefaultCaptureDevice)) { - /* - It looks like the device is switching through an external event, such as the user unplugging the device or changing the default device - via the operating system's sound settings. If we're re-initializing the device, we just terminate because we want the stopping of the - device to be seamless to the client (we don't want them receiving the stopped event and thinking that the device has stopped when it - hasn't!). - */ - if (((audioUnit == pDevice->coreaudio.audioUnitPlayback) && pDevice->coreaudio.isSwitchingPlaybackDevice) || - ((audioUnit == pDevice->coreaudio.audioUnitCapture) && pDevice->coreaudio.isSwitchingCaptureDevice)) { - goto done; - } - - /* - Getting here means the device is not reinitializing which means it may have been unplugged. From what I can see, it looks like Core Audio - will try switching to the new default device seamlessly. We need to somehow find a way to determine whether or not Core Audio will most - likely be successful in switching to the new device. - - TODO: Try to predict if Core Audio will switch devices. If not, the stopped callback needs to be posted. - */ - goto done; - } - - /* Getting here means we need to stop the device. */ - ma_device__on_notification_stopped(pDevice); - } - } - - (void)propertyID; /* Unused. */ - -done: - /* Always signal the stop event. It's possible for the "else" case to get hit which can happen during an interruption. */ - ma_event_signal(&pDevice->coreaudio.stopEvent); -} - -#if defined(MA_APPLE_DESKTOP) -static ma_spinlock g_DeviceTrackingInitLock_CoreAudio = 0; /* A spinlock for mutal exclusion of the init/uninit of the global tracking data. Initialization to 0 is what we need. */ -static ma_uint32 g_DeviceTrackingInitCounter_CoreAudio = 0; -static ma_mutex g_DeviceTrackingMutex_CoreAudio; -static ma_device** g_ppTrackedDevices_CoreAudio = NULL; -static ma_uint32 g_TrackedDeviceCap_CoreAudio = 0; -static ma_uint32 g_TrackedDeviceCount_CoreAudio = 0; - -static OSStatus ma_default_device_changed__coreaudio(AudioObjectID objectID, UInt32 addressCount, const AudioObjectPropertyAddress* pAddresses, void* pUserData) -{ - ma_device_type deviceType; - - /* Not sure if I really need to check this, but it makes me feel better. */ - if (addressCount == 0) { - return noErr; - } - - if (pAddresses[0].mSelector == kAudioHardwarePropertyDefaultOutputDevice) { - deviceType = ma_device_type_playback; - } else if (pAddresses[0].mSelector == kAudioHardwarePropertyDefaultInputDevice) { - deviceType = ma_device_type_capture; - } else { - return noErr; /* Should never hit this. */ - } - - ma_mutex_lock(&g_DeviceTrackingMutex_CoreAudio); - { - ma_uint32 iDevice; - for (iDevice = 0; iDevice < g_TrackedDeviceCount_CoreAudio; iDevice += 1) { - ma_result reinitResult; - ma_device* pDevice; - - pDevice = g_ppTrackedDevices_CoreAudio[iDevice]; - if (pDevice->type == deviceType || pDevice->type == ma_device_type_duplex) { - if (deviceType == ma_device_type_playback) { - pDevice->coreaudio.isSwitchingPlaybackDevice = MA_TRUE; - reinitResult = ma_device_reinit_internal__coreaudio(pDevice, deviceType, MA_TRUE); - pDevice->coreaudio.isSwitchingPlaybackDevice = MA_FALSE; - } else { - pDevice->coreaudio.isSwitchingCaptureDevice = MA_TRUE; - reinitResult = ma_device_reinit_internal__coreaudio(pDevice, deviceType, MA_TRUE); - pDevice->coreaudio.isSwitchingCaptureDevice = MA_FALSE; - } - - if (reinitResult == MA_SUCCESS) { - ma_device__post_init_setup(pDevice, deviceType); - - /* Restart the device if required. If this fails we need to stop the device entirely. */ - if (ma_device_get_state(pDevice) == ma_device_state_started) { - OSStatus status; - if (deviceType == ma_device_type_playback) { - status = ((ma_AudioOutputUnitStart_proc)pDevice->pContext->coreaudio.AudioOutputUnitStart)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - if (status != noErr) { - if (pDevice->type == ma_device_type_duplex) { - ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - } - ma_device__set_state(pDevice, ma_device_state_stopped); - } - } else if (deviceType == ma_device_type_capture) { - status = ((ma_AudioOutputUnitStart_proc)pDevice->pContext->coreaudio.AudioOutputUnitStart)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - if (status != noErr) { - if (pDevice->type == ma_device_type_duplex) { - ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - } - ma_device__set_state(pDevice, ma_device_state_stopped); - } - } - } - - ma_device__on_notification_rerouted(pDevice); - } - } - } - } - ma_mutex_unlock(&g_DeviceTrackingMutex_CoreAudio); - - /* Unused parameters. */ - (void)objectID; - (void)pUserData; - - return noErr; -} - -static ma_result ma_context__init_device_tracking__coreaudio(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - - ma_spinlock_lock(&g_DeviceTrackingInitLock_CoreAudio); - { - /* Don't do anything if we've already initializd device tracking. */ - if (g_DeviceTrackingInitCounter_CoreAudio == 0) { - AudioObjectPropertyAddress propAddress; - propAddress.mScope = kAudioObjectPropertyScopeGlobal; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - ma_mutex_init(&g_DeviceTrackingMutex_CoreAudio); - - propAddress.mSelector = kAudioHardwarePropertyDefaultInputDevice; - ((ma_AudioObjectAddPropertyListener_proc)pContext->coreaudio.AudioObjectAddPropertyListener)(kAudioObjectSystemObject, &propAddress, &ma_default_device_changed__coreaudio, NULL); - - propAddress.mSelector = kAudioHardwarePropertyDefaultOutputDevice; - ((ma_AudioObjectAddPropertyListener_proc)pContext->coreaudio.AudioObjectAddPropertyListener)(kAudioObjectSystemObject, &propAddress, &ma_default_device_changed__coreaudio, NULL); - - } - g_DeviceTrackingInitCounter_CoreAudio += 1; - } - ma_spinlock_unlock(&g_DeviceTrackingInitLock_CoreAudio); - - return MA_SUCCESS; -} - -static ma_result ma_context__uninit_device_tracking__coreaudio(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - - ma_spinlock_lock(&g_DeviceTrackingInitLock_CoreAudio); - { - if (g_DeviceTrackingInitCounter_CoreAudio > 0) - g_DeviceTrackingInitCounter_CoreAudio -= 1; - - if (g_DeviceTrackingInitCounter_CoreAudio == 0) { - AudioObjectPropertyAddress propAddress; - propAddress.mScope = kAudioObjectPropertyScopeGlobal; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - propAddress.mSelector = kAudioHardwarePropertyDefaultInputDevice; - ((ma_AudioObjectRemovePropertyListener_proc)pContext->coreaudio.AudioObjectRemovePropertyListener)(kAudioObjectSystemObject, &propAddress, &ma_default_device_changed__coreaudio, NULL); - - propAddress.mSelector = kAudioHardwarePropertyDefaultOutputDevice; - ((ma_AudioObjectRemovePropertyListener_proc)pContext->coreaudio.AudioObjectRemovePropertyListener)(kAudioObjectSystemObject, &propAddress, &ma_default_device_changed__coreaudio, NULL); - - /* At this point there should be no tracked devices. If not there's an error somewhere. */ - if (g_ppTrackedDevices_CoreAudio != NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "You have uninitialized all contexts while an associated device is still active."); - ma_spinlock_unlock(&g_DeviceTrackingInitLock_CoreAudio); - return MA_INVALID_OPERATION; - } - - ma_mutex_uninit(&g_DeviceTrackingMutex_CoreAudio); - } - } - ma_spinlock_unlock(&g_DeviceTrackingInitLock_CoreAudio); - - return MA_SUCCESS; -} - -static ma_result ma_device__track__coreaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - ma_mutex_lock(&g_DeviceTrackingMutex_CoreAudio); - { - /* Allocate memory if required. */ - if (g_TrackedDeviceCap_CoreAudio <= g_TrackedDeviceCount_CoreAudio) { - ma_uint32 newCap; - ma_device** ppNewDevices; - - newCap = g_TrackedDeviceCap_CoreAudio * 2; - if (newCap == 0) { - newCap = 1; - } - - ppNewDevices = (ma_device**)ma_realloc(g_ppTrackedDevices_CoreAudio, sizeof(*g_ppTrackedDevices_CoreAudio)*newCap, &pDevice->pContext->allocationCallbacks); - if (ppNewDevices == NULL) { - ma_mutex_unlock(&g_DeviceTrackingMutex_CoreAudio); - return MA_OUT_OF_MEMORY; - } - - g_ppTrackedDevices_CoreAudio = ppNewDevices; - g_TrackedDeviceCap_CoreAudio = newCap; - } - - g_ppTrackedDevices_CoreAudio[g_TrackedDeviceCount_CoreAudio] = pDevice; - g_TrackedDeviceCount_CoreAudio += 1; - } - ma_mutex_unlock(&g_DeviceTrackingMutex_CoreAudio); - - return MA_SUCCESS; -} - -static ma_result ma_device__untrack__coreaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - ma_mutex_lock(&g_DeviceTrackingMutex_CoreAudio); - { - ma_uint32 iDevice; - for (iDevice = 0; iDevice < g_TrackedDeviceCount_CoreAudio; iDevice += 1) { - if (g_ppTrackedDevices_CoreAudio[iDevice] == pDevice) { - /* We've found the device. We now need to remove it from the list. */ - ma_uint32 jDevice; - for (jDevice = iDevice; jDevice < g_TrackedDeviceCount_CoreAudio-1; jDevice += 1) { - g_ppTrackedDevices_CoreAudio[jDevice] = g_ppTrackedDevices_CoreAudio[jDevice+1]; - } - - g_TrackedDeviceCount_CoreAudio -= 1; - - /* If there's nothing else in the list we need to free memory. */ - if (g_TrackedDeviceCount_CoreAudio == 0) { - ma_free(g_ppTrackedDevices_CoreAudio, &pDevice->pContext->allocationCallbacks); - g_ppTrackedDevices_CoreAudio = NULL; - g_TrackedDeviceCap_CoreAudio = 0; - } - - break; - } - } - } - ma_mutex_unlock(&g_DeviceTrackingMutex_CoreAudio); - - return MA_SUCCESS; -} -#endif - -#if defined(MA_APPLE_MOBILE) -@interface ma_ios_notification_handler:NSObject { - ma_device* m_pDevice; -} -@end - -@implementation ma_ios_notification_handler --(id)init:(ma_device*)pDevice -{ - self = [super init]; - m_pDevice = pDevice; - - /* For route changes. */ - [[NSNotificationCenter defaultCenter] addObserver:self selector:@selector(handle_route_change:) name:AVAudioSessionRouteChangeNotification object:[AVAudioSession sharedInstance]]; - - /* For interruptions. */ - [[NSNotificationCenter defaultCenter] addObserver:self selector:@selector(handle_interruption:) name:AVAudioSessionInterruptionNotification object:[AVAudioSession sharedInstance]]; - - return self; -} - --(void)dealloc -{ - [self remove_handler]; - - #if defined(__has_feature) - #if !__has_feature(objc_arc) - [super dealloc]; - #endif - #endif -} - --(void)remove_handler -{ - [[NSNotificationCenter defaultCenter] removeObserver:self name:AVAudioSessionRouteChangeNotification object:nil]; - [[NSNotificationCenter defaultCenter] removeObserver:self name:AVAudioSessionInterruptionNotification object:nil]; -} - --(void)handle_interruption:(NSNotification*)pNotification -{ - NSInteger type = [[[pNotification userInfo] objectForKey:AVAudioSessionInterruptionTypeKey] integerValue]; - switch (type) - { - case AVAudioSessionInterruptionTypeBegan: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Interruption: AVAudioSessionInterruptionTypeBegan\n"); - - /* - Core Audio will have stopped the internal device automatically, but we need explicitly - stop it at a higher level to ensure miniaudio-specific state is updated for consistency. - */ - ma_device_stop(m_pDevice); - - /* - Fire the notification after the device has been stopped to ensure it's in the correct - state when the notification handler is invoked. - */ - ma_device__on_notification_interruption_began(m_pDevice); - } break; - - case AVAudioSessionInterruptionTypeEnded: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Interruption: AVAudioSessionInterruptionTypeEnded\n"); - ma_device__on_notification_interruption_ended(m_pDevice); - } break; - } -} - --(void)handle_route_change:(NSNotification*)pNotification -{ - AVAudioSession* pSession = [AVAudioSession sharedInstance]; - - NSInteger reason = [[[pNotification userInfo] objectForKey:AVAudioSessionRouteChangeReasonKey] integerValue]; - switch (reason) - { - case AVAudioSessionRouteChangeReasonOldDeviceUnavailable: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonOldDeviceUnavailable\n"); - } break; - - case AVAudioSessionRouteChangeReasonNewDeviceAvailable: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonNewDeviceAvailable\n"); - } break; - - case AVAudioSessionRouteChangeReasonNoSuitableRouteForCategory: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonNoSuitableRouteForCategory\n"); - } break; - - case AVAudioSessionRouteChangeReasonWakeFromSleep: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonWakeFromSleep\n"); - } break; - - case AVAudioSessionRouteChangeReasonOverride: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonOverride\n"); - } break; - - case AVAudioSessionRouteChangeReasonCategoryChange: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonCategoryChange\n"); - } break; - - case AVAudioSessionRouteChangeReasonUnknown: - default: - { - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_INFO, "[Core Audio] Route Changed: AVAudioSessionRouteChangeReasonUnknown\n"); - } break; - } - - ma_log_postf(ma_device_get_log(m_pDevice), MA_LOG_LEVEL_DEBUG, "[Core Audio] Changing Route. inputNumberChannels=%d; outputNumberOfChannels=%d\n", (int)pSession.inputNumberOfChannels, (int)pSession.outputNumberOfChannels); - - /* Let the application know about the route change. */ - ma_device__on_notification_rerouted(m_pDevice); -} -@end -#endif - -static ma_result ma_device_uninit__coreaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(ma_device_get_state(pDevice) == ma_device_state_uninitialized); - -#if defined(MA_APPLE_DESKTOP) - /* - Make sure we're no longer tracking the device. It doesn't matter if we call this for a non-default device because it'll - just gracefully ignore it. - */ - ma_device__untrack__coreaudio(pDevice); -#endif -#if defined(MA_APPLE_MOBILE) - if (pDevice->coreaudio.pNotificationHandler != NULL) { - ma_ios_notification_handler* pNotificationHandler = (MA_BRIDGE_TRANSFER ma_ios_notification_handler*)pDevice->coreaudio.pNotificationHandler; - [pNotificationHandler remove_handler]; - } -#endif - - if (pDevice->coreaudio.audioUnitCapture != NULL) { - ((ma_AudioComponentInstanceDispose_proc)pDevice->pContext->coreaudio.AudioComponentInstanceDispose)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - } - if (pDevice->coreaudio.audioUnitPlayback != NULL) { - ((ma_AudioComponentInstanceDispose_proc)pDevice->pContext->coreaudio.AudioComponentInstanceDispose)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - } - - if (pDevice->coreaudio.pAudioBufferList) { - ma_free(pDevice->coreaudio.pAudioBufferList, &pDevice->pContext->allocationCallbacks); - } - - return MA_SUCCESS; -} - -typedef struct -{ - ma_bool32 allowNominalSampleRateChange; - - /* Input. */ - ma_format formatIn; - ma_uint32 channelsIn; - ma_uint32 sampleRateIn; - ma_channel channelMapIn[MA_MAX_CHANNELS]; - ma_uint32 periodSizeInFramesIn; - ma_uint32 periodSizeInMillisecondsIn; - ma_uint32 periodsIn; - ma_share_mode shareMode; - ma_performance_profile performanceProfile; - ma_bool32 registerStopEvent; - - /* Output. */ -#if defined(MA_APPLE_DESKTOP) - AudioObjectID deviceObjectID; -#endif - AudioComponent component; - AudioUnit audioUnit; - AudioBufferList* pAudioBufferList; /* Only used for input devices. */ - ma_format formatOut; - ma_uint32 channelsOut; - ma_uint32 sampleRateOut; - ma_channel channelMapOut[MA_MAX_CHANNELS]; - ma_uint32 periodSizeInFramesOut; - ma_uint32 periodsOut; - char deviceName[256]; -} ma_device_init_internal_data__coreaudio; - -static ma_result ma_device_init_internal__coreaudio(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_init_internal_data__coreaudio* pData, void* pDevice_DoNotReference) /* <-- pDevice is typed as void* intentionally so as to avoid accidentally referencing it. */ -{ - ma_result result; - OSStatus status; - UInt32 enableIOFlag; - AudioStreamBasicDescription bestFormat; - UInt32 actualPeriodSizeInFrames; - AURenderCallbackStruct callbackInfo; -#if defined(MA_APPLE_DESKTOP) - AudioObjectID deviceObjectID; -#endif - - /* This API should only be used for a single device type: playback or capture. No full-duplex mode. */ - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - MA_ASSERT(pContext != NULL); - MA_ASSERT(deviceType == ma_device_type_playback || deviceType == ma_device_type_capture); - -#if defined(MA_APPLE_DESKTOP) - pData->deviceObjectID = 0; -#endif - pData->component = NULL; - pData->audioUnit = NULL; - pData->pAudioBufferList = NULL; - -#if defined(MA_APPLE_DESKTOP) - result = ma_find_AudioObjectID(pContext, deviceType, pDeviceID, &deviceObjectID); - if (result != MA_SUCCESS) { - return result; - } - - pData->deviceObjectID = deviceObjectID; -#endif - - /* Core audio doesn't really use the notion of a period so we can leave this unmodified, but not too over the top. */ - pData->periodsOut = pData->periodsIn; - if (pData->periodsOut == 0) { - pData->periodsOut = MA_DEFAULT_PERIODS; - } - if (pData->periodsOut > 16) { - pData->periodsOut = 16; - } - - - /* Audio unit. */ - status = ((ma_AudioComponentInstanceNew_proc)pContext->coreaudio.AudioComponentInstanceNew)((AudioComponent)pContext->coreaudio.component, (AudioUnit*)&pData->audioUnit); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - - - /* The input/output buses need to be explicitly enabled and disabled. We set the flag based on the output unit first, then we just swap it for input. */ - enableIOFlag = 1; - if (deviceType == ma_device_type_capture) { - enableIOFlag = 0; - } - - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioOutputUnitProperty_EnableIO, kAudioUnitScope_Output, MA_COREAUDIO_OUTPUT_BUS, &enableIOFlag, sizeof(enableIOFlag)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - - enableIOFlag = (enableIOFlag == 0) ? 1 : 0; - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioOutputUnitProperty_EnableIO, kAudioUnitScope_Input, MA_COREAUDIO_INPUT_BUS, &enableIOFlag, sizeof(enableIOFlag)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - - - /* Set the device to use with this audio unit. This is only used on desktop since we are using defaults on mobile. */ -#if defined(MA_APPLE_DESKTOP) - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioOutputUnitProperty_CurrentDevice, kAudioUnitScope_Global, 0, &deviceObjectID, sizeof(deviceObjectID)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(result); - } -#else - /* - For some reason it looks like Apple is only allowing selection of the input device. There does not appear to be any way to change - the default output route. I have no idea why this is like this, but for now we'll only be able to configure capture devices. - */ - if (pDeviceID != NULL) { - if (deviceType == ma_device_type_capture) { - ma_bool32 found = MA_FALSE; - NSArray *pInputs = [[[AVAudioSession sharedInstance] currentRoute] inputs]; - for (AVAudioSessionPortDescription* pPortDesc in pInputs) { - if (strcmp(pDeviceID->coreaudio, [pPortDesc.UID UTF8String]) == 0) { - [[AVAudioSession sharedInstance] setPreferredInput:pPortDesc error:nil]; - found = MA_TRUE; - break; - } - } - - if (found == MA_FALSE) { - return MA_DOES_NOT_EXIST; - } - } - } -#endif - - /* - Format. This is the hardest part of initialization because there's a few variables to take into account. - 1) The format must be supported by the device. - 2) The format must be supported miniaudio. - 3) There's a priority that miniaudio prefers. - - Ideally we would like to use a format that's as close to the hardware as possible so we can get as close to a passthrough as possible. The - most important property is the sample rate. miniaudio can do format conversion for any sample rate and channel count, but cannot do the same - for the sample data format. If the sample data format is not supported by miniaudio it must be ignored completely. - - On mobile platforms this is a bit different. We just force the use of whatever the audio unit's current format is set to. - */ - { - AudioStreamBasicDescription origFormat; - UInt32 origFormatSize = sizeof(origFormat); - AudioUnitScope formatScope = (deviceType == ma_device_type_playback) ? kAudioUnitScope_Input : kAudioUnitScope_Output; - AudioUnitElement formatElement = (deviceType == ma_device_type_playback) ? MA_COREAUDIO_OUTPUT_BUS : MA_COREAUDIO_INPUT_BUS; - - if (deviceType == ma_device_type_playback) { - status = ((ma_AudioUnitGetProperty_proc)pContext->coreaudio.AudioUnitGetProperty)(pData->audioUnit, kAudioUnitProperty_StreamFormat, kAudioUnitScope_Output, MA_COREAUDIO_OUTPUT_BUS, &origFormat, &origFormatSize); - } else { - status = ((ma_AudioUnitGetProperty_proc)pContext->coreaudio.AudioUnitGetProperty)(pData->audioUnit, kAudioUnitProperty_StreamFormat, kAudioUnitScope_Input, MA_COREAUDIO_INPUT_BUS, &origFormat, &origFormatSize); - } - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - - #if defined(MA_APPLE_DESKTOP) - result = ma_find_best_format__coreaudio(pContext, deviceObjectID, deviceType, pData->formatIn, pData->channelsIn, pData->sampleRateIn, &origFormat, &bestFormat); - if (result != MA_SUCCESS) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return result; - } - - /* - Technical Note TN2091: Device input using the HAL Output Audio Unit - https://developer.apple.com/library/archive/technotes/tn2091/_index.html - - This documentation says the following: - - The internal AudioConverter can handle any *simple* conversion. Typically, this means that a client can specify ANY - variant of the PCM formats. Consequently, the device's sample rate should match the desired sample rate. If sample rate - conversion is needed, it can be accomplished by buffering the input and converting the data on a separate thread with - another AudioConverter. - - The important part here is the mention that it can handle *simple* conversions, which does *not* include sample rate. We - therefore want to ensure the sample rate stays consistent. This document is specifically for input, but I'm going to play it - safe and apply the same rule to output as well. - - I have tried going against the documentation by setting the sample rate anyway, but this just results in AudioUnitRender() - returning a result code of -10863. I have also tried changing the format directly on the input scope on the input bus, but - this just results in `ca_require: IsStreamFormatWritable(inScope, inElement) NotWritable` when trying to set the format. - - Something that does seem to work, however, has been setting the nominal sample rate on the deivce object. The problem with - this, however, is that it actually changes the sample rate at the operating system level and not just the application. This - could be intrusive to the user, however, so I don't think it's wise to make this the default. Instead I'm making this a - configuration option. When the `coreaudio.allowNominalSampleRateChange` config option is set to true, changing the sample - rate will be allowed. Otherwise it'll be fixed to the current sample rate. To check the system-defined sample rate, run - the Audio MIDI Setup program that comes installed on macOS and observe how the sample rate changes as the sample rate is - changed by miniaudio. - */ - if (pData->allowNominalSampleRateChange) { - AudioValueRange sampleRateRange; - AudioObjectPropertyAddress propAddress; - - sampleRateRange.mMinimum = bestFormat.mSampleRate; - sampleRateRange.mMaximum = bestFormat.mSampleRate; - - propAddress.mSelector = kAudioDevicePropertyNominalSampleRate; - propAddress.mScope = (deviceType == ma_device_type_playback) ? kAudioObjectPropertyScopeOutput : kAudioObjectPropertyScopeInput; - propAddress.mElement = AUDIO_OBJECT_PROPERTY_ELEMENT; - - status = ((ma_AudioObjectSetPropertyData_proc)pContext->coreaudio.AudioObjectSetPropertyData)(deviceObjectID, &propAddress, 0, NULL, sizeof(sampleRateRange), &sampleRateRange); - if (status != noErr) { - bestFormat.mSampleRate = origFormat.mSampleRate; - } - } else { - bestFormat.mSampleRate = origFormat.mSampleRate; - } - - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioUnitProperty_StreamFormat, formatScope, formatElement, &bestFormat, sizeof(bestFormat)); - if (status != noErr) { - /* We failed to set the format, so fall back to the current format of the audio unit. */ - bestFormat = origFormat; - } - #else - bestFormat = origFormat; - - /* - Sample rate is a little different here because for some reason kAudioUnitProperty_StreamFormat returns 0... Oh well. We need to instead try - setting the sample rate to what the user has requested and then just see the results of it. Need to use some Objective-C here for this since - it depends on Apple's AVAudioSession API. To do this we just get the shared AVAudioSession instance and then set it. Note that from what I - can tell, it looks like the sample rate is shared between playback and capture for everything. - */ - @autoreleasepool { - AVAudioSession* pAudioSession = [AVAudioSession sharedInstance]; - MA_ASSERT(pAudioSession != NULL); - - [pAudioSession setPreferredSampleRate:(double)pData->sampleRateIn error:nil]; - bestFormat.mSampleRate = pAudioSession.sampleRate; - - /* - I've had a report that the channel count returned by AudioUnitGetProperty above is inconsistent with - AVAudioSession outputNumberOfChannels. I'm going to try using the AVAudioSession values instead. - */ - if (deviceType == ma_device_type_playback) { - bestFormat.mChannelsPerFrame = (UInt32)pAudioSession.outputNumberOfChannels; - } - if (deviceType == ma_device_type_capture) { - bestFormat.mChannelsPerFrame = (UInt32)pAudioSession.inputNumberOfChannels; - } - } - - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioUnitProperty_StreamFormat, formatScope, formatElement, &bestFormat, sizeof(bestFormat)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - #endif - - result = ma_format_from_AudioStreamBasicDescription(&bestFormat, &pData->formatOut); - if (result != MA_SUCCESS) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return result; - } - - if (pData->formatOut == ma_format_unknown) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return MA_FORMAT_NOT_SUPPORTED; - } - - pData->channelsOut = bestFormat.mChannelsPerFrame; - pData->sampleRateOut = bestFormat.mSampleRate; - } - - /* Clamp the channel count for safety. */ - if (pData->channelsOut > MA_MAX_CHANNELS) { - pData->channelsOut = MA_MAX_CHANNELS; - } - - /* - Internal channel map. This is weird in my testing. If I use the AudioObject to get the - channel map, the channel descriptions are set to "Unknown" for some reason. To work around - this it looks like retrieving it from the AudioUnit will work. However, and this is where - it gets weird, it doesn't seem to work with capture devices, nor at all on iOS... Therefore - I'm going to fall back to a default assumption in these cases. - */ -#if defined(MA_APPLE_DESKTOP) - result = ma_get_AudioUnit_channel_map(pContext, pData->audioUnit, deviceType, pData->channelMapOut, pData->channelsOut); - if (result != MA_SUCCESS) { - #if 0 - /* Try falling back to the channel map from the AudioObject. */ - result = ma_get_AudioObject_channel_map(pContext, deviceObjectID, deviceType, pData->channelMapOut, pData->channelsOut); - if (result != MA_SUCCESS) { - return result; - } - #else - /* Fall back to default assumptions. */ - ma_channel_map_init_standard(ma_standard_channel_map_default, pData->channelMapOut, ma_countof(pData->channelMapOut), pData->channelsOut); - #endif - } -#else - /* TODO: Figure out how to get the channel map using AVAudioSession. */ - ma_channel_map_init_standard(ma_standard_channel_map_default, pData->channelMapOut, ma_countof(pData->channelMapOut), pData->channelsOut); -#endif - - - /* Buffer size. Not allowing this to be configurable on iOS. */ - if (pData->periodSizeInFramesIn == 0) { - if (pData->periodSizeInMillisecondsIn == 0) { - if (pData->performanceProfile == ma_performance_profile_low_latency) { - actualPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_LOW_LATENCY, pData->sampleRateOut); - } else { - actualPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE, pData->sampleRateOut); - } - } else { - actualPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(pData->periodSizeInMillisecondsIn, pData->sampleRateOut); - } - } else { - actualPeriodSizeInFrames = pData->periodSizeInFramesIn; - } - -#if defined(MA_APPLE_DESKTOP) - result = ma_set_AudioObject_buffer_size_in_frames(pContext, deviceObjectID, deviceType, &actualPeriodSizeInFrames); - if (result != MA_SUCCESS) { - return result; - } -#else - /* - On iOS, the size of the IO buffer needs to be specified in seconds and is a floating point - number. I don't trust any potential truncation errors due to converting from float to integer - so I'm going to explicitly set the actual period size to the next power of 2. - */ - @autoreleasepool { - AVAudioSession* pAudioSession = [AVAudioSession sharedInstance]; - MA_ASSERT(pAudioSession != NULL); - - [pAudioSession setPreferredIOBufferDuration:((float)actualPeriodSizeInFrames / pAudioSession.sampleRate) error:nil]; - actualPeriodSizeInFrames = ma_next_power_of_2((ma_uint32)(pAudioSession.IOBufferDuration * pAudioSession.sampleRate)); - } -#endif - - - /* - During testing I discovered that the buffer size can be too big. You'll get an error like this: - - kAudioUnitErr_TooManyFramesToProcess : inFramesToProcess=4096, mMaxFramesPerSlice=512 - - Note how inFramesToProcess is smaller than mMaxFramesPerSlice. To fix, we need to set kAudioUnitProperty_MaximumFramesPerSlice to that - of the size of our buffer, or do it the other way around and set our buffer size to the kAudioUnitProperty_MaximumFramesPerSlice. - */ - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioUnitProperty_MaximumFramesPerSlice, kAudioUnitScope_Global, 0, &actualPeriodSizeInFrames, sizeof(actualPeriodSizeInFrames)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - - pData->periodSizeInFramesOut = (ma_uint32)actualPeriodSizeInFrames; - - /* We need a buffer list if this is an input device. We render into this in the input callback. */ - if (deviceType == ma_device_type_capture) { - ma_bool32 isInterleaved = (bestFormat.mFormatFlags & kAudioFormatFlagIsNonInterleaved) == 0; - AudioBufferList* pBufferList; - - pBufferList = ma_allocate_AudioBufferList__coreaudio(pData->periodSizeInFramesOut, pData->formatOut, pData->channelsOut, (isInterleaved) ? ma_stream_layout_interleaved : ma_stream_layout_deinterleaved, &pContext->allocationCallbacks); - if (pBufferList == NULL) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return MA_OUT_OF_MEMORY; - } - - pData->pAudioBufferList = pBufferList; - } - - /* Callbacks. */ - callbackInfo.inputProcRefCon = pDevice_DoNotReference; - if (deviceType == ma_device_type_playback) { - callbackInfo.inputProc = ma_on_output__coreaudio; - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioUnitProperty_SetRenderCallback, kAudioUnitScope_Global, 0, &callbackInfo, sizeof(callbackInfo)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - } else { - callbackInfo.inputProc = ma_on_input__coreaudio; - status = ((ma_AudioUnitSetProperty_proc)pContext->coreaudio.AudioUnitSetProperty)(pData->audioUnit, kAudioOutputUnitProperty_SetInputCallback, kAudioUnitScope_Global, 0, &callbackInfo, sizeof(callbackInfo)); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - } - - /* We need to listen for stop events. */ - if (pData->registerStopEvent) { - status = ((ma_AudioUnitAddPropertyListener_proc)pContext->coreaudio.AudioUnitAddPropertyListener)(pData->audioUnit, kAudioOutputUnitProperty_IsRunning, on_start_stop__coreaudio, pDevice_DoNotReference); - if (status != noErr) { - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - } - - /* Initialize the audio unit. */ - status = ((ma_AudioUnitInitialize_proc)pContext->coreaudio.AudioUnitInitialize)(pData->audioUnit); - if (status != noErr) { - ma_free(pData->pAudioBufferList, &pContext->allocationCallbacks); - pData->pAudioBufferList = NULL; - ((ma_AudioComponentInstanceDispose_proc)pContext->coreaudio.AudioComponentInstanceDispose)(pData->audioUnit); - return ma_result_from_OSStatus(status); - } - - /* Grab the name. */ -#if defined(MA_APPLE_DESKTOP) - ma_get_AudioObject_name(pContext, deviceObjectID, sizeof(pData->deviceName), pData->deviceName); -#else - if (deviceType == ma_device_type_playback) { - ma_strcpy_s(pData->deviceName, sizeof(pData->deviceName), MA_DEFAULT_PLAYBACK_DEVICE_NAME); - } else { - ma_strcpy_s(pData->deviceName, sizeof(pData->deviceName), MA_DEFAULT_CAPTURE_DEVICE_NAME); - } -#endif - - return result; -} - -#if defined(MA_APPLE_DESKTOP) -static ma_result ma_device_reinit_internal__coreaudio(ma_device* pDevice, ma_device_type deviceType, ma_bool32 disposePreviousAudioUnit) -{ - ma_device_init_internal_data__coreaudio data; - ma_result result; - - /* This should only be called for playback or capture, not duplex. */ - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - data.allowNominalSampleRateChange = MA_FALSE; /* Don't change the nominal sample rate when switching devices. */ - - if (deviceType == ma_device_type_capture) { - data.formatIn = pDevice->capture.format; - data.channelsIn = pDevice->capture.channels; - data.sampleRateIn = pDevice->sampleRate; - MA_COPY_MEMORY(data.channelMapIn, pDevice->capture.channelMap, sizeof(pDevice->capture.channelMap)); - data.shareMode = pDevice->capture.shareMode; - data.performanceProfile = pDevice->coreaudio.originalPerformanceProfile; - data.registerStopEvent = MA_TRUE; - - if (disposePreviousAudioUnit) { - ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - ((ma_AudioComponentInstanceDispose_proc)pDevice->pContext->coreaudio.AudioComponentInstanceDispose)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - } - if (pDevice->coreaudio.pAudioBufferList) { - ma_free(pDevice->coreaudio.pAudioBufferList, &pDevice->pContext->allocationCallbacks); - } - } else if (deviceType == ma_device_type_playback) { - data.formatIn = pDevice->playback.format; - data.channelsIn = pDevice->playback.channels; - data.sampleRateIn = pDevice->sampleRate; - MA_COPY_MEMORY(data.channelMapIn, pDevice->playback.channelMap, sizeof(pDevice->playback.channelMap)); - data.shareMode = pDevice->playback.shareMode; - data.performanceProfile = pDevice->coreaudio.originalPerformanceProfile; - data.registerStopEvent = (pDevice->type != ma_device_type_duplex); - - if (disposePreviousAudioUnit) { - ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - ((ma_AudioComponentInstanceDispose_proc)pDevice->pContext->coreaudio.AudioComponentInstanceDispose)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - } - } - data.periodSizeInFramesIn = pDevice->coreaudio.originalPeriodSizeInFrames; - data.periodSizeInMillisecondsIn = pDevice->coreaudio.originalPeriodSizeInMilliseconds; - data.periodsIn = pDevice->coreaudio.originalPeriods; - - /* Need at least 3 periods for duplex. */ - if (data.periodsIn < 3 && pDevice->type == ma_device_type_duplex) { - data.periodsIn = 3; - } - - result = ma_device_init_internal__coreaudio(pDevice->pContext, deviceType, NULL, &data, (void*)pDevice); - if (result != MA_SUCCESS) { - return result; - } - - if (deviceType == ma_device_type_capture) { - #if defined(MA_APPLE_DESKTOP) - pDevice->coreaudio.deviceObjectIDCapture = (ma_uint32)data.deviceObjectID; - ma_get_AudioObject_uid(pDevice->pContext, pDevice->coreaudio.deviceObjectIDCapture, sizeof(pDevice->capture.id.coreaudio), pDevice->capture.id.coreaudio); - #endif - pDevice->coreaudio.audioUnitCapture = (ma_ptr)data.audioUnit; - pDevice->coreaudio.pAudioBufferList = (ma_ptr)data.pAudioBufferList; - pDevice->coreaudio.audioBufferCapInFrames = data.periodSizeInFramesOut; - - pDevice->capture.internalFormat = data.formatOut; - pDevice->capture.internalChannels = data.channelsOut; - pDevice->capture.internalSampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDevice->capture.internalChannelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDevice->capture.internalPeriodSizeInFrames = data.periodSizeInFramesOut; - pDevice->capture.internalPeriods = data.periodsOut; - } else if (deviceType == ma_device_type_playback) { - #if defined(MA_APPLE_DESKTOP) - pDevice->coreaudio.deviceObjectIDPlayback = (ma_uint32)data.deviceObjectID; - ma_get_AudioObject_uid(pDevice->pContext, pDevice->coreaudio.deviceObjectIDPlayback, sizeof(pDevice->playback.id.coreaudio), pDevice->playback.id.coreaudio); - #endif - pDevice->coreaudio.audioUnitPlayback = (ma_ptr)data.audioUnit; - - pDevice->playback.internalFormat = data.formatOut; - pDevice->playback.internalChannels = data.channelsOut; - pDevice->playback.internalSampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDevice->playback.internalChannelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDevice->playback.internalPeriodSizeInFrames = data.periodSizeInFramesOut; - pDevice->playback.internalPeriods = data.periodsOut; - } - - return MA_SUCCESS; -} -#endif /* MA_APPLE_DESKTOP */ - -static ma_result ma_device_init__coreaudio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pConfig != NULL); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* No exclusive mode with the Core Audio backend for now. */ - if (((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->shareMode == ma_share_mode_exclusive)) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - /* Capture needs to be initialized first. */ - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_device_init_internal_data__coreaudio data; - data.allowNominalSampleRateChange = pConfig->coreaudio.allowNominalSampleRateChange; - data.formatIn = pDescriptorCapture->format; - data.channelsIn = pDescriptorCapture->channels; - data.sampleRateIn = pDescriptorCapture->sampleRate; - MA_COPY_MEMORY(data.channelMapIn, pDescriptorCapture->channelMap, sizeof(pDescriptorCapture->channelMap)); - data.periodSizeInFramesIn = pDescriptorCapture->periodSizeInFrames; - data.periodSizeInMillisecondsIn = pDescriptorCapture->periodSizeInMilliseconds; - data.periodsIn = pDescriptorCapture->periodCount; - data.shareMode = pDescriptorCapture->shareMode; - data.performanceProfile = pConfig->performanceProfile; - data.registerStopEvent = MA_TRUE; - - /* Need at least 3 periods for duplex. */ - if (data.periodsIn < 3 && pConfig->deviceType == ma_device_type_duplex) { - data.periodsIn = 3; - } - - result = ma_device_init_internal__coreaudio(pDevice->pContext, ma_device_type_capture, pDescriptorCapture->pDeviceID, &data, (void*)pDevice); - if (result != MA_SUCCESS) { - return result; - } - - pDevice->coreaudio.isDefaultCaptureDevice = (pConfig->capture.pDeviceID == NULL); - #if defined(MA_APPLE_DESKTOP) - pDevice->coreaudio.deviceObjectIDCapture = (ma_uint32)data.deviceObjectID; - #endif - pDevice->coreaudio.audioUnitCapture = (ma_ptr)data.audioUnit; - pDevice->coreaudio.pAudioBufferList = (ma_ptr)data.pAudioBufferList; - pDevice->coreaudio.audioBufferCapInFrames = data.periodSizeInFramesOut; - pDevice->coreaudio.originalPeriodSizeInFrames = pDescriptorCapture->periodSizeInFrames; - pDevice->coreaudio.originalPeriodSizeInMilliseconds = pDescriptorCapture->periodSizeInMilliseconds; - pDevice->coreaudio.originalPeriods = pDescriptorCapture->periodCount; - pDevice->coreaudio.originalPerformanceProfile = pConfig->performanceProfile; - - pDescriptorCapture->format = data.formatOut; - pDescriptorCapture->channels = data.channelsOut; - pDescriptorCapture->sampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDescriptorCapture->channelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDescriptorCapture->periodSizeInFrames = data.periodSizeInFramesOut; - pDescriptorCapture->periodCount = data.periodsOut; - - #if defined(MA_APPLE_DESKTOP) - ma_get_AudioObject_uid(pDevice->pContext, pDevice->coreaudio.deviceObjectIDCapture, sizeof(pDevice->capture.id.coreaudio), pDevice->capture.id.coreaudio); - - /* - If we are using the default device we'll need to listen for changes to the system's default device so we can seemlessly - switch the device in the background. - */ - if (pConfig->capture.pDeviceID == NULL) { - ma_device__track__coreaudio(pDevice); - } - #endif - } - - /* Playback. */ - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_device_init_internal_data__coreaudio data; - data.allowNominalSampleRateChange = pConfig->coreaudio.allowNominalSampleRateChange; - data.formatIn = pDescriptorPlayback->format; - data.channelsIn = pDescriptorPlayback->channels; - data.sampleRateIn = pDescriptorPlayback->sampleRate; - MA_COPY_MEMORY(data.channelMapIn, pDescriptorPlayback->channelMap, sizeof(pDescriptorPlayback->channelMap)); - data.shareMode = pDescriptorPlayback->shareMode; - data.performanceProfile = pConfig->performanceProfile; - - /* In full-duplex mode we want the playback buffer to be the same size as the capture buffer. */ - if (pConfig->deviceType == ma_device_type_duplex) { - data.periodSizeInFramesIn = pDescriptorCapture->periodSizeInFrames; - data.periodsIn = pDescriptorCapture->periodCount; - data.registerStopEvent = MA_FALSE; - } else { - data.periodSizeInFramesIn = pDescriptorPlayback->periodSizeInFrames; - data.periodSizeInMillisecondsIn = pDescriptorPlayback->periodSizeInMilliseconds; - data.periodsIn = pDescriptorPlayback->periodCount; - data.registerStopEvent = MA_TRUE; - } - - result = ma_device_init_internal__coreaudio(pDevice->pContext, ma_device_type_playback, pDescriptorPlayback->pDeviceID, &data, (void*)pDevice); - if (result != MA_SUCCESS) { - if (pConfig->deviceType == ma_device_type_duplex) { - ((ma_AudioComponentInstanceDispose_proc)pDevice->pContext->coreaudio.AudioComponentInstanceDispose)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - if (pDevice->coreaudio.pAudioBufferList) { - ma_free(pDevice->coreaudio.pAudioBufferList, &pDevice->pContext->allocationCallbacks); - } - } - return result; - } - - pDevice->coreaudio.isDefaultPlaybackDevice = (pConfig->playback.pDeviceID == NULL); - #if defined(MA_APPLE_DESKTOP) - pDevice->coreaudio.deviceObjectIDPlayback = (ma_uint32)data.deviceObjectID; - #endif - pDevice->coreaudio.audioUnitPlayback = (ma_ptr)data.audioUnit; - pDevice->coreaudio.originalPeriodSizeInFrames = pDescriptorPlayback->periodSizeInFrames; - pDevice->coreaudio.originalPeriodSizeInMilliseconds = pDescriptorPlayback->periodSizeInMilliseconds; - pDevice->coreaudio.originalPeriods = pDescriptorPlayback->periodCount; - pDevice->coreaudio.originalPerformanceProfile = pConfig->performanceProfile; - - pDescriptorPlayback->format = data.formatOut; - pDescriptorPlayback->channels = data.channelsOut; - pDescriptorPlayback->sampleRate = data.sampleRateOut; - MA_COPY_MEMORY(pDescriptorPlayback->channelMap, data.channelMapOut, sizeof(data.channelMapOut)); - pDescriptorPlayback->periodSizeInFrames = data.periodSizeInFramesOut; - pDescriptorPlayback->periodCount = data.periodsOut; - - #if defined(MA_APPLE_DESKTOP) - ma_get_AudioObject_uid(pDevice->pContext, pDevice->coreaudio.deviceObjectIDPlayback, sizeof(pDevice->playback.id.coreaudio), pDevice->playback.id.coreaudio); - - /* - If we are using the default device we'll need to listen for changes to the system's default device so we can seemlessly - switch the device in the background. - */ - if (pDescriptorPlayback->pDeviceID == NULL && (pConfig->deviceType != ma_device_type_duplex || pDescriptorCapture->pDeviceID != NULL)) { - ma_device__track__coreaudio(pDevice); - } - #endif - } - - - - /* - When stopping the device, a callback is called on another thread. We need to wait for this callback - before returning from ma_device_stop(). This event is used for this. - */ - ma_event_init(&pDevice->coreaudio.stopEvent); - - /* - We need to detect when a route has changed so we can update the data conversion pipeline accordingly. This is done - differently on non-Desktop Apple platforms. - */ -#if defined(MA_APPLE_MOBILE) - pDevice->coreaudio.pNotificationHandler = (MA_BRIDGE_RETAINED void*)[[ma_ios_notification_handler alloc] init:pDevice]; -#endif - - return MA_SUCCESS; -} - - -static ma_result ma_device_start__coreaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - OSStatus status = ((ma_AudioOutputUnitStart_proc)pDevice->pContext->coreaudio.AudioOutputUnitStart)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - OSStatus status = ((ma_AudioOutputUnitStart_proc)pDevice->pContext->coreaudio.AudioOutputUnitStart)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - if (status != noErr) { - if (pDevice->type == ma_device_type_duplex) { - ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - } - return ma_result_from_OSStatus(status); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__coreaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - /* It's not clear from the documentation whether or not AudioOutputUnitStop() actually drains the device or not. */ - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - OSStatus status = ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitCapture); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - OSStatus status = ((ma_AudioOutputUnitStop_proc)pDevice->pContext->coreaudio.AudioOutputUnitStop)((AudioUnit)pDevice->coreaudio.audioUnitPlayback); - if (status != noErr) { - return ma_result_from_OSStatus(status); - } - } - - /* We need to wait for the callback to finish before returning. */ - ma_event_wait(&pDevice->coreaudio.stopEvent); - return MA_SUCCESS; -} - - -static ma_result ma_context_uninit__coreaudio(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_coreaudio); - -#if defined(MA_APPLE_MOBILE) - if (!pContext->coreaudio.noAudioSessionDeactivate) { - if (![[AVAudioSession sharedInstance] setActive:false error:nil]) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "Failed to deactivate audio session."); - return MA_FAILED_TO_INIT_BACKEND; - } - } -#endif - -#if !defined(MA_NO_RUNTIME_LINKING) && !defined(MA_APPLE_MOBILE) - ma_dlclose(pContext, pContext->coreaudio.hAudioUnit); - ma_dlclose(pContext, pContext->coreaudio.hCoreAudio); - ma_dlclose(pContext, pContext->coreaudio.hCoreFoundation); -#endif - -#if !defined(MA_APPLE_MOBILE) - ma_context__uninit_device_tracking__coreaudio(pContext); -#endif - - (void)pContext; - return MA_SUCCESS; -} - -#if defined(MA_APPLE_MOBILE) && defined(__IPHONE_12_0) -static AVAudioSessionCategory ma_to_AVAudioSessionCategory(ma_ios_session_category category) -{ - /* The "default" and "none" categories are treated different and should not be used as an input into this function. */ - MA_ASSERT(category != ma_ios_session_category_default); - MA_ASSERT(category != ma_ios_session_category_none); - - switch (category) { - case ma_ios_session_category_ambient: return AVAudioSessionCategoryAmbient; - case ma_ios_session_category_solo_ambient: return AVAudioSessionCategorySoloAmbient; - case ma_ios_session_category_playback: return AVAudioSessionCategoryPlayback; - case ma_ios_session_category_record: return AVAudioSessionCategoryRecord; - case ma_ios_session_category_play_and_record: return AVAudioSessionCategoryPlayAndRecord; - case ma_ios_session_category_multi_route: return AVAudioSessionCategoryMultiRoute; - case ma_ios_session_category_none: return AVAudioSessionCategoryAmbient; - case ma_ios_session_category_default: return AVAudioSessionCategoryAmbient; - default: return AVAudioSessionCategoryAmbient; - } -} -#endif - -static ma_result ma_context_init__coreaudio(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ -#if !defined(MA_APPLE_MOBILE) - ma_result result; -#endif - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pContext != NULL); - -#if defined(MA_APPLE_MOBILE) - @autoreleasepool { - AVAudioSession* pAudioSession = [AVAudioSession sharedInstance]; - AVAudioSessionCategoryOptions options = pConfig->coreaudio.sessionCategoryOptions; - - MA_ASSERT(pAudioSession != NULL); - - if (pConfig->coreaudio.sessionCategory == ma_ios_session_category_default) { - /* - I'm going to use trial and error to determine our default session category. First we'll try PlayAndRecord. If that fails - we'll try Playback and if that fails we'll try record. If all of these fail we'll just not set the category. - */ - #if !defined(MA_APPLE_TV) && !defined(MA_APPLE_WATCH) - options |= AVAudioSessionCategoryOptionDefaultToSpeaker; - #endif - - if ([pAudioSession setCategory: AVAudioSessionCategoryPlayAndRecord withOptions:options error:nil]) { - /* Using PlayAndRecord */ - } else if ([pAudioSession setCategory: AVAudioSessionCategoryPlayback withOptions:options error:nil]) { - /* Using Playback */ - } else if ([pAudioSession setCategory: AVAudioSessionCategoryRecord withOptions:options error:nil]) { - /* Using Record */ - } else { - /* Leave as default? */ - } - } else { - if (pConfig->coreaudio.sessionCategory != ma_ios_session_category_none) { - #if defined(__IPHONE_12_0) - if (![pAudioSession setCategory: ma_to_AVAudioSessionCategory(pConfig->coreaudio.sessionCategory) withOptions:options error:nil]) { - return MA_INVALID_OPERATION; /* Failed to set session category. */ - } - #else - /* Ignore the session category on version 11 and older, but post a warning. */ - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "Session category only supported in iOS 12 and newer."); - #endif - } - } - - if (!pConfig->coreaudio.noAudioSessionActivate) { - if (![pAudioSession setActive:true error:nil]) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "Failed to activate audio session."); - return MA_FAILED_TO_INIT_BACKEND; - } - } - } -#endif - -#if !defined(MA_NO_RUNTIME_LINKING) && !defined(MA_APPLE_MOBILE) - pContext->coreaudio.hCoreFoundation = ma_dlopen(pContext, "CoreFoundation.framework/CoreFoundation"); - if (pContext->coreaudio.hCoreFoundation == NULL) { - return MA_API_NOT_FOUND; - } - - pContext->coreaudio.CFStringGetCString = ma_dlsym(pContext, pContext->coreaudio.hCoreFoundation, "CFStringGetCString"); - pContext->coreaudio.CFRelease = ma_dlsym(pContext, pContext->coreaudio.hCoreFoundation, "CFRelease"); - - - pContext->coreaudio.hCoreAudio = ma_dlopen(pContext, "CoreAudio.framework/CoreAudio"); - if (pContext->coreaudio.hCoreAudio == NULL) { - ma_dlclose(pContext, pContext->coreaudio.hCoreFoundation); - return MA_API_NOT_FOUND; - } - - pContext->coreaudio.AudioObjectGetPropertyData = ma_dlsym(pContext, pContext->coreaudio.hCoreAudio, "AudioObjectGetPropertyData"); - pContext->coreaudio.AudioObjectGetPropertyDataSize = ma_dlsym(pContext, pContext->coreaudio.hCoreAudio, "AudioObjectGetPropertyDataSize"); - pContext->coreaudio.AudioObjectSetPropertyData = ma_dlsym(pContext, pContext->coreaudio.hCoreAudio, "AudioObjectSetPropertyData"); - pContext->coreaudio.AudioObjectAddPropertyListener = ma_dlsym(pContext, pContext->coreaudio.hCoreAudio, "AudioObjectAddPropertyListener"); - pContext->coreaudio.AudioObjectRemovePropertyListener = ma_dlsym(pContext, pContext->coreaudio.hCoreAudio, "AudioObjectRemovePropertyListener"); - - /* - It looks like Apple has moved some APIs from AudioUnit into AudioToolbox on more recent versions of macOS. They are still - defined in AudioUnit, but just in case they decide to remove them from there entirely I'm going to implement a fallback. - The way it'll work is that it'll first try AudioUnit, and if the required symbols are not present there we'll fall back to - AudioToolbox. - */ - pContext->coreaudio.hAudioUnit = ma_dlopen(pContext, "AudioUnit.framework/AudioUnit"); - if (pContext->coreaudio.hAudioUnit == NULL) { - ma_dlclose(pContext, pContext->coreaudio.hCoreAudio); - ma_dlclose(pContext, pContext->coreaudio.hCoreFoundation); - return MA_API_NOT_FOUND; - } - - if (ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioComponentFindNext") == NULL) { - /* Couldn't find the required symbols in AudioUnit, so fall back to AudioToolbox. */ - ma_dlclose(pContext, pContext->coreaudio.hAudioUnit); - pContext->coreaudio.hAudioUnit = ma_dlopen(pContext, "AudioToolbox.framework/AudioToolbox"); - if (pContext->coreaudio.hAudioUnit == NULL) { - ma_dlclose(pContext, pContext->coreaudio.hCoreAudio); - ma_dlclose(pContext, pContext->coreaudio.hCoreFoundation); - return MA_API_NOT_FOUND; - } - } - - pContext->coreaudio.AudioComponentFindNext = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioComponentFindNext"); - pContext->coreaudio.AudioComponentInstanceDispose = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioComponentInstanceDispose"); - pContext->coreaudio.AudioComponentInstanceNew = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioComponentInstanceNew"); - pContext->coreaudio.AudioOutputUnitStart = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioOutputUnitStart"); - pContext->coreaudio.AudioOutputUnitStop = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioOutputUnitStop"); - pContext->coreaudio.AudioUnitAddPropertyListener = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioUnitAddPropertyListener"); - pContext->coreaudio.AudioUnitGetPropertyInfo = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioUnitGetPropertyInfo"); - pContext->coreaudio.AudioUnitGetProperty = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioUnitGetProperty"); - pContext->coreaudio.AudioUnitSetProperty = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioUnitSetProperty"); - pContext->coreaudio.AudioUnitInitialize = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioUnitInitialize"); - pContext->coreaudio.AudioUnitRender = ma_dlsym(pContext, pContext->coreaudio.hAudioUnit, "AudioUnitRender"); -#else - pContext->coreaudio.CFStringGetCString = (ma_proc)CFStringGetCString; - pContext->coreaudio.CFRelease = (ma_proc)CFRelease; - - #if defined(MA_APPLE_DESKTOP) - pContext->coreaudio.AudioObjectGetPropertyData = (ma_proc)AudioObjectGetPropertyData; - pContext->coreaudio.AudioObjectGetPropertyDataSize = (ma_proc)AudioObjectGetPropertyDataSize; - pContext->coreaudio.AudioObjectSetPropertyData = (ma_proc)AudioObjectSetPropertyData; - pContext->coreaudio.AudioObjectAddPropertyListener = (ma_proc)AudioObjectAddPropertyListener; - pContext->coreaudio.AudioObjectRemovePropertyListener = (ma_proc)AudioObjectRemovePropertyListener; - #endif - - pContext->coreaudio.AudioComponentFindNext = (ma_proc)AudioComponentFindNext; - pContext->coreaudio.AudioComponentInstanceDispose = (ma_proc)AudioComponentInstanceDispose; - pContext->coreaudio.AudioComponentInstanceNew = (ma_proc)AudioComponentInstanceNew; - pContext->coreaudio.AudioOutputUnitStart = (ma_proc)AudioOutputUnitStart; - pContext->coreaudio.AudioOutputUnitStop = (ma_proc)AudioOutputUnitStop; - pContext->coreaudio.AudioUnitAddPropertyListener = (ma_proc)AudioUnitAddPropertyListener; - pContext->coreaudio.AudioUnitGetPropertyInfo = (ma_proc)AudioUnitGetPropertyInfo; - pContext->coreaudio.AudioUnitGetProperty = (ma_proc)AudioUnitGetProperty; - pContext->coreaudio.AudioUnitSetProperty = (ma_proc)AudioUnitSetProperty; - pContext->coreaudio.AudioUnitInitialize = (ma_proc)AudioUnitInitialize; - pContext->coreaudio.AudioUnitRender = (ma_proc)AudioUnitRender; -#endif - - /* Audio component. */ - { - AudioComponentDescription desc; - desc.componentType = kAudioUnitType_Output; - #if defined(MA_APPLE_DESKTOP) - desc.componentSubType = kAudioUnitSubType_HALOutput; - #else - desc.componentSubType = kAudioUnitSubType_RemoteIO; - #endif - desc.componentManufacturer = kAudioUnitManufacturer_Apple; - desc.componentFlags = 0; - desc.componentFlagsMask = 0; - - pContext->coreaudio.component = ((ma_AudioComponentFindNext_proc)pContext->coreaudio.AudioComponentFindNext)(NULL, &desc); - if (pContext->coreaudio.component == NULL) { - #if !defined(MA_NO_RUNTIME_LINKING) && !defined(MA_APPLE_MOBILE) - ma_dlclose(pContext, pContext->coreaudio.hAudioUnit); - ma_dlclose(pContext, pContext->coreaudio.hCoreAudio); - ma_dlclose(pContext, pContext->coreaudio.hCoreFoundation); - #endif - return MA_FAILED_TO_INIT_BACKEND; - } - } - -#if !defined(MA_APPLE_MOBILE) - result = ma_context__init_device_tracking__coreaudio(pContext); - if (result != MA_SUCCESS) { - #if !defined(MA_NO_RUNTIME_LINKING) && !defined(MA_APPLE_MOBILE) - ma_dlclose(pContext, pContext->coreaudio.hAudioUnit); - ma_dlclose(pContext, pContext->coreaudio.hCoreAudio); - ma_dlclose(pContext, pContext->coreaudio.hCoreFoundation); - #endif - return result; - } -#endif - - pContext->coreaudio.noAudioSessionDeactivate = pConfig->coreaudio.noAudioSessionDeactivate; - - pCallbacks->onContextInit = ma_context_init__coreaudio; - pCallbacks->onContextUninit = ma_context_uninit__coreaudio; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__coreaudio; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__coreaudio; - pCallbacks->onDeviceInit = ma_device_init__coreaudio; - pCallbacks->onDeviceUninit = ma_device_uninit__coreaudio; - pCallbacks->onDeviceStart = ma_device_start__coreaudio; - pCallbacks->onDeviceStop = ma_device_stop__coreaudio; - pCallbacks->onDeviceRead = NULL; - pCallbacks->onDeviceWrite = NULL; - pCallbacks->onDeviceDataLoop = NULL; - - return MA_SUCCESS; -} -#endif /* Core Audio */ - - - -/****************************************************************************** - -sndio Backend - -******************************************************************************/ -#ifdef MA_HAS_SNDIO -#include - -/* -Only supporting OpenBSD. This did not work very well at all on FreeBSD when I tried it. Not sure if this is due -to miniaudio's implementation or if it's some kind of system configuration issue, but basically the default device -just doesn't emit any sound, or at times you'll hear tiny pieces. I will consider enabling this when there's -demand for it or if I can get it tested and debugged more thoroughly. -*/ -#if 0 -#if defined(__NetBSD__) || defined(__OpenBSD__) -#include -#endif -#if defined(__FreeBSD__) || defined(__DragonFly__) -#include -#endif -#endif - -#define MA_SIO_DEVANY "default" -#define MA_SIO_PLAY 1 -#define MA_SIO_REC 2 -#define MA_SIO_NENC 8 -#define MA_SIO_NCHAN 8 -#define MA_SIO_NRATE 16 -#define MA_SIO_NCONF 4 - -struct ma_sio_hdl; /* <-- Opaque */ - -struct ma_sio_par -{ - unsigned int bits; - unsigned int bps; - unsigned int sig; - unsigned int le; - unsigned int msb; - unsigned int rchan; - unsigned int pchan; - unsigned int rate; - unsigned int bufsz; - unsigned int xrun; - unsigned int round; - unsigned int appbufsz; - int __pad[3]; - unsigned int __magic; -}; - -struct ma_sio_enc -{ - unsigned int bits; - unsigned int bps; - unsigned int sig; - unsigned int le; - unsigned int msb; -}; - -struct ma_sio_conf -{ - unsigned int enc; - unsigned int rchan; - unsigned int pchan; - unsigned int rate; -}; - -struct ma_sio_cap -{ - struct ma_sio_enc enc[MA_SIO_NENC]; - unsigned int rchan[MA_SIO_NCHAN]; - unsigned int pchan[MA_SIO_NCHAN]; - unsigned int rate[MA_SIO_NRATE]; - int __pad[7]; - unsigned int nconf; - struct ma_sio_conf confs[MA_SIO_NCONF]; -}; - -typedef struct ma_sio_hdl* (* ma_sio_open_proc) (const char*, unsigned int, int); -typedef void (* ma_sio_close_proc) (struct ma_sio_hdl*); -typedef int (* ma_sio_setpar_proc) (struct ma_sio_hdl*, struct ma_sio_par*); -typedef int (* ma_sio_getpar_proc) (struct ma_sio_hdl*, struct ma_sio_par*); -typedef int (* ma_sio_getcap_proc) (struct ma_sio_hdl*, struct ma_sio_cap*); -typedef size_t (* ma_sio_write_proc) (struct ma_sio_hdl*, const void*, size_t); -typedef size_t (* ma_sio_read_proc) (struct ma_sio_hdl*, void*, size_t); -typedef int (* ma_sio_start_proc) (struct ma_sio_hdl*); -typedef int (* ma_sio_stop_proc) (struct ma_sio_hdl*); -typedef int (* ma_sio_initpar_proc)(struct ma_sio_par*); - -static ma_uint32 ma_get_standard_sample_rate_priority_index__sndio(ma_uint32 sampleRate) /* Lower = higher priority */ -{ - ma_uint32 i; - for (i = 0; i < ma_countof(g_maStandardSampleRatePriorities); ++i) { - if (g_maStandardSampleRatePriorities[i] == sampleRate) { - return i; - } - } - - return (ma_uint32)-1; -} - -static ma_format ma_format_from_sio_enc__sndio(unsigned int bits, unsigned int bps, unsigned int sig, unsigned int le, unsigned int msb) -{ - /* We only support native-endian right now. */ - if ((ma_is_little_endian() && le == 0) || (ma_is_big_endian() && le == 1)) { - return ma_format_unknown; - } - - if (bits == 8 && bps == 1 && sig == 0) { - return ma_format_u8; - } - if (bits == 16 && bps == 2 && sig == 1) { - return ma_format_s16; - } - if (bits == 24 && bps == 3 && sig == 1) { - return ma_format_s24; - } - if (bits == 24 && bps == 4 && sig == 1 && msb == 0) { - /*return ma_format_s24_32;*/ - } - if (bits == 32 && bps == 4 && sig == 1) { - return ma_format_s32; - } - - return ma_format_unknown; -} - -static ma_format ma_find_best_format_from_sio_cap__sndio(struct ma_sio_cap* caps) -{ - ma_format bestFormat; - unsigned int iConfig; - - MA_ASSERT(caps != NULL); - - bestFormat = ma_format_unknown; - for (iConfig = 0; iConfig < caps->nconf; iConfig += 1) { - unsigned int iEncoding; - for (iEncoding = 0; iEncoding < MA_SIO_NENC; iEncoding += 1) { - unsigned int bits; - unsigned int bps; - unsigned int sig; - unsigned int le; - unsigned int msb; - ma_format format; - - if ((caps->confs[iConfig].enc & (1UL << iEncoding)) == 0) { - continue; - } - - bits = caps->enc[iEncoding].bits; - bps = caps->enc[iEncoding].bps; - sig = caps->enc[iEncoding].sig; - le = caps->enc[iEncoding].le; - msb = caps->enc[iEncoding].msb; - format = ma_format_from_sio_enc__sndio(bits, bps, sig, le, msb); - if (format == ma_format_unknown) { - continue; /* Format not supported. */ - } - - if (bestFormat == ma_format_unknown) { - bestFormat = format; - } else { - if (ma_get_format_priority_index(bestFormat) > ma_get_format_priority_index(format)) { /* <-- Lower = better. */ - bestFormat = format; - } - } - } - } - - return bestFormat; -} - -static ma_uint32 ma_find_best_channels_from_sio_cap__sndio(struct ma_sio_cap* caps, ma_device_type deviceType, ma_format requiredFormat) -{ - ma_uint32 maxChannels; - unsigned int iConfig; - - MA_ASSERT(caps != NULL); - MA_ASSERT(requiredFormat != ma_format_unknown); - - /* Just pick whatever configuration has the most channels. */ - maxChannels = 0; - for (iConfig = 0; iConfig < caps->nconf; iConfig += 1) { - /* The encoding should be of requiredFormat. */ - unsigned int iEncoding; - for (iEncoding = 0; iEncoding < MA_SIO_NENC; iEncoding += 1) { - unsigned int iChannel; - unsigned int bits; - unsigned int bps; - unsigned int sig; - unsigned int le; - unsigned int msb; - ma_format format; - - if ((caps->confs[iConfig].enc & (1UL << iEncoding)) == 0) { - continue; - } - - bits = caps->enc[iEncoding].bits; - bps = caps->enc[iEncoding].bps; - sig = caps->enc[iEncoding].sig; - le = caps->enc[iEncoding].le; - msb = caps->enc[iEncoding].msb; - format = ma_format_from_sio_enc__sndio(bits, bps, sig, le, msb); - if (format != requiredFormat) { - continue; - } - - /* Getting here means the format is supported. Iterate over each channel count and grab the biggest one. */ - for (iChannel = 0; iChannel < MA_SIO_NCHAN; iChannel += 1) { - unsigned int chan = 0; - unsigned int channels; - - if (deviceType == ma_device_type_playback) { - chan = caps->confs[iConfig].pchan; - } else { - chan = caps->confs[iConfig].rchan; - } - - if ((chan & (1UL << iChannel)) == 0) { - continue; - } - - if (deviceType == ma_device_type_playback) { - channels = caps->pchan[iChannel]; - } else { - channels = caps->rchan[iChannel]; - } - - if (maxChannels < channels) { - maxChannels = channels; - } - } - } - } - - return maxChannels; -} - -static ma_uint32 ma_find_best_sample_rate_from_sio_cap__sndio(struct ma_sio_cap* caps, ma_device_type deviceType, ma_format requiredFormat, ma_uint32 requiredChannels) -{ - ma_uint32 firstSampleRate; - ma_uint32 bestSampleRate; - unsigned int iConfig; - - MA_ASSERT(caps != NULL); - MA_ASSERT(requiredFormat != ma_format_unknown); - MA_ASSERT(requiredChannels > 0); - MA_ASSERT(requiredChannels <= MA_MAX_CHANNELS); - - firstSampleRate = 0; /* <-- If the device does not support a standard rate we'll fall back to the first one that's found. */ - bestSampleRate = 0; - - for (iConfig = 0; iConfig < caps->nconf; iConfig += 1) { - /* The encoding should be of requiredFormat. */ - unsigned int iEncoding; - for (iEncoding = 0; iEncoding < MA_SIO_NENC; iEncoding += 1) { - unsigned int iChannel; - unsigned int bits; - unsigned int bps; - unsigned int sig; - unsigned int le; - unsigned int msb; - ma_format format; - - if ((caps->confs[iConfig].enc & (1UL << iEncoding)) == 0) { - continue; - } - - bits = caps->enc[iEncoding].bits; - bps = caps->enc[iEncoding].bps; - sig = caps->enc[iEncoding].sig; - le = caps->enc[iEncoding].le; - msb = caps->enc[iEncoding].msb; - format = ma_format_from_sio_enc__sndio(bits, bps, sig, le, msb); - if (format != requiredFormat) { - continue; - } - - /* Getting here means the format is supported. Iterate over each channel count and grab the biggest one. */ - for (iChannel = 0; iChannel < MA_SIO_NCHAN; iChannel += 1) { - unsigned int chan = 0; - unsigned int channels; - unsigned int iRate; - - if (deviceType == ma_device_type_playback) { - chan = caps->confs[iConfig].pchan; - } else { - chan = caps->confs[iConfig].rchan; - } - - if ((chan & (1UL << iChannel)) == 0) { - continue; - } - - if (deviceType == ma_device_type_playback) { - channels = caps->pchan[iChannel]; - } else { - channels = caps->rchan[iChannel]; - } - - if (channels != requiredChannels) { - continue; - } - - /* Getting here means we have found a compatible encoding/channel pair. */ - for (iRate = 0; iRate < MA_SIO_NRATE; iRate += 1) { - ma_uint32 rate = (ma_uint32)caps->rate[iRate]; - ma_uint32 ratePriority; - - if (firstSampleRate == 0) { - firstSampleRate = rate; - } - - /* Disregard this rate if it's not a standard one. */ - ratePriority = ma_get_standard_sample_rate_priority_index__sndio(rate); - if (ratePriority == (ma_uint32)-1) { - continue; - } - - if (ma_get_standard_sample_rate_priority_index__sndio(bestSampleRate) > ratePriority) { /* Lower = better. */ - bestSampleRate = rate; - } - } - } - } - } - - /* If a standard sample rate was not found just fall back to the first one that was iterated. */ - if (bestSampleRate == 0) { - bestSampleRate = firstSampleRate; - } - - return bestSampleRate; -} - - -static ma_result ma_context_enumerate_devices__sndio(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_bool32 isTerminating = MA_FALSE; - struct ma_sio_hdl* handle; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* sndio doesn't seem to have a good device enumeration API, so I'm therefore only enumerating over default devices for now. */ - - /* Playback. */ - if (!isTerminating) { - handle = ((ma_sio_open_proc)pContext->sndio.sio_open)(MA_SIO_DEVANY, MA_SIO_PLAY, 0); - if (handle != NULL) { - /* Supports playback. */ - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strcpy_s(deviceInfo.id.sndio, sizeof(deviceInfo.id.sndio), MA_SIO_DEVANY); - ma_strcpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME); - - isTerminating = !callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - - ((ma_sio_close_proc)pContext->sndio.sio_close)(handle); - } - } - - /* Capture. */ - if (!isTerminating) { - handle = ((ma_sio_open_proc)pContext->sndio.sio_open)(MA_SIO_DEVANY, MA_SIO_REC, 0); - if (handle != NULL) { - /* Supports capture. */ - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strcpy_s(deviceInfo.id.sndio, sizeof(deviceInfo.id.sndio), "default"); - ma_strcpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_CAPTURE_DEVICE_NAME); - - isTerminating = !callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - - ((ma_sio_close_proc)pContext->sndio.sio_close)(handle); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__sndio(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - char devid[256]; - struct ma_sio_hdl* handle; - struct ma_sio_cap caps; - unsigned int iConfig; - - MA_ASSERT(pContext != NULL); - - /* We need to open the device before we can get information about it. */ - if (pDeviceID == NULL) { - ma_strcpy_s(devid, sizeof(devid), MA_SIO_DEVANY); - ma_strcpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), (deviceType == ma_device_type_playback) ? MA_DEFAULT_PLAYBACK_DEVICE_NAME : MA_DEFAULT_CAPTURE_DEVICE_NAME); - } else { - ma_strcpy_s(devid, sizeof(devid), pDeviceID->sndio); - ma_strcpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), devid); - } - - handle = ((ma_sio_open_proc)pContext->sndio.sio_open)(devid, (deviceType == ma_device_type_playback) ? MA_SIO_PLAY : MA_SIO_REC, 0); - if (handle == NULL) { - return MA_NO_DEVICE; - } - - if (((ma_sio_getcap_proc)pContext->sndio.sio_getcap)(handle, &caps) == 0) { - return MA_ERROR; - } - - pDeviceInfo->nativeDataFormatCount = 0; - - for (iConfig = 0; iConfig < caps.nconf; iConfig += 1) { - /* - The main thing we care about is that the encoding is supported by miniaudio. If it is, we want to give - preference to some formats over others. - */ - unsigned int iEncoding; - unsigned int iChannel; - unsigned int iRate; - - for (iEncoding = 0; iEncoding < MA_SIO_NENC; iEncoding += 1) { - unsigned int bits; - unsigned int bps; - unsigned int sig; - unsigned int le; - unsigned int msb; - ma_format format; - - if ((caps.confs[iConfig].enc & (1UL << iEncoding)) == 0) { - continue; - } - - bits = caps.enc[iEncoding].bits; - bps = caps.enc[iEncoding].bps; - sig = caps.enc[iEncoding].sig; - le = caps.enc[iEncoding].le; - msb = caps.enc[iEncoding].msb; - format = ma_format_from_sio_enc__sndio(bits, bps, sig, le, msb); - if (format == ma_format_unknown) { - continue; /* Format not supported. */ - } - - - /* Channels. */ - for (iChannel = 0; iChannel < MA_SIO_NCHAN; iChannel += 1) { - unsigned int chan = 0; - unsigned int channels; - - if (deviceType == ma_device_type_playback) { - chan = caps.confs[iConfig].pchan; - } else { - chan = caps.confs[iConfig].rchan; - } - - if ((chan & (1UL << iChannel)) == 0) { - continue; - } - - if (deviceType == ma_device_type_playback) { - channels = caps.pchan[iChannel]; - } else { - channels = caps.rchan[iChannel]; - } - - - /* Sample Rates. */ - for (iRate = 0; iRate < MA_SIO_NRATE; iRate += 1) { - if ((caps.confs[iConfig].rate & (1UL << iRate)) != 0) { - ma_device_info_add_native_data_format(pDeviceInfo, format, channels, caps.rate[iRate], 0); - } - } - } - } - } - - ((ma_sio_close_proc)pContext->sndio.sio_close)(handle); - return MA_SUCCESS; -} - -static ma_result ma_device_uninit__sndio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ((ma_sio_close_proc)pDevice->pContext->sndio.sio_close)((struct ma_sio_hdl*)pDevice->sndio.handleCapture); - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ((ma_sio_close_proc)pDevice->pContext->sndio.sio_close)((struct ma_sio_hdl*)pDevice->sndio.handlePlayback); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_init_handle__sndio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptor, ma_device_type deviceType) -{ - const char* pDeviceName; - ma_ptr handle; - int openFlags = 0; - struct ma_sio_cap caps; - struct ma_sio_par par; - const ma_device_id* pDeviceID; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - ma_format internalFormat; - ma_uint32 internalChannels; - ma_uint32 internalSampleRate; - ma_uint32 internalPeriodSizeInFrames; - ma_uint32 internalPeriods; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(deviceType != ma_device_type_duplex); - MA_ASSERT(pDevice != NULL); - - if (deviceType == ma_device_type_capture) { - openFlags = MA_SIO_REC; - } else { - openFlags = MA_SIO_PLAY; - } - - pDeviceID = pDescriptor->pDeviceID; - format = pDescriptor->format; - channels = pDescriptor->channels; - sampleRate = pDescriptor->sampleRate; - - pDeviceName = MA_SIO_DEVANY; - if (pDeviceID != NULL) { - pDeviceName = pDeviceID->sndio; - } - - handle = (ma_ptr)((ma_sio_open_proc)pDevice->pContext->sndio.sio_open)(pDeviceName, openFlags, 0); - if (handle == NULL) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[sndio] Failed to open device."); - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } - - /* We need to retrieve the device caps to determine the most appropriate format to use. */ - if (((ma_sio_getcap_proc)pDevice->pContext->sndio.sio_getcap)((struct ma_sio_hdl*)handle, &caps) == 0) { - ((ma_sio_close_proc)pDevice->pContext->sndio.sio_close)((struct ma_sio_hdl*)handle); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[sndio] Failed to retrieve device caps."); - return MA_ERROR; - } - - /* - Note: sndio reports a huge range of available channels. This is inconvenient for us because there's no real - way, as far as I can tell, to get the _actual_ channel count of the device. I'm therefore restricting this - to the requested channels, regardless of whether or not the default channel count is requested. - - For hardware devices, I'm suspecting only a single channel count will be reported and we can safely use the - value returned by ma_find_best_channels_from_sio_cap__sndio(). - */ - if (deviceType == ma_device_type_capture) { - if (format == ma_format_unknown) { - format = ma_find_best_format_from_sio_cap__sndio(&caps); - } - - if (channels == 0) { - if (strlen(pDeviceName) > strlen("rsnd/") && strncmp(pDeviceName, "rsnd/", strlen("rsnd/")) == 0) { - channels = ma_find_best_channels_from_sio_cap__sndio(&caps, deviceType, format); - } else { - channels = MA_DEFAULT_CHANNELS; - } - } - } else { - if (format == ma_format_unknown) { - format = ma_find_best_format_from_sio_cap__sndio(&caps); - } - - if (channels == 0) { - if (strlen(pDeviceName) > strlen("rsnd/") && strncmp(pDeviceName, "rsnd/", strlen("rsnd/")) == 0) { - channels = ma_find_best_channels_from_sio_cap__sndio(&caps, deviceType, format); - } else { - channels = MA_DEFAULT_CHANNELS; - } - } - } - - if (sampleRate == 0) { - sampleRate = ma_find_best_sample_rate_from_sio_cap__sndio(&caps, pConfig->deviceType, format, channels); - } - - - ((ma_sio_initpar_proc)pDevice->pContext->sndio.sio_initpar)(&par); - par.msb = 0; - par.le = ma_is_little_endian(); - - switch (format) { - case ma_format_u8: - { - par.bits = 8; - par.bps = 1; - par.sig = 0; - } break; - - case ma_format_s24: - { - par.bits = 24; - par.bps = 3; - par.sig = 1; - } break; - - case ma_format_s32: - { - par.bits = 32; - par.bps = 4; - par.sig = 1; - } break; - - case ma_format_s16: - case ma_format_f32: - case ma_format_unknown: - default: - { - par.bits = 16; - par.bps = 2; - par.sig = 1; - } break; - } - - if (deviceType == ma_device_type_capture) { - par.rchan = channels; - } else { - par.pchan = channels; - } - - par.rate = sampleRate; - - internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, par.rate, pConfig->performanceProfile); - - par.round = internalPeriodSizeInFrames; - par.appbufsz = par.round * pDescriptor->periodCount; - - if (((ma_sio_setpar_proc)pDevice->pContext->sndio.sio_setpar)((struct ma_sio_hdl*)handle, &par) == 0) { - ((ma_sio_close_proc)pDevice->pContext->sndio.sio_close)((struct ma_sio_hdl*)handle); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[sndio] Failed to set buffer size."); - return MA_ERROR; - } - - if (((ma_sio_getpar_proc)pDevice->pContext->sndio.sio_getpar)((struct ma_sio_hdl*)handle, &par) == 0) { - ((ma_sio_close_proc)pDevice->pContext->sndio.sio_close)((struct ma_sio_hdl*)handle); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[sndio] Failed to retrieve buffer size."); - return MA_ERROR; - } - - internalFormat = ma_format_from_sio_enc__sndio(par.bits, par.bps, par.sig, par.le, par.msb); - internalChannels = (deviceType == ma_device_type_capture) ? par.rchan : par.pchan; - internalSampleRate = par.rate; - internalPeriods = par.appbufsz / par.round; - internalPeriodSizeInFrames = par.round; - - if (deviceType == ma_device_type_capture) { - pDevice->sndio.handleCapture = handle; - } else { - pDevice->sndio.handlePlayback = handle; - } - - pDescriptor->format = internalFormat; - pDescriptor->channels = internalChannels; - pDescriptor->sampleRate = internalSampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_sndio, pDescriptor->channelMap, ma_countof(pDescriptor->channelMap), internalChannels); - pDescriptor->periodSizeInFrames = internalPeriodSizeInFrames; - pDescriptor->periodCount = internalPeriods; - - return MA_SUCCESS; -} - -static ma_result ma_device_init__sndio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->sndio); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_handle__sndio(pDevice, pConfig, pDescriptorCapture, ma_device_type_capture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_handle__sndio(pDevice, pConfig, pDescriptorPlayback, ma_device_type_playback); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__sndio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ((ma_sio_start_proc)pDevice->pContext->sndio.sio_start)((struct ma_sio_hdl*)pDevice->sndio.handleCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ((ma_sio_start_proc)pDevice->pContext->sndio.sio_start)((struct ma_sio_hdl*)pDevice->sndio.handlePlayback); /* <-- Doesn't actually playback until data is written. */ - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__sndio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - /* - From the documentation: - - The sio_stop() function puts the audio subsystem in the same state as before sio_start() is called. It stops recording, drains the play buffer and then - stops playback. If samples to play are queued but playback hasn't started yet then playback is forced immediately; playback will actually stop once the - buffer is drained. In no case are samples in the play buffer discarded. - - Therefore, sio_stop() performs all of the necessary draining for us. - */ - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ((ma_sio_stop_proc)pDevice->pContext->sndio.sio_stop)((struct ma_sio_hdl*)pDevice->sndio.handleCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ((ma_sio_stop_proc)pDevice->pContext->sndio.sio_stop)((struct ma_sio_hdl*)pDevice->sndio.handlePlayback); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_write__sndio(ma_device* pDevice, const void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - int result; - - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - result = ((ma_sio_write_proc)pDevice->pContext->sndio.sio_write)((struct ma_sio_hdl*)pDevice->sndio.handlePlayback, pPCMFrames, frameCount * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - if (result == 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[sndio] Failed to send data from the client to the device."); - return MA_IO_ERROR; - } - - if (pFramesWritten != NULL) { - *pFramesWritten = frameCount; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_read__sndio(ma_device* pDevice, void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - int result; - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - result = ((ma_sio_read_proc)pDevice->pContext->sndio.sio_read)((struct ma_sio_hdl*)pDevice->sndio.handleCapture, pPCMFrames, frameCount * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels)); - if (result == 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[sndio] Failed to read data from the device to be sent to the device."); - return MA_IO_ERROR; - } - - if (pFramesRead != NULL) { - *pFramesRead = frameCount; - } - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__sndio(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_sndio); - - (void)pContext; - return MA_SUCCESS; -} - -static ma_result ma_context_init__sndio(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ -#ifndef MA_NO_RUNTIME_LINKING - const char* libsndioNames[] = { - "libsndio.so" - }; - size_t i; - - for (i = 0; i < ma_countof(libsndioNames); ++i) { - pContext->sndio.sndioSO = ma_dlopen(pContext, libsndioNames[i]); - if (pContext->sndio.sndioSO != NULL) { - break; - } - } - - if (pContext->sndio.sndioSO == NULL) { - return MA_NO_BACKEND; - } - - pContext->sndio.sio_open = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_open"); - pContext->sndio.sio_close = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_close"); - pContext->sndio.sio_setpar = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_setpar"); - pContext->sndio.sio_getpar = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_getpar"); - pContext->sndio.sio_getcap = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_getcap"); - pContext->sndio.sio_write = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_write"); - pContext->sndio.sio_read = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_read"); - pContext->sndio.sio_start = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_start"); - pContext->sndio.sio_stop = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_stop"); - pContext->sndio.sio_initpar = (ma_proc)ma_dlsym(pContext, pContext->sndio.sndioSO, "sio_initpar"); -#else - pContext->sndio.sio_open = sio_open; - pContext->sndio.sio_close = sio_close; - pContext->sndio.sio_setpar = sio_setpar; - pContext->sndio.sio_getpar = sio_getpar; - pContext->sndio.sio_getcap = sio_getcap; - pContext->sndio.sio_write = sio_write; - pContext->sndio.sio_read = sio_read; - pContext->sndio.sio_start = sio_start; - pContext->sndio.sio_stop = sio_stop; - pContext->sndio.sio_initpar = sio_initpar; -#endif - - pCallbacks->onContextInit = ma_context_init__sndio; - pCallbacks->onContextUninit = ma_context_uninit__sndio; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__sndio; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__sndio; - pCallbacks->onDeviceInit = ma_device_init__sndio; - pCallbacks->onDeviceUninit = ma_device_uninit__sndio; - pCallbacks->onDeviceStart = ma_device_start__sndio; - pCallbacks->onDeviceStop = ma_device_stop__sndio; - pCallbacks->onDeviceRead = ma_device_read__sndio; - pCallbacks->onDeviceWrite = ma_device_write__sndio; - pCallbacks->onDeviceDataLoop = NULL; - - (void)pConfig; - return MA_SUCCESS; -} -#endif /* sndio */ - - - -/****************************************************************************** - -audio(4) Backend - -******************************************************************************/ -#ifdef MA_HAS_AUDIO4 -#include -#include -#include -#include -#include -#include -#include - -#if defined(__OpenBSD__) - #include - #if defined(OpenBSD) && OpenBSD >= 201709 - #define MA_AUDIO4_USE_NEW_API - #endif -#endif - -static void ma_construct_device_id__audio4(char* id, size_t idSize, const char* base, int deviceIndex) -{ - size_t baseLen; - - MA_ASSERT(id != NULL); - MA_ASSERT(idSize > 0); - MA_ASSERT(deviceIndex >= 0); - - baseLen = strlen(base); - MA_ASSERT(idSize > baseLen); - - ma_strcpy_s(id, idSize, base); - ma_itoa_s(deviceIndex, id+baseLen, idSize-baseLen, 10); -} - -static ma_result ma_extract_device_index_from_id__audio4(const char* id, const char* base, int* pIndexOut) -{ - size_t idLen; - size_t baseLen; - const char* deviceIndexStr; - - MA_ASSERT(id != NULL); - MA_ASSERT(base != NULL); - MA_ASSERT(pIndexOut != NULL); - - idLen = strlen(id); - baseLen = strlen(base); - if (idLen <= baseLen) { - return MA_ERROR; /* Doesn't look like the id starts with the base. */ - } - - if (strncmp(id, base, baseLen) != 0) { - return MA_ERROR; /* ID does not begin with base. */ - } - - deviceIndexStr = id + baseLen; - if (deviceIndexStr[0] == '\0') { - return MA_ERROR; /* No index specified in the ID. */ - } - - if (pIndexOut) { - *pIndexOut = atoi(deviceIndexStr); - } - - return MA_SUCCESS; -} - - -#if !defined(MA_AUDIO4_USE_NEW_API) /* Old API */ -static ma_format ma_format_from_encoding__audio4(unsigned int encoding, unsigned int precision) -{ - if (precision == 8 && (encoding == AUDIO_ENCODING_ULINEAR || encoding == AUDIO_ENCODING_ULINEAR || encoding == AUDIO_ENCODING_ULINEAR_LE || encoding == AUDIO_ENCODING_ULINEAR_BE)) { - return ma_format_u8; - } else { - if (ma_is_little_endian() && encoding == AUDIO_ENCODING_SLINEAR_LE) { - if (precision == 16) { - return ma_format_s16; - } else if (precision == 24) { - return ma_format_s24; - } else if (precision == 32) { - return ma_format_s32; - } - } else if (ma_is_big_endian() && encoding == AUDIO_ENCODING_SLINEAR_BE) { - if (precision == 16) { - return ma_format_s16; - } else if (precision == 24) { - return ma_format_s24; - } else if (precision == 32) { - return ma_format_s32; - } - } - } - - return ma_format_unknown; /* Encoding not supported. */ -} - -static void ma_encoding_from_format__audio4(ma_format format, unsigned int* pEncoding, unsigned int* pPrecision) -{ - MA_ASSERT(pEncoding != NULL); - MA_ASSERT(pPrecision != NULL); - - switch (format) - { - case ma_format_u8: - { - *pEncoding = AUDIO_ENCODING_ULINEAR; - *pPrecision = 8; - } break; - - case ma_format_s24: - { - *pEncoding = (ma_is_little_endian()) ? AUDIO_ENCODING_SLINEAR_LE : AUDIO_ENCODING_SLINEAR_BE; - *pPrecision = 24; - } break; - - case ma_format_s32: - { - *pEncoding = (ma_is_little_endian()) ? AUDIO_ENCODING_SLINEAR_LE : AUDIO_ENCODING_SLINEAR_BE; - *pPrecision = 32; - } break; - - case ma_format_s16: - case ma_format_f32: - case ma_format_unknown: - default: - { - *pEncoding = (ma_is_little_endian()) ? AUDIO_ENCODING_SLINEAR_LE : AUDIO_ENCODING_SLINEAR_BE; - *pPrecision = 16; - } break; - } -} - -static ma_format ma_format_from_prinfo__audio4(struct audio_prinfo* prinfo) -{ - return ma_format_from_encoding__audio4(prinfo->encoding, prinfo->precision); -} - -static ma_format ma_best_format_from_fd__audio4(int fd, ma_format preferredFormat) -{ - audio_encoding_t encoding; - ma_uint32 iFormat; - int counter = 0; - - /* First check to see if the preferred format is supported. */ - if (preferredFormat != ma_format_unknown) { - counter = 0; - for (;;) { - MA_ZERO_OBJECT(&encoding); - encoding.index = counter; - if (ioctl(fd, AUDIO_GETENC, &encoding) < 0) { - break; - } - - if (preferredFormat == ma_format_from_encoding__audio4(encoding.encoding, encoding.precision)) { - return preferredFormat; /* Found the preferred format. */ - } - - /* Getting here means this encoding does not match our preferred format so we need to more on to the next encoding. */ - counter += 1; - } - } - - /* Getting here means our preferred format is not supported, so fall back to our standard priorities. */ - for (iFormat = 0; iFormat < ma_countof(g_maFormatPriorities); iFormat += 1) { - ma_format format = g_maFormatPriorities[iFormat]; - - counter = 0; - for (;;) { - MA_ZERO_OBJECT(&encoding); - encoding.index = counter; - if (ioctl(fd, AUDIO_GETENC, &encoding) < 0) { - break; - } - - if (format == ma_format_from_encoding__audio4(encoding.encoding, encoding.precision)) { - return format; /* Found a workable format. */ - } - - /* Getting here means this encoding does not match our preferred format so we need to more on to the next encoding. */ - counter += 1; - } - } - - /* Getting here means not appropriate format was found. */ - return ma_format_unknown; -} -#else -static ma_format ma_format_from_swpar__audio4(struct audio_swpar* par) -{ - if (par->bits == 8 && par->bps == 1 && par->sig == 0) { - return ma_format_u8; - } - if (par->bits == 16 && par->bps == 2 && par->sig == 1 && par->le == ma_is_little_endian()) { - return ma_format_s16; - } - if (par->bits == 24 && par->bps == 3 && par->sig == 1 && par->le == ma_is_little_endian()) { - return ma_format_s24; - } - if (par->bits == 32 && par->bps == 4 && par->sig == 1 && par->le == ma_is_little_endian()) { - return ma_format_f32; - } - - /* Format not supported. */ - return ma_format_unknown; -} -#endif - -static ma_result ma_context_get_device_info_from_fd__audio4(ma_context* pContext, ma_device_type deviceType, int fd, ma_device_info* pDeviceInfo) -{ - audio_device_t fdDevice; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(fd >= 0); - MA_ASSERT(pDeviceInfo != NULL); - - (void)pContext; - (void)deviceType; - - if (ioctl(fd, AUDIO_GETDEV, &fdDevice) < 0) { - return MA_ERROR; /* Failed to retrieve device info. */ - } - - /* Name. */ - ma_strcpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), fdDevice.name); - - #if !defined(MA_AUDIO4_USE_NEW_API) - { - audio_info_t fdInfo; - int counter = 0; - ma_uint32 channels; - ma_uint32 sampleRate; - - if (ioctl(fd, AUDIO_GETINFO, &fdInfo) < 0) { - return MA_ERROR; - } - - if (deviceType == ma_device_type_playback) { - channels = fdInfo.play.channels; - sampleRate = fdInfo.play.sample_rate; - } else { - channels = fdInfo.record.channels; - sampleRate = fdInfo.record.sample_rate; - } - - /* Supported formats. We get this by looking at the encodings. */ - pDeviceInfo->nativeDataFormatCount = 0; - for (;;) { - audio_encoding_t encoding; - ma_format format; - - MA_ZERO_OBJECT(&encoding); - encoding.index = counter; - if (ioctl(fd, AUDIO_GETENC, &encoding) < 0) { - break; - } - - format = ma_format_from_encoding__audio4(encoding.encoding, encoding.precision); - if (format != ma_format_unknown) { - ma_device_info_add_native_data_format(pDeviceInfo, format, channels, sampleRate, 0); - } - - counter += 1; - } - } - #else - { - struct audio_swpar fdPar; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - - if (ioctl(fd, AUDIO_GETPAR, &fdPar) < 0) { - return MA_ERROR; - } - - format = ma_format_from_swpar__audio4(&fdPar); - if (format == ma_format_unknown) { - return MA_FORMAT_NOT_SUPPORTED; - } - - if (deviceType == ma_device_type_playback) { - channels = fdPar.pchan; - } else { - channels = fdPar.rchan; - } - - sampleRate = fdPar.rate; - - pDeviceInfo->nativeDataFormatCount = 0; - ma_device_info_add_native_data_format(pDeviceInfo, format, channels, sampleRate, 0); - } - #endif - - return MA_SUCCESS; -} - -static ma_result ma_context_enumerate_devices__audio4(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - const int maxDevices = 64; - char devpath[256]; - int iDevice; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* - Every device will be named "/dev/audioN", with a "/dev/audioctlN" equivalent. We use the "/dev/audioctlN" - version here since we can open it even when another process has control of the "/dev/audioN" device. - */ - for (iDevice = 0; iDevice < maxDevices; ++iDevice) { - struct stat st; - int fd; - ma_bool32 isTerminating = MA_FALSE; - - ma_strcpy_s(devpath, sizeof(devpath), "/dev/audioctl"); - ma_itoa_s(iDevice, devpath+strlen(devpath), sizeof(devpath)-strlen(devpath), 10); - - if (stat(devpath, &st) < 0) { - break; - } - - /* The device exists, but we need to check if it's usable as playback and/or capture. */ - - /* Playback. */ - if (!isTerminating) { - fd = open(devpath, O_RDONLY, 0); - if (fd >= 0) { - /* Supports playback. */ - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_construct_device_id__audio4(deviceInfo.id.audio4, sizeof(deviceInfo.id.audio4), "/dev/audio", iDevice); - if (ma_context_get_device_info_from_fd__audio4(pContext, ma_device_type_playback, fd, &deviceInfo) == MA_SUCCESS) { - isTerminating = !callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - - close(fd); - } - } - - /* Capture. */ - if (!isTerminating) { - fd = open(devpath, O_WRONLY, 0); - if (fd >= 0) { - /* Supports capture. */ - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_construct_device_id__audio4(deviceInfo.id.audio4, sizeof(deviceInfo.id.audio4), "/dev/audio", iDevice); - if (ma_context_get_device_info_from_fd__audio4(pContext, ma_device_type_capture, fd, &deviceInfo) == MA_SUCCESS) { - isTerminating = !callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - - close(fd); - } - } - - if (isTerminating) { - break; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__audio4(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - int fd = -1; - int deviceIndex = -1; - char ctlid[256]; - ma_result result; - - MA_ASSERT(pContext != NULL); - - /* - We need to open the "/dev/audioctlN" device to get the info. To do this we need to extract the number - from the device ID which will be in "/dev/audioN" format. - */ - if (pDeviceID == NULL) { - /* Default device. */ - ma_strcpy_s(ctlid, sizeof(ctlid), "/dev/audioctl"); - } else { - /* Specific device. We need to convert from "/dev/audioN" to "/dev/audioctlN". */ - result = ma_extract_device_index_from_id__audio4(pDeviceID->audio4, "/dev/audio", &deviceIndex); - if (result != MA_SUCCESS) { - return result; - } - - ma_construct_device_id__audio4(ctlid, sizeof(ctlid), "/dev/audioctl", deviceIndex); - } - - fd = open(ctlid, (deviceType == ma_device_type_playback) ? O_WRONLY : O_RDONLY, 0); - if (fd == -1) { - return MA_NO_DEVICE; - } - - if (deviceIndex == -1) { - ma_strcpy_s(pDeviceInfo->id.audio4, sizeof(pDeviceInfo->id.audio4), "/dev/audio"); - } else { - ma_construct_device_id__audio4(pDeviceInfo->id.audio4, sizeof(pDeviceInfo->id.audio4), "/dev/audio", deviceIndex); - } - - result = ma_context_get_device_info_from_fd__audio4(pContext, deviceType, fd, pDeviceInfo); - - close(fd); - return result; -} - -static ma_result ma_device_uninit__audio4(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - close(pDevice->audio4.fdCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - close(pDevice->audio4.fdPlayback); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_init_fd__audio4(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptor, ma_device_type deviceType) -{ - const char* pDefaultDeviceNames[] = { - "/dev/audio", - "/dev/audio0" - }; - const char* pDefaultDeviceCtlNames[] = { - "/dev/audioctl", - "/dev/audioctl0" - }; - int fd; - int fdFlags = 0; - size_t iDefaultDevice = (size_t)-1; - ma_format internalFormat; - ma_uint32 internalChannels; - ma_uint32 internalSampleRate; - ma_uint32 internalPeriodSizeInFrames; - ma_uint32 internalPeriods; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(deviceType != ma_device_type_duplex); - MA_ASSERT(pDevice != NULL); - - /* The first thing to do is open the file. */ - if (deviceType == ma_device_type_capture) { - fdFlags = O_RDONLY; - } else { - fdFlags = O_WRONLY; - } - /*fdFlags |= O_NONBLOCK;*/ - - /* Find the index of the default device as a start. We'll use this index later. Set it to (size_t)-1 otherwise. */ - if (pDescriptor->pDeviceID == NULL) { - /* Default device. */ - for (iDefaultDevice = 0; iDefaultDevice < ma_countof(pDefaultDeviceNames); ++iDefaultDevice) { - fd = open(pDefaultDeviceNames[iDefaultDevice], fdFlags, 0); - if (fd != -1) { - break; - } - } - } else { - /* Specific device. */ - fd = open(pDescriptor->pDeviceID->audio4, fdFlags, 0); - - for (iDefaultDevice = 0; iDefaultDevice < ma_countof(pDefaultDeviceNames); iDefaultDevice += 1) { - if (ma_strcmp(pDefaultDeviceNames[iDefaultDevice], pDescriptor->pDeviceID->audio4) == 0) { - break; - } - } - - if (iDefaultDevice == ma_countof(pDefaultDeviceNames)) { - iDefaultDevice = (size_t)-1; - } - } - - if (fd == -1) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to open device."); - return ma_result_from_errno(errno); - } - - #if !defined(MA_AUDIO4_USE_NEW_API) /* Old API */ - { - audio_info_t fdInfo; - int fdInfoResult = -1; - - /* - The documentation is a little bit unclear to me as to how it handles formats. It says the - following: - - Regardless of formats supported by underlying driver, the audio driver accepts the - following formats. - - By then the next sentence says this: - - `encoding` and `precision` are one of the values obtained by AUDIO_GETENC. - - It sounds like a direct contradiction to me. I'm going to play this safe any only use the - best sample format returned by AUDIO_GETENC. If the requested format is supported we'll - use that, but otherwise we'll just use our standard format priorities to pick an - appropriate one. - */ - AUDIO_INITINFO(&fdInfo); - - /* - Get the default format from the audioctl file if we're asking for a default device. If we - retrieve it from /dev/audio it'll default to mono 8000Hz. - */ - if (iDefaultDevice != (size_t)-1) { - /* We're using a default device. Get the info from the /dev/audioctl file instead of /dev/audio. */ - int fdctl = open(pDefaultDeviceCtlNames[iDefaultDevice], fdFlags, 0); - if (fdctl != -1) { - fdInfoResult = ioctl(fdctl, AUDIO_GETINFO, &fdInfo); - close(fdctl); - } - } - - if (fdInfoResult == -1) { - /* We still don't have the default device info so just retrieve it from the main audio device. */ - if (ioctl(fd, AUDIO_GETINFO, &fdInfo) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] AUDIO_GETINFO failed."); - return ma_result_from_errno(errno); - } - } - - /* We get the driver to do as much of the data conversion as possible. */ - if (deviceType == ma_device_type_capture) { - fdInfo.mode = AUMODE_RECORD; - ma_encoding_from_format__audio4(ma_best_format_from_fd__audio4(fd, pDescriptor->format), &fdInfo.record.encoding, &fdInfo.record.precision); - - if (pDescriptor->channels != 0) { - fdInfo.record.channels = ma_clamp(pDescriptor->channels, 1, 12); /* From the documentation: `channels` ranges from 1 to 12. */ - } - - if (pDescriptor->sampleRate != 0) { - fdInfo.record.sample_rate = ma_clamp(pDescriptor->sampleRate, 1000, 192000); /* From the documentation: `frequency` ranges from 1000Hz to 192000Hz. (They mean `sample_rate` instead of `frequency`.) */ - } - } else { - fdInfo.mode = AUMODE_PLAY; - ma_encoding_from_format__audio4(ma_best_format_from_fd__audio4(fd, pDescriptor->format), &fdInfo.play.encoding, &fdInfo.play.precision); - - if (pDescriptor->channels != 0) { - fdInfo.play.channels = ma_clamp(pDescriptor->channels, 1, 12); /* From the documentation: `channels` ranges from 1 to 12. */ - } - - if (pDescriptor->sampleRate != 0) { - fdInfo.play.sample_rate = ma_clamp(pDescriptor->sampleRate, 1000, 192000); /* From the documentation: `frequency` ranges from 1000Hz to 192000Hz. (They mean `sample_rate` instead of `frequency`.) */ - } - } - - if (ioctl(fd, AUDIO_SETINFO, &fdInfo) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to set device format. AUDIO_SETINFO failed."); - return ma_result_from_errno(errno); - } - - if (ioctl(fd, AUDIO_GETINFO, &fdInfo) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] AUDIO_GETINFO failed."); - return ma_result_from_errno(errno); - } - - if (deviceType == ma_device_type_capture) { - internalFormat = ma_format_from_prinfo__audio4(&fdInfo.record); - internalChannels = fdInfo.record.channels; - internalSampleRate = fdInfo.record.sample_rate; - } else { - internalFormat = ma_format_from_prinfo__audio4(&fdInfo.play); - internalChannels = fdInfo.play.channels; - internalSampleRate = fdInfo.play.sample_rate; - } - - if (internalFormat == ma_format_unknown) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] The device's internal device format is not supported by miniaudio. The device is unusable."); - return MA_FORMAT_NOT_SUPPORTED; - } - - /* Buffer. */ - { - ma_uint32 internalPeriodSizeInBytes; - - internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, internalSampleRate, pConfig->performanceProfile); - - internalPeriodSizeInBytes = internalPeriodSizeInFrames * ma_get_bytes_per_frame(internalFormat, internalChannels); - if (internalPeriodSizeInBytes < 16) { - internalPeriodSizeInBytes = 16; - } - - internalPeriods = pDescriptor->periodCount; - if (internalPeriods < 2) { - internalPeriods = 2; - } - - /* What miniaudio calls a period, audio4 calls a block. */ - AUDIO_INITINFO(&fdInfo); - fdInfo.hiwat = internalPeriods; - fdInfo.lowat = internalPeriods-1; - fdInfo.blocksize = internalPeriodSizeInBytes; - if (ioctl(fd, AUDIO_SETINFO, &fdInfo) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to set internal buffer size. AUDIO_SETINFO failed."); - return ma_result_from_errno(errno); - } - - internalPeriods = fdInfo.hiwat; - internalPeriodSizeInFrames = fdInfo.blocksize / ma_get_bytes_per_frame(internalFormat, internalChannels); - } - } - #else - { - struct audio_swpar fdPar; - - /* We need to retrieve the format of the device so we can know the channel count and sample rate. Then we can calculate the buffer size. */ - if (ioctl(fd, AUDIO_GETPAR, &fdPar) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to retrieve initial device parameters."); - return ma_result_from_errno(errno); - } - - internalFormat = ma_format_from_swpar__audio4(&fdPar); - internalChannels = (deviceType == ma_device_type_capture) ? fdPar.rchan : fdPar.pchan; - internalSampleRate = fdPar.rate; - - if (internalFormat == ma_format_unknown) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] The device's internal device format is not supported by miniaudio. The device is unusable."); - return MA_FORMAT_NOT_SUPPORTED; - } - - /* Buffer. */ - { - ma_uint32 internalPeriodSizeInBytes; - - internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, internalSampleRate, pConfig->performanceProfile); - - /* What miniaudio calls a period, audio4 calls a block. */ - internalPeriodSizeInBytes = internalPeriodSizeInFrames * ma_get_bytes_per_frame(internalFormat, internalChannels); - if (internalPeriodSizeInBytes < 16) { - internalPeriodSizeInBytes = 16; - } - - fdPar.nblks = pDescriptor->periodCount; - fdPar.round = internalPeriodSizeInBytes; - - if (ioctl(fd, AUDIO_SETPAR, &fdPar) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to set device parameters."); - return ma_result_from_errno(errno); - } - - if (ioctl(fd, AUDIO_GETPAR, &fdPar) < 0) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to retrieve actual device parameters."); - return ma_result_from_errno(errno); - } - } - - internalFormat = ma_format_from_swpar__audio4(&fdPar); - internalChannels = (deviceType == ma_device_type_capture) ? fdPar.rchan : fdPar.pchan; - internalSampleRate = fdPar.rate; - internalPeriods = fdPar.nblks; - internalPeriodSizeInFrames = fdPar.round / ma_get_bytes_per_frame(internalFormat, internalChannels); - } - #endif - - if (internalFormat == ma_format_unknown) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] The device's internal device format is not supported by miniaudio. The device is unusable."); - return MA_FORMAT_NOT_SUPPORTED; - } - - if (deviceType == ma_device_type_capture) { - pDevice->audio4.fdCapture = fd; - } else { - pDevice->audio4.fdPlayback = fd; - } - - pDescriptor->format = internalFormat; - pDescriptor->channels = internalChannels; - pDescriptor->sampleRate = internalSampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_sound4, pDescriptor->channelMap, ma_countof(pDescriptor->channelMap), internalChannels); - pDescriptor->periodSizeInFrames = internalPeriodSizeInFrames; - pDescriptor->periodCount = internalPeriods; - - return MA_SUCCESS; -} - -static ma_result ma_device_init__audio4(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - MA_ASSERT(pDevice != NULL); - - MA_ZERO_OBJECT(&pDevice->audio4); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - pDevice->audio4.fdCapture = -1; - pDevice->audio4.fdPlayback = -1; - - /* - The version of the operating system dictates whether or not the device is exclusive or shared. NetBSD - introduced in-kernel mixing which means it's shared. All other BSD flavours are exclusive as far as - I'm aware. - */ -#if defined(__NetBSD_Version__) && __NetBSD_Version__ >= 800000000 - /* NetBSD 8.0+ */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->shareMode == ma_share_mode_exclusive)) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } -#else - /* All other flavors. */ -#endif - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_fd__audio4(pDevice, pConfig, pDescriptorCapture, ma_device_type_capture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_fd__audio4(pDevice, pConfig, pDescriptorPlayback, ma_device_type_playback); - if (result != MA_SUCCESS) { - if (pConfig->deviceType == ma_device_type_duplex) { - close(pDevice->audio4.fdCapture); - } - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__audio4(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - if (pDevice->audio4.fdCapture == -1) { - return MA_INVALID_ARGS; - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - if (pDevice->audio4.fdPlayback == -1) { - return MA_INVALID_ARGS; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop_fd__audio4(ma_device* pDevice, int fd) -{ - if (fd == -1) { - return MA_INVALID_ARGS; - } - -#if !defined(MA_AUDIO4_USE_NEW_API) - if (ioctl(fd, AUDIO_FLUSH, 0) < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to stop device. AUDIO_FLUSH failed."); - return ma_result_from_errno(errno); - } -#else - if (ioctl(fd, AUDIO_STOP, 0) < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to stop device. AUDIO_STOP failed."); - return ma_result_from_errno(errno); - } -#endif - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__audio4(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_result result; - - result = ma_device_stop_fd__audio4(pDevice, pDevice->audio4.fdCapture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_result result; - - /* Drain the device first. If this fails we'll just need to flush without draining. Unfortunately draining isn't available on newer version of OpenBSD. */ - #if !defined(MA_AUDIO4_USE_NEW_API) - ioctl(pDevice->audio4.fdPlayback, AUDIO_DRAIN, 0); - #endif - - /* Here is where the device is stopped immediately. */ - result = ma_device_stop_fd__audio4(pDevice, pDevice->audio4.fdPlayback); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_write__audio4(ma_device* pDevice, const void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - int result; - - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - result = write(pDevice->audio4.fdPlayback, pPCMFrames, frameCount * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - if (result < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to write data to the device."); - return ma_result_from_errno(errno); - } - - if (pFramesWritten != NULL) { - *pFramesWritten = (ma_uint32)result / ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_read__audio4(ma_device* pDevice, void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - int result; - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - result = read(pDevice->audio4.fdCapture, pPCMFrames, frameCount * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels)); - if (result < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[audio4] Failed to read data from the device."); - return ma_result_from_errno(errno); - } - - if (pFramesRead != NULL) { - *pFramesRead = (ma_uint32)result / ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - } - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__audio4(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_audio4); - - (void)pContext; - return MA_SUCCESS; -} - -static ma_result ma_context_init__audio4(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - MA_ASSERT(pContext != NULL); - - (void)pConfig; - - pCallbacks->onContextInit = ma_context_init__audio4; - pCallbacks->onContextUninit = ma_context_uninit__audio4; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__audio4; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__audio4; - pCallbacks->onDeviceInit = ma_device_init__audio4; - pCallbacks->onDeviceUninit = ma_device_uninit__audio4; - pCallbacks->onDeviceStart = ma_device_start__audio4; - pCallbacks->onDeviceStop = ma_device_stop__audio4; - pCallbacks->onDeviceRead = ma_device_read__audio4; - pCallbacks->onDeviceWrite = ma_device_write__audio4; - pCallbacks->onDeviceDataLoop = NULL; - - return MA_SUCCESS; -} -#endif /* audio4 */ - - -/****************************************************************************** - -OSS Backend - -******************************************************************************/ -#ifdef MA_HAS_OSS -#include -#include -#include -#include - -#ifndef SNDCTL_DSP_HALT -#define SNDCTL_DSP_HALT SNDCTL_DSP_RESET -#endif - -#define MA_OSS_DEFAULT_DEVICE_NAME "/dev/dsp" - -static int ma_open_temp_device__oss() -{ - /* The OSS sample code uses "/dev/mixer" as the device for getting system properties so I'm going to do the same. */ - int fd = open("/dev/mixer", O_RDONLY, 0); - if (fd >= 0) { - return fd; - } - - return -1; -} - -static ma_result ma_context_open_device__oss(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_share_mode shareMode, int* pfd) -{ - const char* deviceName; - int flags; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pfd != NULL); - (void)pContext; - - *pfd = -1; - - /* This function should only be called for playback or capture, not duplex. */ - if (deviceType == ma_device_type_duplex) { - return MA_INVALID_ARGS; - } - - deviceName = MA_OSS_DEFAULT_DEVICE_NAME; - if (pDeviceID != NULL) { - deviceName = pDeviceID->oss; - } - - flags = (deviceType == ma_device_type_playback) ? O_WRONLY : O_RDONLY; - if (shareMode == ma_share_mode_exclusive) { - flags |= O_EXCL; - } - - *pfd = open(deviceName, flags, 0); - if (*pfd == -1) { - return ma_result_from_errno(errno); - } - - return MA_SUCCESS; -} - -static ma_result ma_context_enumerate_devices__oss(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - int fd; - oss_sysinfo si; - int result; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - fd = ma_open_temp_device__oss(); - if (fd == -1) { - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[OSS] Failed to open a temporary device for retrieving system information used for device enumeration."); - return MA_NO_BACKEND; - } - - result = ioctl(fd, SNDCTL_SYSINFO, &si); - if (result != -1) { - int iAudioDevice; - for (iAudioDevice = 0; iAudioDevice < si.numaudios; ++iAudioDevice) { - oss_audioinfo ai; - ai.dev = iAudioDevice; - result = ioctl(fd, SNDCTL_AUDIOINFO, &ai); - if (result != -1) { - if (ai.devnode[0] != '\0') { /* <-- Can be blank, according to documentation. */ - ma_device_info deviceInfo; - ma_bool32 isTerminating = MA_FALSE; - - MA_ZERO_OBJECT(&deviceInfo); - - /* ID */ - ma_strncpy_s(deviceInfo.id.oss, sizeof(deviceInfo.id.oss), ai.devnode, (size_t)-1); - - /* - The human readable device name should be in the "ai.handle" variable, but it can - sometimes be empty in which case we just fall back to "ai.name" which is less user - friendly, but usually has a value. - */ - if (ai.handle[0] != '\0') { - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), ai.handle, (size_t)-1); - } else { - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), ai.name, (size_t)-1); - } - - /* The device can be both playback and capture. */ - if (!isTerminating && (ai.caps & PCM_CAP_OUTPUT) != 0) { - isTerminating = !callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - if (!isTerminating && (ai.caps & PCM_CAP_INPUT) != 0) { - isTerminating = !callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - - if (isTerminating) { - break; - } - } - } - } - } else { - close(fd); - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[OSS] Failed to retrieve system information for device enumeration."); - return MA_NO_BACKEND; - } - - close(fd); - return MA_SUCCESS; -} - -static void ma_context_add_native_data_format__oss(ma_context* pContext, oss_audioinfo* pAudioInfo, ma_format format, ma_device_info* pDeviceInfo) -{ - unsigned int minChannels; - unsigned int maxChannels; - unsigned int iRate; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pAudioInfo != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - /* If we support all channels we just report 0. */ - minChannels = ma_clamp(pAudioInfo->min_channels, MA_MIN_CHANNELS, MA_MAX_CHANNELS); - maxChannels = ma_clamp(pAudioInfo->max_channels, MA_MIN_CHANNELS, MA_MAX_CHANNELS); - - /* - OSS has this annoying thing where sample rates can be reported in two ways. We prefer explicitness, - which OSS has in the form of nrates/rates, however there are times where nrates can be 0, in which - case we'll need to use min_rate and max_rate and report only standard rates. - */ - if (pAudioInfo->nrates > 0) { - for (iRate = 0; iRate < pAudioInfo->nrates; iRate += 1) { - unsigned int rate = pAudioInfo->rates[iRate]; - - if (minChannels == MA_MIN_CHANNELS && maxChannels == MA_MAX_CHANNELS) { - ma_device_info_add_native_data_format(pDeviceInfo, format, 0, rate, 0); /* Set the channel count to 0 to indicate that all channel counts are supported. */ - } else { - unsigned int iChannel; - for (iChannel = minChannels; iChannel <= maxChannels; iChannel += 1) { - ma_device_info_add_native_data_format(pDeviceInfo, format, iChannel, rate, 0); - } - } - } - } else { - for (iRate = 0; iRate < ma_countof(g_maStandardSampleRatePriorities); iRate += 1) { - ma_uint32 standardRate = g_maStandardSampleRatePriorities[iRate]; - - if (standardRate >= (ma_uint32)pAudioInfo->min_rate && standardRate <= (ma_uint32)pAudioInfo->max_rate) { - if (minChannels == MA_MIN_CHANNELS && maxChannels == MA_MAX_CHANNELS) { - ma_device_info_add_native_data_format(pDeviceInfo, format, 0, standardRate, 0); /* Set the channel count to 0 to indicate that all channel counts are supported. */ - } else { - unsigned int iChannel; - for (iChannel = minChannels; iChannel <= maxChannels; iChannel += 1) { - ma_device_info_add_native_data_format(pDeviceInfo, format, iChannel, standardRate, 0); - } - } - } - } - } -} - -static ma_result ma_context_get_device_info__oss(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_bool32 foundDevice; - int fdTemp; - oss_sysinfo si; - int result; - - MA_ASSERT(pContext != NULL); - - /* Handle the default device a little differently. */ - if (pDeviceID == NULL) { - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - return MA_SUCCESS; - } - - - /* If we get here it means we are _not_ using the default device. */ - foundDevice = MA_FALSE; - - fdTemp = ma_open_temp_device__oss(); - if (fdTemp == -1) { - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[OSS] Failed to open a temporary device for retrieving system information used for device enumeration."); - return MA_NO_BACKEND; - } - - result = ioctl(fdTemp, SNDCTL_SYSINFO, &si); - if (result != -1) { - int iAudioDevice; - for (iAudioDevice = 0; iAudioDevice < si.numaudios; ++iAudioDevice) { - oss_audioinfo ai; - ai.dev = iAudioDevice; - result = ioctl(fdTemp, SNDCTL_AUDIOINFO, &ai); - if (result != -1) { - if (ma_strcmp(ai.devnode, pDeviceID->oss) == 0) { - /* It has the same name, so now just confirm the type. */ - if ((deviceType == ma_device_type_playback && ((ai.caps & PCM_CAP_OUTPUT) != 0)) || - (deviceType == ma_device_type_capture && ((ai.caps & PCM_CAP_INPUT) != 0))) { - unsigned int formatMask; - - /* ID */ - ma_strncpy_s(pDeviceInfo->id.oss, sizeof(pDeviceInfo->id.oss), ai.devnode, (size_t)-1); - - /* - The human readable device name should be in the "ai.handle" variable, but it can - sometimes be empty in which case we just fall back to "ai.name" which is less user - friendly, but usually has a value. - */ - if (ai.handle[0] != '\0') { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), ai.handle, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), ai.name, (size_t)-1); - } - - - pDeviceInfo->nativeDataFormatCount = 0; - - if (deviceType == ma_device_type_playback) { - formatMask = ai.oformats; - } else { - formatMask = ai.iformats; - } - - if (((formatMask & AFMT_S16_LE) != 0 && ma_is_little_endian()) || (AFMT_S16_BE && ma_is_big_endian())) { - ma_context_add_native_data_format__oss(pContext, &ai, ma_format_s16, pDeviceInfo); - } - if (((formatMask & AFMT_S32_LE) != 0 && ma_is_little_endian()) || (AFMT_S32_BE && ma_is_big_endian())) { - ma_context_add_native_data_format__oss(pContext, &ai, ma_format_s32, pDeviceInfo); - } - if ((formatMask & AFMT_U8) != 0) { - ma_context_add_native_data_format__oss(pContext, &ai, ma_format_u8, pDeviceInfo); - } - - foundDevice = MA_TRUE; - break; - } - } - } - } - } else { - close(fdTemp); - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[OSS] Failed to retrieve system information for device enumeration."); - return MA_NO_BACKEND; - } - - - close(fdTemp); - - if (!foundDevice) { - return MA_NO_DEVICE; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_uninit__oss(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - close(pDevice->oss.fdCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - close(pDevice->oss.fdPlayback); - } - - return MA_SUCCESS; -} - -static int ma_format_to_oss(ma_format format) -{ - int ossFormat = AFMT_U8; - switch (format) { - case ma_format_s16: ossFormat = (ma_is_little_endian()) ? AFMT_S16_LE : AFMT_S16_BE; break; - case ma_format_s24: ossFormat = (ma_is_little_endian()) ? AFMT_S32_LE : AFMT_S32_BE; break; - case ma_format_s32: ossFormat = (ma_is_little_endian()) ? AFMT_S32_LE : AFMT_S32_BE; break; - case ma_format_f32: ossFormat = (ma_is_little_endian()) ? AFMT_S16_LE : AFMT_S16_BE; break; - case ma_format_u8: - default: ossFormat = AFMT_U8; break; - } - - return ossFormat; -} - -static ma_format ma_format_from_oss(int ossFormat) -{ - if (ossFormat == AFMT_U8) { - return ma_format_u8; - } else { - if (ma_is_little_endian()) { - switch (ossFormat) { - case AFMT_S16_LE: return ma_format_s16; - case AFMT_S32_LE: return ma_format_s32; - default: return ma_format_unknown; - } - } else { - switch (ossFormat) { - case AFMT_S16_BE: return ma_format_s16; - case AFMT_S32_BE: return ma_format_s32; - default: return ma_format_unknown; - } - } - } - - return ma_format_unknown; -} - -static ma_result ma_device_init_fd__oss(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptor, ma_device_type deviceType) -{ - ma_result result; - int ossResult; - int fd; - const ma_device_id* pDeviceID = NULL; - ma_share_mode shareMode; - int ossFormat; - int ossChannels; - int ossSampleRate; - int ossFragment; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pConfig != NULL); - MA_ASSERT(deviceType != ma_device_type_duplex); - - pDeviceID = pDescriptor->pDeviceID; - shareMode = pDescriptor->shareMode; - ossFormat = ma_format_to_oss((pDescriptor->format != ma_format_unknown) ? pDescriptor->format : ma_format_s16); /* Use s16 by default because OSS doesn't like floating point. */ - ossChannels = (int)(pDescriptor->channels > 0) ? pDescriptor->channels : MA_DEFAULT_CHANNELS; - ossSampleRate = (int)(pDescriptor->sampleRate > 0) ? pDescriptor->sampleRate : MA_DEFAULT_SAMPLE_RATE; - - result = ma_context_open_device__oss(pDevice->pContext, deviceType, pDeviceID, shareMode, &fd); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to open device."); - return result; - } - - /* - The OSS documantation is very clear about the order we should be initializing the device's properties: - 1) Format - 2) Channels - 3) Sample rate. - */ - - /* Format. */ - ossResult = ioctl(fd, SNDCTL_DSP_SETFMT, &ossFormat); - if (ossResult == -1) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to set format."); - return ma_result_from_errno(errno); - } - - /* Channels. */ - ossResult = ioctl(fd, SNDCTL_DSP_CHANNELS, &ossChannels); - if (ossResult == -1) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to set channel count."); - return ma_result_from_errno(errno); - } - - /* Sample Rate. */ - ossResult = ioctl(fd, SNDCTL_DSP_SPEED, &ossSampleRate); - if (ossResult == -1) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to set sample rate."); - return ma_result_from_errno(errno); - } - - /* - Buffer. - - The documentation says that the fragment settings should be set as soon as possible, but I'm not sure if - it should be done before or after format/channels/rate. - - OSS wants the fragment size in bytes and a power of 2. When setting, we specify the power, not the actual - value. - */ - { - ma_uint32 periodSizeInFrames; - ma_uint32 periodSizeInBytes; - ma_uint32 ossFragmentSizePower; - - periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, (ma_uint32)ossSampleRate, pConfig->performanceProfile); - - periodSizeInBytes = ma_round_to_power_of_2(periodSizeInFrames * ma_get_bytes_per_frame(ma_format_from_oss(ossFormat), ossChannels)); - if (periodSizeInBytes < 16) { - periodSizeInBytes = 16; - } - - ossFragmentSizePower = 4; - periodSizeInBytes >>= 4; - while (periodSizeInBytes >>= 1) { - ossFragmentSizePower += 1; - } - - ossFragment = (int)((pConfig->periods << 16) | ossFragmentSizePower); - ossResult = ioctl(fd, SNDCTL_DSP_SETFRAGMENT, &ossFragment); - if (ossResult == -1) { - close(fd); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to set fragment size and period count."); - return ma_result_from_errno(errno); - } - } - - /* Internal settings. */ - if (deviceType == ma_device_type_capture) { - pDevice->oss.fdCapture = fd; - } else { - pDevice->oss.fdPlayback = fd; - } - - pDescriptor->format = ma_format_from_oss(ossFormat); - pDescriptor->channels = ossChannels; - pDescriptor->sampleRate = ossSampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_sound4, pDescriptor->channelMap, ma_countof(pDescriptor->channelMap), pDescriptor->channels); - pDescriptor->periodCount = (ma_uint32)(ossFragment >> 16); - pDescriptor->periodSizeInFrames = (ma_uint32)(1 << (ossFragment & 0xFFFF)) / ma_get_bytes_per_frame(pDescriptor->format, pDescriptor->channels); - - if (pDescriptor->format == ma_format_unknown) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] The device's internal format is not supported by miniaudio."); - return MA_FORMAT_NOT_SUPPORTED; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_init__oss(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pConfig != NULL); - - MA_ZERO_OBJECT(&pDevice->oss); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_fd__oss(pDevice, pConfig, pDescriptorCapture, ma_device_type_capture); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to open device."); - return result; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_result result = ma_device_init_fd__oss(pDevice, pConfig, pDescriptorPlayback, ma_device_type_playback); - if (result != MA_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to open device."); - return result; - } - } - - return MA_SUCCESS; -} - -/* -Note on Starting and Stopping -============================= -In the past I was using SNDCTL_DSP_HALT to stop the device, however this results in issues when -trying to resume the device again. If we use SNDCTL_DSP_HALT, the next write() or read() will -fail. Instead what we need to do is just not write or read to and from the device when the -device is not running. - -As a result, both the start and stop functions for OSS are just empty stubs. The starting and -stopping logic is handled by ma_device_write__oss() and ma_device_read__oss(). These will check -the device state, and if the device is stopped they will simply not do any kind of processing. - -The downside to this technique is that I've noticed a fairly lengthy delay in stopping the -device, up to a second. This is on a virtual machine, and as such might just be due to the -virtual drivers, but I'm not fully sure. I am not sure how to work around this problem so for -the moment that's just how it's going to have to be. - -When starting the device, OSS will automatically start it when write() or read() is called. -*/ -static ma_result ma_device_start__oss(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - /* The device is automatically started with reading and writing. */ - (void)pDevice; - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__oss(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - /* See note above on why this is empty. */ - (void)pDevice; - - return MA_SUCCESS; -} - -static ma_result ma_device_write__oss(ma_device* pDevice, const void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesWritten) -{ - int resultOSS; - ma_uint32 deviceState; - - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - /* Don't do any processing if the device is stopped. */ - deviceState = ma_device_get_state(pDevice); - if (deviceState != ma_device_state_started && deviceState != ma_device_state_starting) { - return MA_SUCCESS; - } - - resultOSS = write(pDevice->oss.fdPlayback, pPCMFrames, frameCount * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - if (resultOSS < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to send data from the client to the device."); - return ma_result_from_errno(errno); - } - - if (pFramesWritten != NULL) { - *pFramesWritten = (ma_uint32)resultOSS / ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - } - - return MA_SUCCESS; -} - -static ma_result ma_device_read__oss(ma_device* pDevice, void* pPCMFrames, ma_uint32 frameCount, ma_uint32* pFramesRead) -{ - int resultOSS; - ma_uint32 deviceState; - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - /* Don't do any processing if the device is stopped. */ - deviceState = ma_device_get_state(pDevice); - if (deviceState != ma_device_state_started && deviceState != ma_device_state_starting) { - return MA_SUCCESS; - } - - resultOSS = read(pDevice->oss.fdCapture, pPCMFrames, frameCount * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels)); - if (resultOSS < 0) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OSS] Failed to read data from the device to be sent to the client."); - return ma_result_from_errno(errno); - } - - if (pFramesRead != NULL) { - *pFramesRead = (ma_uint32)resultOSS / ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - } - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__oss(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_oss); - - (void)pContext; - return MA_SUCCESS; -} - -static ma_result ma_context_init__oss(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - int fd; - int ossVersion; - int result; - - MA_ASSERT(pContext != NULL); - - (void)pConfig; - - /* Try opening a temporary device first so we can get version information. This is closed at the end. */ - fd = ma_open_temp_device__oss(); - if (fd == -1) { - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[OSS] Failed to open temporary device for retrieving system properties."); /* Looks liks OSS isn't installed, or there are no available devices. */ - return MA_NO_BACKEND; - } - - /* Grab the OSS version. */ - ossVersion = 0; - result = ioctl(fd, OSS_GETVERSION, &ossVersion); - if (result == -1) { - close(fd); - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_ERROR, "[OSS] Failed to retrieve OSS version."); - return MA_NO_BACKEND; - } - - /* The file handle to temp device is no longer needed. Close ASAP. */ - close(fd); - - pContext->oss.versionMajor = ((ossVersion & 0xFF0000) >> 16); - pContext->oss.versionMinor = ((ossVersion & 0x00FF00) >> 8); - - pCallbacks->onContextInit = ma_context_init__oss; - pCallbacks->onContextUninit = ma_context_uninit__oss; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__oss; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__oss; - pCallbacks->onDeviceInit = ma_device_init__oss; - pCallbacks->onDeviceUninit = ma_device_uninit__oss; - pCallbacks->onDeviceStart = ma_device_start__oss; - pCallbacks->onDeviceStop = ma_device_stop__oss; - pCallbacks->onDeviceRead = ma_device_read__oss; - pCallbacks->onDeviceWrite = ma_device_write__oss; - pCallbacks->onDeviceDataLoop = NULL; - - return MA_SUCCESS; -} -#endif /* OSS */ - - - - - -/****************************************************************************** - -AAudio Backend - -******************************************************************************/ -#ifdef MA_HAS_AAUDIO - -/*#include */ - -typedef int32_t ma_aaudio_result_t; -typedef int32_t ma_aaudio_direction_t; -typedef int32_t ma_aaudio_sharing_mode_t; -typedef int32_t ma_aaudio_format_t; -typedef int32_t ma_aaudio_stream_state_t; -typedef int32_t ma_aaudio_performance_mode_t; -typedef int32_t ma_aaudio_usage_t; -typedef int32_t ma_aaudio_content_type_t; -typedef int32_t ma_aaudio_input_preset_t; -typedef int32_t ma_aaudio_allowed_capture_policy_t; -typedef int32_t ma_aaudio_data_callback_result_t; -typedef struct ma_AAudioStreamBuilder_t* ma_AAudioStreamBuilder; -typedef struct ma_AAudioStream_t* ma_AAudioStream; - -#define MA_AAUDIO_UNSPECIFIED 0 - -/* Result codes. miniaudio only cares about the success code. */ -#define MA_AAUDIO_OK 0 - -/* Directions. */ -#define MA_AAUDIO_DIRECTION_OUTPUT 0 -#define MA_AAUDIO_DIRECTION_INPUT 1 - -/* Sharing modes. */ -#define MA_AAUDIO_SHARING_MODE_EXCLUSIVE 0 -#define MA_AAUDIO_SHARING_MODE_SHARED 1 - -/* Formats. */ -#define MA_AAUDIO_FORMAT_PCM_I16 1 -#define MA_AAUDIO_FORMAT_PCM_FLOAT 2 - -/* Stream states. */ -#define MA_AAUDIO_STREAM_STATE_UNINITIALIZED 0 -#define MA_AAUDIO_STREAM_STATE_UNKNOWN 1 -#define MA_AAUDIO_STREAM_STATE_OPEN 2 -#define MA_AAUDIO_STREAM_STATE_STARTING 3 -#define MA_AAUDIO_STREAM_STATE_STARTED 4 -#define MA_AAUDIO_STREAM_STATE_PAUSING 5 -#define MA_AAUDIO_STREAM_STATE_PAUSED 6 -#define MA_AAUDIO_STREAM_STATE_FLUSHING 7 -#define MA_AAUDIO_STREAM_STATE_FLUSHED 8 -#define MA_AAUDIO_STREAM_STATE_STOPPING 9 -#define MA_AAUDIO_STREAM_STATE_STOPPED 10 -#define MA_AAUDIO_STREAM_STATE_CLOSING 11 -#define MA_AAUDIO_STREAM_STATE_CLOSED 12 -#define MA_AAUDIO_STREAM_STATE_DISCONNECTED 13 - -/* Performance modes. */ -#define MA_AAUDIO_PERFORMANCE_MODE_NONE 10 -#define MA_AAUDIO_PERFORMANCE_MODE_POWER_SAVING 11 -#define MA_AAUDIO_PERFORMANCE_MODE_LOW_LATENCY 12 - -/* Usage types. */ -#define MA_AAUDIO_USAGE_MEDIA 1 -#define MA_AAUDIO_USAGE_VOICE_COMMUNICATION 2 -#define MA_AAUDIO_USAGE_VOICE_COMMUNICATION_SIGNALLING 3 -#define MA_AAUDIO_USAGE_ALARM 4 -#define MA_AAUDIO_USAGE_NOTIFICATION 5 -#define MA_AAUDIO_USAGE_NOTIFICATION_RINGTONE 6 -#define MA_AAUDIO_USAGE_NOTIFICATION_EVENT 10 -#define MA_AAUDIO_USAGE_ASSISTANCE_ACCESSIBILITY 11 -#define MA_AAUDIO_USAGE_ASSISTANCE_NAVIGATION_GUIDANCE 12 -#define MA_AAUDIO_USAGE_ASSISTANCE_SONIFICATION 13 -#define MA_AAUDIO_USAGE_GAME 14 -#define MA_AAUDIO_USAGE_ASSISTANT 16 -#define MA_AAUDIO_SYSTEM_USAGE_EMERGENCY 1000 -#define MA_AAUDIO_SYSTEM_USAGE_SAFETY 1001 -#define MA_AAUDIO_SYSTEM_USAGE_VEHICLE_STATUS 1002 -#define MA_AAUDIO_SYSTEM_USAGE_ANNOUNCEMENT 1003 - -/* Content types. */ -#define MA_AAUDIO_CONTENT_TYPE_SPEECH 1 -#define MA_AAUDIO_CONTENT_TYPE_MUSIC 2 -#define MA_AAUDIO_CONTENT_TYPE_MOVIE 3 -#define MA_AAUDIO_CONTENT_TYPE_SONIFICATION 4 - -/* Input presets. */ -#define MA_AAUDIO_INPUT_PRESET_GENERIC 1 -#define MA_AAUDIO_INPUT_PRESET_CAMCORDER 5 -#define MA_AAUDIO_INPUT_PRESET_VOICE_RECOGNITION 6 -#define MA_AAUDIO_INPUT_PRESET_VOICE_COMMUNICATION 7 -#define MA_AAUDIO_INPUT_PRESET_UNPROCESSED 9 -#define MA_AAUDIO_INPUT_PRESET_VOICE_PERFORMANCE 10 - -/* Allowed Capture Policies */ -#define MA_AAUDIO_ALLOW_CAPTURE_BY_ALL 1 -#define MA_AAUDIO_ALLOW_CAPTURE_BY_SYSTEM 2 -#define MA_AAUDIO_ALLOW_CAPTURE_BY_NONE 3 - -/* Callback results. */ -#define MA_AAUDIO_CALLBACK_RESULT_CONTINUE 0 -#define MA_AAUDIO_CALLBACK_RESULT_STOP 1 - - -typedef ma_aaudio_data_callback_result_t (* ma_AAudioStream_dataCallback) (ma_AAudioStream* pStream, void* pUserData, void* pAudioData, int32_t numFrames); -typedef void (* ma_AAudioStream_errorCallback)(ma_AAudioStream *pStream, void *pUserData, ma_aaudio_result_t error); - -typedef ma_aaudio_result_t (* MA_PFN_AAudio_createStreamBuilder) (ma_AAudioStreamBuilder** ppBuilder); -typedef ma_aaudio_result_t (* MA_PFN_AAudioStreamBuilder_delete) (ma_AAudioStreamBuilder* pBuilder); -typedef void (* MA_PFN_AAudioStreamBuilder_setDeviceId) (ma_AAudioStreamBuilder* pBuilder, int32_t deviceId); -typedef void (* MA_PFN_AAudioStreamBuilder_setDirection) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_direction_t direction); -typedef void (* MA_PFN_AAudioStreamBuilder_setSharingMode) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_sharing_mode_t sharingMode); -typedef void (* MA_PFN_AAudioStreamBuilder_setFormat) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_format_t format); -typedef void (* MA_PFN_AAudioStreamBuilder_setChannelCount) (ma_AAudioStreamBuilder* pBuilder, int32_t channelCount); -typedef void (* MA_PFN_AAudioStreamBuilder_setSampleRate) (ma_AAudioStreamBuilder* pBuilder, int32_t sampleRate); -typedef void (* MA_PFN_AAudioStreamBuilder_setBufferCapacityInFrames)(ma_AAudioStreamBuilder* pBuilder, int32_t numFrames); -typedef void (* MA_PFN_AAudioStreamBuilder_setFramesPerDataCallback) (ma_AAudioStreamBuilder* pBuilder, int32_t numFrames); -typedef void (* MA_PFN_AAudioStreamBuilder_setDataCallback) (ma_AAudioStreamBuilder* pBuilder, ma_AAudioStream_dataCallback callback, void* pUserData); -typedef void (* MA_PFN_AAudioStreamBuilder_setErrorCallback) (ma_AAudioStreamBuilder* pBuilder, ma_AAudioStream_errorCallback callback, void* pUserData); -typedef void (* MA_PFN_AAudioStreamBuilder_setPerformanceMode) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_performance_mode_t mode); -typedef void (* MA_PFN_AAudioStreamBuilder_setUsage) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_usage_t contentType); -typedef void (* MA_PFN_AAudioStreamBuilder_setContentType) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_content_type_t contentType); -typedef void (* MA_PFN_AAudioStreamBuilder_setInputPreset) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_input_preset_t inputPreset); -typedef void (* MA_PFN_AAudioStreamBuilder_setAllowedCapturePolicy) (ma_AAudioStreamBuilder* pBuilder, ma_aaudio_allowed_capture_policy_t policy); -typedef ma_aaudio_result_t (* MA_PFN_AAudioStreamBuilder_openStream) (ma_AAudioStreamBuilder* pBuilder, ma_AAudioStream** ppStream); -typedef ma_aaudio_result_t (* MA_PFN_AAudioStream_close) (ma_AAudioStream* pStream); -typedef ma_aaudio_stream_state_t (* MA_PFN_AAudioStream_getState) (ma_AAudioStream* pStream); -typedef ma_aaudio_result_t (* MA_PFN_AAudioStream_waitForStateChange) (ma_AAudioStream* pStream, ma_aaudio_stream_state_t inputState, ma_aaudio_stream_state_t* pNextState, int64_t timeoutInNanoseconds); -typedef ma_aaudio_format_t (* MA_PFN_AAudioStream_getFormat) (ma_AAudioStream* pStream); -typedef int32_t (* MA_PFN_AAudioStream_getChannelCount) (ma_AAudioStream* pStream); -typedef int32_t (* MA_PFN_AAudioStream_getSampleRate) (ma_AAudioStream* pStream); -typedef int32_t (* MA_PFN_AAudioStream_getBufferCapacityInFrames) (ma_AAudioStream* pStream); -typedef int32_t (* MA_PFN_AAudioStream_getFramesPerDataCallback) (ma_AAudioStream* pStream); -typedef int32_t (* MA_PFN_AAudioStream_getFramesPerBurst) (ma_AAudioStream* pStream); -typedef ma_aaudio_result_t (* MA_PFN_AAudioStream_requestStart) (ma_AAudioStream* pStream); -typedef ma_aaudio_result_t (* MA_PFN_AAudioStream_requestStop) (ma_AAudioStream* pStream); - -static ma_result ma_result_from_aaudio(ma_aaudio_result_t resultAA) -{ - switch (resultAA) - { - case MA_AAUDIO_OK: return MA_SUCCESS; - default: break; - } - - return MA_ERROR; -} - -static ma_aaudio_usage_t ma_to_usage__aaudio(ma_aaudio_usage usage) -{ - switch (usage) { - case ma_aaudio_usage_media: return MA_AAUDIO_USAGE_MEDIA; - case ma_aaudio_usage_voice_communication: return MA_AAUDIO_USAGE_VOICE_COMMUNICATION; - case ma_aaudio_usage_voice_communication_signalling: return MA_AAUDIO_USAGE_VOICE_COMMUNICATION_SIGNALLING; - case ma_aaudio_usage_alarm: return MA_AAUDIO_USAGE_ALARM; - case ma_aaudio_usage_notification: return MA_AAUDIO_USAGE_NOTIFICATION; - case ma_aaudio_usage_notification_ringtone: return MA_AAUDIO_USAGE_NOTIFICATION_RINGTONE; - case ma_aaudio_usage_notification_event: return MA_AAUDIO_USAGE_NOTIFICATION_EVENT; - case ma_aaudio_usage_assistance_accessibility: return MA_AAUDIO_USAGE_ASSISTANCE_ACCESSIBILITY; - case ma_aaudio_usage_assistance_navigation_guidance: return MA_AAUDIO_USAGE_ASSISTANCE_NAVIGATION_GUIDANCE; - case ma_aaudio_usage_assistance_sonification: return MA_AAUDIO_USAGE_ASSISTANCE_SONIFICATION; - case ma_aaudio_usage_game: return MA_AAUDIO_USAGE_GAME; - case ma_aaudio_usage_assitant: return MA_AAUDIO_USAGE_ASSISTANT; - case ma_aaudio_usage_emergency: return MA_AAUDIO_SYSTEM_USAGE_EMERGENCY; - case ma_aaudio_usage_safety: return MA_AAUDIO_SYSTEM_USAGE_SAFETY; - case ma_aaudio_usage_vehicle_status: return MA_AAUDIO_SYSTEM_USAGE_VEHICLE_STATUS; - case ma_aaudio_usage_announcement: return MA_AAUDIO_SYSTEM_USAGE_ANNOUNCEMENT; - default: break; - } - - return MA_AAUDIO_USAGE_MEDIA; -} - -static ma_aaudio_content_type_t ma_to_content_type__aaudio(ma_aaudio_content_type contentType) -{ - switch (contentType) { - case ma_aaudio_content_type_speech: return MA_AAUDIO_CONTENT_TYPE_SPEECH; - case ma_aaudio_content_type_music: return MA_AAUDIO_CONTENT_TYPE_MUSIC; - case ma_aaudio_content_type_movie: return MA_AAUDIO_CONTENT_TYPE_MOVIE; - case ma_aaudio_content_type_sonification: return MA_AAUDIO_CONTENT_TYPE_SONIFICATION; - default: break; - } - - return MA_AAUDIO_CONTENT_TYPE_SPEECH; -} - -static ma_aaudio_input_preset_t ma_to_input_preset__aaudio(ma_aaudio_input_preset inputPreset) -{ - switch (inputPreset) { - case ma_aaudio_input_preset_generic: return MA_AAUDIO_INPUT_PRESET_GENERIC; - case ma_aaudio_input_preset_camcorder: return MA_AAUDIO_INPUT_PRESET_CAMCORDER; - case ma_aaudio_input_preset_voice_recognition: return MA_AAUDIO_INPUT_PRESET_VOICE_RECOGNITION; - case ma_aaudio_input_preset_voice_communication: return MA_AAUDIO_INPUT_PRESET_VOICE_COMMUNICATION; - case ma_aaudio_input_preset_unprocessed: return MA_AAUDIO_INPUT_PRESET_UNPROCESSED; - case ma_aaudio_input_preset_voice_performance: return MA_AAUDIO_INPUT_PRESET_VOICE_PERFORMANCE; - default: break; - } - - return MA_AAUDIO_INPUT_PRESET_GENERIC; -} - -static ma_aaudio_allowed_capture_policy_t ma_to_allowed_capture_policy__aaudio(ma_aaudio_allowed_capture_policy allowedCapturePolicy) -{ - switch (allowedCapturePolicy) { - case ma_aaudio_allow_capture_by_all: return MA_AAUDIO_ALLOW_CAPTURE_BY_ALL; - case ma_aaudio_allow_capture_by_system: return MA_AAUDIO_ALLOW_CAPTURE_BY_SYSTEM; - case ma_aaudio_allow_capture_by_none: return MA_AAUDIO_ALLOW_CAPTURE_BY_NONE; - default: break; - } - - return MA_AAUDIO_ALLOW_CAPTURE_BY_ALL; -} - -static void ma_stream_error_callback__aaudio(ma_AAudioStream* pStream, void* pUserData, ma_aaudio_result_t error) -{ - ma_result result; - ma_job job; - ma_device* pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - (void)error; - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[AAudio] ERROR CALLBACK: error=%d, AAudioStream_getState()=%d\n", error, ((MA_PFN_AAudioStream_getState)pDevice->pContext->aaudio.AAudioStream_getState)(pStream)); - - /* - When we get an error, we'll assume that the stream is in an erroneous state and needs to be restarted. From the documentation, - we cannot do this from the error callback. Therefore we are going to use an event thread for the AAudio backend to do this - cleanly and safely. - */ - job = ma_job_init(MA_JOB_TYPE_DEVICE_AAUDIO_REROUTE); - job.data.device.aaudio.reroute.pDevice = pDevice; - - if (pStream == pDevice->aaudio.pStreamCapture) { - job.data.device.aaudio.reroute.deviceType = ma_device_type_capture; - } - else { - job.data.device.aaudio.reroute.deviceType = ma_device_type_playback; - } - - result = ma_device_job_thread_post(&pDevice->pContext->aaudio.jobThread, &job); - if (result != MA_SUCCESS) { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[AAudio] Device Disconnected. Failed to post job for rerouting.\n"); - return; - } -} - -static ma_aaudio_data_callback_result_t ma_stream_data_callback_capture__aaudio(ma_AAudioStream* pStream, void* pUserData, void* pAudioData, int32_t frameCount) -{ - ma_device* pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - ma_device_handle_backend_data_callback(pDevice, NULL, pAudioData, frameCount); - - (void)pStream; - return MA_AAUDIO_CALLBACK_RESULT_CONTINUE; -} - -static ma_aaudio_data_callback_result_t ma_stream_data_callback_playback__aaudio(ma_AAudioStream* pStream, void* pUserData, void* pAudioData, int32_t frameCount) -{ - ma_device* pDevice = (ma_device*)pUserData; - MA_ASSERT(pDevice != NULL); - - ma_device_handle_backend_data_callback(pDevice, pAudioData, NULL, frameCount); - - (void)pStream; - return MA_AAUDIO_CALLBACK_RESULT_CONTINUE; -} - -static ma_result ma_create_and_configure_AAudioStreamBuilder__aaudio(ma_context* pContext, const ma_device_id* pDeviceID, ma_device_type deviceType, ma_share_mode shareMode, const ma_device_descriptor* pDescriptor, const ma_device_config* pConfig, ma_device* pDevice, ma_AAudioStreamBuilder** ppBuilder) -{ - ma_AAudioStreamBuilder* pBuilder; - ma_aaudio_result_t resultAA; - - /* Safety. */ - *ppBuilder = NULL; - - resultAA = ((MA_PFN_AAudio_createStreamBuilder)pContext->aaudio.AAudio_createStreamBuilder)(&pBuilder); - if (resultAA != MA_AAUDIO_OK) { - return ma_result_from_aaudio(resultAA); - } - - if (pDeviceID != NULL) { - ((MA_PFN_AAudioStreamBuilder_setDeviceId)pContext->aaudio.AAudioStreamBuilder_setDeviceId)(pBuilder, pDeviceID->aaudio); - } - - ((MA_PFN_AAudioStreamBuilder_setDirection)pContext->aaudio.AAudioStreamBuilder_setDirection)(pBuilder, (deviceType == ma_device_type_playback) ? MA_AAUDIO_DIRECTION_OUTPUT : MA_AAUDIO_DIRECTION_INPUT); - ((MA_PFN_AAudioStreamBuilder_setSharingMode)pContext->aaudio.AAudioStreamBuilder_setSharingMode)(pBuilder, (shareMode == ma_share_mode_shared) ? MA_AAUDIO_SHARING_MODE_SHARED : MA_AAUDIO_SHARING_MODE_EXCLUSIVE); - - - /* If we have a device descriptor make sure we configure the stream builder to take our requested parameters. */ - if (pDescriptor != NULL) { - MA_ASSERT(pConfig != NULL); /* We must have a device config if we also have a descriptor. The config is required for AAudio specific configuration options. */ - - if (pDescriptor->sampleRate != 0) { - ((MA_PFN_AAudioStreamBuilder_setSampleRate)pContext->aaudio.AAudioStreamBuilder_setSampleRate)(pBuilder, pDescriptor->sampleRate); - } - - if (deviceType == ma_device_type_capture) { - if (pDescriptor->channels != 0) { - ((MA_PFN_AAudioStreamBuilder_setChannelCount)pContext->aaudio.AAudioStreamBuilder_setChannelCount)(pBuilder, pDescriptor->channels); - } - if (pDescriptor->format != ma_format_unknown) { - ((MA_PFN_AAudioStreamBuilder_setFormat)pContext->aaudio.AAudioStreamBuilder_setFormat)(pBuilder, (pDescriptor->format == ma_format_s16) ? MA_AAUDIO_FORMAT_PCM_I16 : MA_AAUDIO_FORMAT_PCM_FLOAT); - } - } else { - if (pDescriptor->channels != 0) { - ((MA_PFN_AAudioStreamBuilder_setChannelCount)pContext->aaudio.AAudioStreamBuilder_setChannelCount)(pBuilder, pDescriptor->channels); - } - if (pDescriptor->format != ma_format_unknown) { - ((MA_PFN_AAudioStreamBuilder_setFormat)pContext->aaudio.AAudioStreamBuilder_setFormat)(pBuilder, (pDescriptor->format == ma_format_s16) ? MA_AAUDIO_FORMAT_PCM_I16 : MA_AAUDIO_FORMAT_PCM_FLOAT); - } - } - - - /* - There have been reports where setting the frames per data callback results in an error - later on from Android. To address this, I'm experimenting with simply not setting it on - anything from Android 11 and earlier. Suggestions welcome on how we might be able to make - this more targetted. - */ - if (pConfig->aaudio.enableCompatibilityWorkarounds && ma_android_sdk_version() > 30) { - /* - AAudio is annoying when it comes to it's buffer calculation stuff because it doesn't let you - retrieve the actual sample rate until after you've opened the stream. But you need to configure - the buffer capacity before you open the stream... :/ - - To solve, we're just going to assume MA_DEFAULT_SAMPLE_RATE (48000) and move on. - */ - ma_uint32 bufferCapacityInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptor, pDescriptor->sampleRate, pConfig->performanceProfile) * pDescriptor->periodCount; - - ((MA_PFN_AAudioStreamBuilder_setBufferCapacityInFrames)pContext->aaudio.AAudioStreamBuilder_setBufferCapacityInFrames)(pBuilder, bufferCapacityInFrames); - ((MA_PFN_AAudioStreamBuilder_setFramesPerDataCallback)pContext->aaudio.AAudioStreamBuilder_setFramesPerDataCallback)(pBuilder, bufferCapacityInFrames / pDescriptor->periodCount); - } - - if (deviceType == ma_device_type_capture) { - if (pConfig->aaudio.inputPreset != ma_aaudio_input_preset_default && pContext->aaudio.AAudioStreamBuilder_setInputPreset != NULL) { - ((MA_PFN_AAudioStreamBuilder_setInputPreset)pContext->aaudio.AAudioStreamBuilder_setInputPreset)(pBuilder, ma_to_input_preset__aaudio(pConfig->aaudio.inputPreset)); - } - - ((MA_PFN_AAudioStreamBuilder_setDataCallback)pContext->aaudio.AAudioStreamBuilder_setDataCallback)(pBuilder, ma_stream_data_callback_capture__aaudio, (void*)pDevice); - } else { - if (pConfig->aaudio.usage != ma_aaudio_usage_default && pContext->aaudio.AAudioStreamBuilder_setUsage != NULL) { - ((MA_PFN_AAudioStreamBuilder_setUsage)pContext->aaudio.AAudioStreamBuilder_setUsage)(pBuilder, ma_to_usage__aaudio(pConfig->aaudio.usage)); - } - - if (pConfig->aaudio.contentType != ma_aaudio_content_type_default && pContext->aaudio.AAudioStreamBuilder_setContentType != NULL) { - ((MA_PFN_AAudioStreamBuilder_setContentType)pContext->aaudio.AAudioStreamBuilder_setContentType)(pBuilder, ma_to_content_type__aaudio(pConfig->aaudio.contentType)); - } - - if (pConfig->aaudio.allowedCapturePolicy != ma_aaudio_allow_capture_default && pContext->aaudio.AAudioStreamBuilder_setAllowedCapturePolicy != NULL) { - ((MA_PFN_AAudioStreamBuilder_setAllowedCapturePolicy)pContext->aaudio.AAudioStreamBuilder_setAllowedCapturePolicy)(pBuilder, ma_to_allowed_capture_policy__aaudio(pConfig->aaudio.allowedCapturePolicy)); - } - - ((MA_PFN_AAudioStreamBuilder_setDataCallback)pContext->aaudio.AAudioStreamBuilder_setDataCallback)(pBuilder, ma_stream_data_callback_playback__aaudio, (void*)pDevice); - } - - /* Not sure how this affects things, but since there's a mapping between miniaudio's performance profiles and AAudio's performance modes, let go ahead and set it. */ - ((MA_PFN_AAudioStreamBuilder_setPerformanceMode)pContext->aaudio.AAudioStreamBuilder_setPerformanceMode)(pBuilder, (pConfig->performanceProfile == ma_performance_profile_low_latency) ? MA_AAUDIO_PERFORMANCE_MODE_LOW_LATENCY : MA_AAUDIO_PERFORMANCE_MODE_NONE); - - /* We need to set an error callback to detect device changes. */ - if (pDevice != NULL) { /* <-- pDevice should never be null if pDescriptor is not null, which is always the case if we hit this branch. Check anyway for safety. */ - ((MA_PFN_AAudioStreamBuilder_setErrorCallback)pContext->aaudio.AAudioStreamBuilder_setErrorCallback)(pBuilder, ma_stream_error_callback__aaudio, (void*)pDevice); - } - } - - *ppBuilder = pBuilder; - - return MA_SUCCESS; -} - -static ma_result ma_open_stream_and_close_builder__aaudio(ma_context* pContext, ma_AAudioStreamBuilder* pBuilder, ma_AAudioStream** ppStream) -{ - ma_result result; - - result = ma_result_from_aaudio(((MA_PFN_AAudioStreamBuilder_openStream)pContext->aaudio.AAudioStreamBuilder_openStream)(pBuilder, ppStream)); - ((MA_PFN_AAudioStreamBuilder_delete)pContext->aaudio.AAudioStreamBuilder_delete)(pBuilder); - - return result; -} - -static ma_result ma_open_stream_basic__aaudio(ma_context* pContext, const ma_device_id* pDeviceID, ma_device_type deviceType, ma_share_mode shareMode, ma_AAudioStream** ppStream) -{ - ma_result result; - ma_AAudioStreamBuilder* pBuilder; - - *ppStream = NULL; - - result = ma_create_and_configure_AAudioStreamBuilder__aaudio(pContext, pDeviceID, deviceType, shareMode, NULL, NULL, NULL, &pBuilder); - if (result != MA_SUCCESS) { - return result; - } - - return ma_open_stream_and_close_builder__aaudio(pContext, pBuilder, ppStream); -} - -static ma_result ma_open_stream__aaudio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_type deviceType, const ma_device_descriptor* pDescriptor, ma_AAudioStream** ppStream) -{ - ma_result result; - ma_AAudioStreamBuilder* pBuilder; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pDescriptor != NULL); - MA_ASSERT(deviceType != ma_device_type_duplex); /* This function should not be called for a full-duplex device type. */ - - *ppStream = NULL; - - result = ma_create_and_configure_AAudioStreamBuilder__aaudio(pDevice->pContext, pDescriptor->pDeviceID, deviceType, pDescriptor->shareMode, pDescriptor, pConfig, pDevice, &pBuilder); - if (result != MA_SUCCESS) { - return result; - } - - return ma_open_stream_and_close_builder__aaudio(pDevice->pContext, pBuilder, ppStream); -} - -static ma_result ma_close_stream__aaudio(ma_context* pContext, ma_AAudioStream* pStream) -{ - return ma_result_from_aaudio(((MA_PFN_AAudioStream_close)pContext->aaudio.AAudioStream_close)(pStream)); -} - -static ma_bool32 ma_has_default_device__aaudio(ma_context* pContext, ma_device_type deviceType) -{ - /* The only way to know this is to try creating a stream. */ - ma_AAudioStream* pStream; - ma_result result = ma_open_stream_basic__aaudio(pContext, NULL, deviceType, ma_share_mode_shared, &pStream); - if (result != MA_SUCCESS) { - return MA_FALSE; - } - - ma_close_stream__aaudio(pContext, pStream); - return MA_TRUE; -} - -static ma_result ma_wait_for_simple_state_transition__aaudio(ma_context* pContext, ma_AAudioStream* pStream, ma_aaudio_stream_state_t oldState, ma_aaudio_stream_state_t newState) -{ - ma_aaudio_stream_state_t actualNewState; - ma_aaudio_result_t resultAA = ((MA_PFN_AAudioStream_waitForStateChange)pContext->aaudio.AAudioStream_waitForStateChange)(pStream, oldState, &actualNewState, 5000000000); /* 5 second timeout. */ - if (resultAA != MA_AAUDIO_OK) { - return ma_result_from_aaudio(resultAA); - } - - if (newState != actualNewState) { - return MA_ERROR; /* Failed to transition into the expected state. */ - } - - return MA_SUCCESS; -} - - -static ma_result ma_context_enumerate_devices__aaudio(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_bool32 cbResult = MA_TRUE; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* Unfortunately AAudio does not have an enumeration API. Therefore I'm only going to report default devices, but only if it can instantiate a stream. */ - - /* Playback. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.aaudio = MA_AAUDIO_UNSPECIFIED; - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - - if (ma_has_default_device__aaudio(pContext, ma_device_type_playback)) { - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - } - - /* Capture. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.aaudio = MA_AAUDIO_UNSPECIFIED; - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - - if (ma_has_default_device__aaudio(pContext, ma_device_type_capture)) { - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - } - - return MA_SUCCESS; -} - -static void ma_context_add_native_data_format_from_AAudioStream_ex__aaudio(ma_context* pContext, ma_AAudioStream* pStream, ma_format format, ma_uint32 flags, ma_device_info* pDeviceInfo) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pStream != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = format; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = ((MA_PFN_AAudioStream_getChannelCount)pContext->aaudio.AAudioStream_getChannelCount)(pStream); - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = ((MA_PFN_AAudioStream_getSampleRate)pContext->aaudio.AAudioStream_getSampleRate)(pStream); - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = flags; - pDeviceInfo->nativeDataFormatCount += 1; -} - -static void ma_context_add_native_data_format_from_AAudioStream__aaudio(ma_context* pContext, ma_AAudioStream* pStream, ma_uint32 flags, ma_device_info* pDeviceInfo) -{ - /* AAudio supports s16 and f32. */ - ma_context_add_native_data_format_from_AAudioStream_ex__aaudio(pContext, pStream, ma_format_f32, flags, pDeviceInfo); - ma_context_add_native_data_format_from_AAudioStream_ex__aaudio(pContext, pStream, ma_format_s16, flags, pDeviceInfo); -} - -static ma_result ma_context_get_device_info__aaudio(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_AAudioStream* pStream; - ma_result result; - - MA_ASSERT(pContext != NULL); - - /* ID */ - if (pDeviceID != NULL) { - pDeviceInfo->id.aaudio = pDeviceID->aaudio; - } else { - pDeviceInfo->id.aaudio = MA_AAUDIO_UNSPECIFIED; - } - - /* Name */ - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - - pDeviceInfo->nativeDataFormatCount = 0; - - /* We'll need to open the device to get accurate sample rate and channel count information. */ - result = ma_open_stream_basic__aaudio(pContext, pDeviceID, deviceType, ma_share_mode_shared, &pStream); - if (result != MA_SUCCESS) { - return result; - } - - ma_context_add_native_data_format_from_AAudioStream__aaudio(pContext, pStream, 0, pDeviceInfo); - - ma_close_stream__aaudio(pContext, pStream); - pStream = NULL; - - return MA_SUCCESS; -} - - -static ma_result ma_device_uninit__aaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_close_stream__aaudio(pDevice->pContext, (ma_AAudioStream*)pDevice->aaudio.pStreamCapture); - pDevice->aaudio.pStreamCapture = NULL; - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_close_stream__aaudio(pDevice->pContext, (ma_AAudioStream*)pDevice->aaudio.pStreamPlayback); - pDevice->aaudio.pStreamPlayback = NULL; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_init_by_type__aaudio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_type deviceType, ma_device_descriptor* pDescriptor, ma_AAudioStream** ppStream) -{ - ma_result result; - int32_t bufferCapacityInFrames; - int32_t framesPerDataCallback; - ma_AAudioStream* pStream; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pDescriptor != NULL); - - *ppStream = NULL; /* Safety. */ - - /* First step is to open the stream. From there we'll be able to extract the internal configuration. */ - result = ma_open_stream__aaudio(pDevice, pConfig, deviceType, pDescriptor, &pStream); - if (result != MA_SUCCESS) { - return result; /* Failed to open the AAudio stream. */ - } - - /* Now extract the internal configuration. */ - pDescriptor->format = (((MA_PFN_AAudioStream_getFormat)pDevice->pContext->aaudio.AAudioStream_getFormat)(pStream) == MA_AAUDIO_FORMAT_PCM_I16) ? ma_format_s16 : ma_format_f32; - pDescriptor->channels = ((MA_PFN_AAudioStream_getChannelCount)pDevice->pContext->aaudio.AAudioStream_getChannelCount)(pStream); - pDescriptor->sampleRate = ((MA_PFN_AAudioStream_getSampleRate)pDevice->pContext->aaudio.AAudioStream_getSampleRate)(pStream); - - /* For the channel map we need to be sure we don't overflow any buffers. */ - if (pDescriptor->channels <= MA_MAX_CHANNELS) { - ma_channel_map_init_standard(ma_standard_channel_map_default, pDescriptor->channelMap, ma_countof(pDescriptor->channelMap), pDescriptor->channels); /* <-- Cannot find info on channel order, so assuming a default. */ - } else { - ma_channel_map_init_blank(pDescriptor->channelMap, MA_MAX_CHANNELS); /* Too many channels. Use a blank channel map. */ - } - - bufferCapacityInFrames = ((MA_PFN_AAudioStream_getBufferCapacityInFrames)pDevice->pContext->aaudio.AAudioStream_getBufferCapacityInFrames)(pStream); - framesPerDataCallback = ((MA_PFN_AAudioStream_getFramesPerDataCallback)pDevice->pContext->aaudio.AAudioStream_getFramesPerDataCallback)(pStream); - - if (framesPerDataCallback > 0) { - pDescriptor->periodSizeInFrames = framesPerDataCallback; - pDescriptor->periodCount = bufferCapacityInFrames / framesPerDataCallback; - } else { - pDescriptor->periodSizeInFrames = bufferCapacityInFrames; - pDescriptor->periodCount = 1; - } - - *ppStream = pStream; - - return MA_SUCCESS; -} - -static ma_result ma_device_init__aaudio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - pDevice->aaudio.usage = pConfig->aaudio.usage; - pDevice->aaudio.contentType = pConfig->aaudio.contentType; - pDevice->aaudio.inputPreset = pConfig->aaudio.inputPreset; - pDevice->aaudio.allowedCapturePolicy = pConfig->aaudio.allowedCapturePolicy; - pDevice->aaudio.noAutoStartAfterReroute = pConfig->aaudio.noAutoStartAfterReroute; - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - result = ma_device_init_by_type__aaudio(pDevice, pConfig, ma_device_type_capture, pDescriptorCapture, (ma_AAudioStream**)&pDevice->aaudio.pStreamCapture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - result = ma_device_init_by_type__aaudio(pDevice, pConfig, ma_device_type_playback, pDescriptorPlayback, (ma_AAudioStream**)&pDevice->aaudio.pStreamPlayback); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start_stream__aaudio(ma_device* pDevice, ma_AAudioStream* pStream) -{ - ma_aaudio_result_t resultAA; - ma_aaudio_stream_state_t currentState; - - MA_ASSERT(pDevice != NULL); - - resultAA = ((MA_PFN_AAudioStream_requestStart)pDevice->pContext->aaudio.AAudioStream_requestStart)(pStream); - if (resultAA != MA_AAUDIO_OK) { - return ma_result_from_aaudio(resultAA); - } - - /* Do we actually need to wait for the device to transition into it's started state? */ - - /* The device should be in either a starting or started state. If it's not set to started we need to wait for it to transition. It should go from starting to started. */ - currentState = ((MA_PFN_AAudioStream_getState)pDevice->pContext->aaudio.AAudioStream_getState)(pStream); - if (currentState != MA_AAUDIO_STREAM_STATE_STARTED) { - ma_result result; - - if (currentState != MA_AAUDIO_STREAM_STATE_STARTING) { - return MA_ERROR; /* Expecting the stream to be a starting or started state. */ - } - - result = ma_wait_for_simple_state_transition__aaudio(pDevice->pContext, pStream, currentState, MA_AAUDIO_STREAM_STATE_STARTED); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop_stream__aaudio(ma_device* pDevice, ma_AAudioStream* pStream) -{ - ma_aaudio_result_t resultAA; - ma_aaudio_stream_state_t currentState; - - MA_ASSERT(pDevice != NULL); - - /* - From the AAudio documentation: - - The stream will stop after all of the data currently buffered has been played. - - This maps with miniaudio's requirement that device's be drained which means we don't need to implement any draining logic. - */ - currentState = ((MA_PFN_AAudioStream_getState)pDevice->pContext->aaudio.AAudioStream_getState)(pStream); - if (currentState == MA_AAUDIO_STREAM_STATE_DISCONNECTED) { - return MA_SUCCESS; /* The device is disconnected. Don't try stopping it. */ - } - - resultAA = ((MA_PFN_AAudioStream_requestStop)pDevice->pContext->aaudio.AAudioStream_requestStop)(pStream); - if (resultAA != MA_AAUDIO_OK) { - return ma_result_from_aaudio(resultAA); - } - - /* The device should be in either a stopping or stopped state. If it's not set to started we need to wait for it to transition. It should go from stopping to stopped. */ - currentState = ((MA_PFN_AAudioStream_getState)pDevice->pContext->aaudio.AAudioStream_getState)(pStream); - if (currentState != MA_AAUDIO_STREAM_STATE_STOPPED) { - ma_result result; - - if (currentState != MA_AAUDIO_STREAM_STATE_STOPPING) { - return MA_ERROR; /* Expecting the stream to be a stopping or stopped state. */ - } - - result = ma_wait_for_simple_state_transition__aaudio(pDevice->pContext, pStream, currentState, MA_AAUDIO_STREAM_STATE_STOPPED); - if (result != MA_SUCCESS) { - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__aaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_result result = ma_device_start_stream__aaudio(pDevice, (ma_AAudioStream*)pDevice->aaudio.pStreamCapture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_result result = ma_device_start_stream__aaudio(pDevice, (ma_AAudioStream*)pDevice->aaudio.pStreamPlayback); - if (result != MA_SUCCESS) { - if (pDevice->type == ma_device_type_duplex) { - ma_device_stop_stream__aaudio(pDevice, (ma_AAudioStream*)pDevice->aaudio.pStreamCapture); - } - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__aaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_result result = ma_device_stop_stream__aaudio(pDevice, (ma_AAudioStream*)pDevice->aaudio.pStreamCapture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_result result = ma_device_stop_stream__aaudio(pDevice, (ma_AAudioStream*)pDevice->aaudio.pStreamPlayback); - if (result != MA_SUCCESS) { - return result; - } - } - - ma_device__on_notification_stopped(pDevice); - - return MA_SUCCESS; -} - -static ma_result ma_device_reinit__aaudio(ma_device* pDevice, ma_device_type deviceType) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - /* The first thing to do is close the streams. */ - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex) { - ma_close_stream__aaudio(pDevice->pContext, (ma_AAudioStream*)pDevice->aaudio.pStreamCapture); - pDevice->aaudio.pStreamCapture = NULL; - } - - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - ma_close_stream__aaudio(pDevice->pContext, (ma_AAudioStream*)pDevice->aaudio.pStreamPlayback); - pDevice->aaudio.pStreamPlayback = NULL; - } - - /* Now we need to reinitialize each streams. The hardest part with this is just filling output the config and descriptors. */ - { - ma_device_config deviceConfig; - ma_device_descriptor descriptorPlayback; - ma_device_descriptor descriptorCapture; - - deviceConfig = ma_device_config_init(deviceType); - deviceConfig.playback.pDeviceID = NULL; /* Only doing rerouting with default devices. */ - deviceConfig.playback.shareMode = pDevice->playback.shareMode; - deviceConfig.playback.format = pDevice->playback.format; - deviceConfig.playback.channels = pDevice->playback.channels; - deviceConfig.capture.pDeviceID = NULL; /* Only doing rerouting with default devices. */ - deviceConfig.capture.shareMode = pDevice->capture.shareMode; - deviceConfig.capture.format = pDevice->capture.format; - deviceConfig.capture.channels = pDevice->capture.channels; - deviceConfig.sampleRate = pDevice->sampleRate; - deviceConfig.aaudio.usage = pDevice->aaudio.usage; - deviceConfig.aaudio.contentType = pDevice->aaudio.contentType; - deviceConfig.aaudio.inputPreset = pDevice->aaudio.inputPreset; - deviceConfig.aaudio.allowedCapturePolicy = pDevice->aaudio.allowedCapturePolicy; - deviceConfig.aaudio.noAutoStartAfterReroute = pDevice->aaudio.noAutoStartAfterReroute; - deviceConfig.periods = 1; - - /* Try to get an accurate period size. */ - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - deviceConfig.periodSizeInFrames = pDevice->playback.internalPeriodSizeInFrames; - } else { - deviceConfig.periodSizeInFrames = pDevice->capture.internalPeriodSizeInFrames; - } - - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex || deviceType == ma_device_type_loopback) { - descriptorCapture.pDeviceID = deviceConfig.capture.pDeviceID; - descriptorCapture.shareMode = deviceConfig.capture.shareMode; - descriptorCapture.format = deviceConfig.capture.format; - descriptorCapture.channels = deviceConfig.capture.channels; - descriptorCapture.sampleRate = deviceConfig.sampleRate; - descriptorCapture.periodSizeInFrames = deviceConfig.periodSizeInFrames; - descriptorCapture.periodCount = deviceConfig.periods; - } - - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - descriptorPlayback.pDeviceID = deviceConfig.playback.pDeviceID; - descriptorPlayback.shareMode = deviceConfig.playback.shareMode; - descriptorPlayback.format = deviceConfig.playback.format; - descriptorPlayback.channels = deviceConfig.playback.channels; - descriptorPlayback.sampleRate = deviceConfig.sampleRate; - descriptorPlayback.periodSizeInFrames = deviceConfig.periodSizeInFrames; - descriptorPlayback.periodCount = deviceConfig.periods; - } - - result = ma_device_init__aaudio(pDevice, &deviceConfig, &descriptorPlayback, &descriptorCapture); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_device_post_init(pDevice, deviceType, &descriptorPlayback, &descriptorCapture); - if (result != MA_SUCCESS) { - ma_device_uninit__aaudio(pDevice); - return result; - } - - /* We'll only ever do this in response to a reroute. */ - ma_device__on_notification_rerouted(pDevice); - - /* If the device is started, start the streams. Maybe make this configurable? */ - if (ma_device_get_state(pDevice) == ma_device_state_started) { - if (pDevice->aaudio.noAutoStartAfterReroute == MA_FALSE) { - ma_device_start__aaudio(pDevice); - } else { - ma_device_stop(pDevice); /* Do a full device stop so we set internal state correctly. */ - } - } - - return MA_SUCCESS; - } -} - -static ma_result ma_device_get_info__aaudio(ma_device* pDevice, ma_device_type type, ma_device_info* pDeviceInfo) -{ - ma_AAudioStream* pStream = NULL; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(type != ma_device_type_duplex); - MA_ASSERT(pDeviceInfo != NULL); - - if (type == ma_device_type_playback) { - pStream = (ma_AAudioStream*)pDevice->aaudio.pStreamCapture; - pDeviceInfo->id.aaudio = pDevice->capture.id.aaudio; - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); /* Only supporting default devices. */ - } - if (type == ma_device_type_capture) { - pStream = (ma_AAudioStream*)pDevice->aaudio.pStreamPlayback; - pDeviceInfo->id.aaudio = pDevice->playback.id.aaudio; - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); /* Only supporting default devices. */ - } - - /* Safety. Should never happen. */ - if (pStream == NULL) { - return MA_INVALID_OPERATION; - } - - pDeviceInfo->nativeDataFormatCount = 0; - ma_context_add_native_data_format_from_AAudioStream__aaudio(pDevice->pContext, pStream, 0, pDeviceInfo); - - return MA_SUCCESS; -} - - -static ma_result ma_context_uninit__aaudio(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_aaudio); - - ma_device_job_thread_uninit(&pContext->aaudio.jobThread, &pContext->allocationCallbacks); - - ma_dlclose(pContext, pContext->aaudio.hAAudio); - pContext->aaudio.hAAudio = NULL; - - return MA_SUCCESS; -} - -static ma_result ma_context_init__aaudio(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - size_t i; - const char* libNames[] = { - "libaaudio.so" - }; - - for (i = 0; i < ma_countof(libNames); ++i) { - pContext->aaudio.hAAudio = ma_dlopen(pContext, libNames[i]); - if (pContext->aaudio.hAAudio != NULL) { - break; - } - } - - if (pContext->aaudio.hAAudio == NULL) { - return MA_FAILED_TO_INIT_BACKEND; - } - - pContext->aaudio.AAudio_createStreamBuilder = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudio_createStreamBuilder"); - pContext->aaudio.AAudioStreamBuilder_delete = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_delete"); - pContext->aaudio.AAudioStreamBuilder_setDeviceId = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setDeviceId"); - pContext->aaudio.AAudioStreamBuilder_setDirection = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setDirection"); - pContext->aaudio.AAudioStreamBuilder_setSharingMode = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setSharingMode"); - pContext->aaudio.AAudioStreamBuilder_setFormat = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setFormat"); - pContext->aaudio.AAudioStreamBuilder_setChannelCount = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setChannelCount"); - pContext->aaudio.AAudioStreamBuilder_setSampleRate = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setSampleRate"); - pContext->aaudio.AAudioStreamBuilder_setBufferCapacityInFrames = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setBufferCapacityInFrames"); - pContext->aaudio.AAudioStreamBuilder_setFramesPerDataCallback = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setFramesPerDataCallback"); - pContext->aaudio.AAudioStreamBuilder_setDataCallback = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setDataCallback"); - pContext->aaudio.AAudioStreamBuilder_setErrorCallback = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setErrorCallback"); - pContext->aaudio.AAudioStreamBuilder_setPerformanceMode = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setPerformanceMode"); - pContext->aaudio.AAudioStreamBuilder_setUsage = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setUsage"); - pContext->aaudio.AAudioStreamBuilder_setContentType = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setContentType"); - pContext->aaudio.AAudioStreamBuilder_setInputPreset = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setInputPreset"); - pContext->aaudio.AAudioStreamBuilder_setAllowedCapturePolicy = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_setAllowedCapturePolicy"); - pContext->aaudio.AAudioStreamBuilder_openStream = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStreamBuilder_openStream"); - pContext->aaudio.AAudioStream_close = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_close"); - pContext->aaudio.AAudioStream_getState = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getState"); - pContext->aaudio.AAudioStream_waitForStateChange = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_waitForStateChange"); - pContext->aaudio.AAudioStream_getFormat = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getFormat"); - pContext->aaudio.AAudioStream_getChannelCount = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getChannelCount"); - pContext->aaudio.AAudioStream_getSampleRate = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getSampleRate"); - pContext->aaudio.AAudioStream_getBufferCapacityInFrames = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getBufferCapacityInFrames"); - pContext->aaudio.AAudioStream_getFramesPerDataCallback = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getFramesPerDataCallback"); - pContext->aaudio.AAudioStream_getFramesPerBurst = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_getFramesPerBurst"); - pContext->aaudio.AAudioStream_requestStart = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_requestStart"); - pContext->aaudio.AAudioStream_requestStop = (ma_proc)ma_dlsym(pContext, pContext->aaudio.hAAudio, "AAudioStream_requestStop"); - - - pCallbacks->onContextInit = ma_context_init__aaudio; - pCallbacks->onContextUninit = ma_context_uninit__aaudio; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__aaudio; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__aaudio; - pCallbacks->onDeviceInit = ma_device_init__aaudio; - pCallbacks->onDeviceUninit = ma_device_uninit__aaudio; - pCallbacks->onDeviceStart = ma_device_start__aaudio; - pCallbacks->onDeviceStop = ma_device_stop__aaudio; - pCallbacks->onDeviceRead = NULL; /* Not used because AAudio is asynchronous. */ - pCallbacks->onDeviceWrite = NULL; /* Not used because AAudio is asynchronous. */ - pCallbacks->onDeviceDataLoop = NULL; /* Not used because AAudio is asynchronous. */ - pCallbacks->onDeviceGetInfo = ma_device_get_info__aaudio; - - - /* We need a job thread so we can deal with rerouting. */ - { - ma_result result; - ma_device_job_thread_config jobThreadConfig; - - jobThreadConfig = ma_device_job_thread_config_init(); - - result = ma_device_job_thread_init(&jobThreadConfig, &pContext->allocationCallbacks, &pContext->aaudio.jobThread); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->aaudio.hAAudio); - pContext->aaudio.hAAudio = NULL; - return result; - } - } - - - (void)pConfig; - return MA_SUCCESS; -} - -static ma_result ma_job_process__device__aaudio_reroute(ma_job* pJob) -{ - ma_device* pDevice; - - MA_ASSERT(pJob != NULL); - - pDevice = (ma_device*)pJob->data.device.aaudio.reroute.pDevice; - MA_ASSERT(pDevice != NULL); - - /* Here is where we need to reroute the device. To do this we need to uninitialize the stream and reinitialize it. */ - return ma_device_reinit__aaudio(pDevice, (ma_device_type)pJob->data.device.aaudio.reroute.deviceType); -} -#else -/* Getting here means there is no AAudio backend so we need a no-op job implementation. */ -static ma_result ma_job_process__device__aaudio_reroute(ma_job* pJob) -{ - return ma_job_process__noop(pJob); -} -#endif /* AAudio */ - - -/****************************************************************************** - -OpenSL|ES Backend - -******************************************************************************/ -#ifdef MA_HAS_OPENSL -#include -#ifdef MA_ANDROID -#include -#endif - -typedef SLresult (SLAPIENTRY * ma_slCreateEngine_proc)(SLObjectItf* pEngine, SLuint32 numOptions, SLEngineOption* pEngineOptions, SLuint32 numInterfaces, SLInterfaceID* pInterfaceIds, SLboolean* pInterfaceRequired); - -/* OpenSL|ES has one-per-application objects :( */ -static SLObjectItf g_maEngineObjectSL = NULL; -static SLEngineItf g_maEngineSL = NULL; -static ma_uint32 g_maOpenSLInitCounter = 0; -static ma_spinlock g_maOpenSLSpinlock = 0; /* For init/uninit. */ - -#define MA_OPENSL_OBJ(p) (*((SLObjectItf)(p))) -#define MA_OPENSL_OUTPUTMIX(p) (*((SLOutputMixItf)(p))) -#define MA_OPENSL_PLAY(p) (*((SLPlayItf)(p))) -#define MA_OPENSL_RECORD(p) (*((SLRecordItf)(p))) - -#ifdef MA_ANDROID -#define MA_OPENSL_BUFFERQUEUE(p) (*((SLAndroidSimpleBufferQueueItf)(p))) -#else -#define MA_OPENSL_BUFFERQUEUE(p) (*((SLBufferQueueItf)(p))) -#endif - -static ma_result ma_result_from_OpenSL(SLuint32 result) -{ - switch (result) - { - case SL_RESULT_SUCCESS: return MA_SUCCESS; - case SL_RESULT_PRECONDITIONS_VIOLATED: return MA_ERROR; - case SL_RESULT_PARAMETER_INVALID: return MA_INVALID_ARGS; - case SL_RESULT_MEMORY_FAILURE: return MA_OUT_OF_MEMORY; - case SL_RESULT_RESOURCE_ERROR: return MA_INVALID_DATA; - case SL_RESULT_RESOURCE_LOST: return MA_ERROR; - case SL_RESULT_IO_ERROR: return MA_IO_ERROR; - case SL_RESULT_BUFFER_INSUFFICIENT: return MA_NO_SPACE; - case SL_RESULT_CONTENT_CORRUPTED: return MA_INVALID_DATA; - case SL_RESULT_CONTENT_UNSUPPORTED: return MA_FORMAT_NOT_SUPPORTED; - case SL_RESULT_CONTENT_NOT_FOUND: return MA_ERROR; - case SL_RESULT_PERMISSION_DENIED: return MA_ACCESS_DENIED; - case SL_RESULT_FEATURE_UNSUPPORTED: return MA_NOT_IMPLEMENTED; - case SL_RESULT_INTERNAL_ERROR: return MA_ERROR; - case SL_RESULT_UNKNOWN_ERROR: return MA_ERROR; - case SL_RESULT_OPERATION_ABORTED: return MA_ERROR; - case SL_RESULT_CONTROL_LOST: return MA_ERROR; - default: return MA_ERROR; - } -} - -/* Converts an individual OpenSL-style channel identifier (SL_SPEAKER_FRONT_LEFT, etc.) to miniaudio. */ -static ma_uint8 ma_channel_id_to_ma__opensl(SLuint32 id) -{ - switch (id) - { - case SL_SPEAKER_FRONT_LEFT: return MA_CHANNEL_FRONT_LEFT; - case SL_SPEAKER_FRONT_RIGHT: return MA_CHANNEL_FRONT_RIGHT; - case SL_SPEAKER_FRONT_CENTER: return MA_CHANNEL_FRONT_CENTER; - case SL_SPEAKER_LOW_FREQUENCY: return MA_CHANNEL_LFE; - case SL_SPEAKER_BACK_LEFT: return MA_CHANNEL_BACK_LEFT; - case SL_SPEAKER_BACK_RIGHT: return MA_CHANNEL_BACK_RIGHT; - case SL_SPEAKER_FRONT_LEFT_OF_CENTER: return MA_CHANNEL_FRONT_LEFT_CENTER; - case SL_SPEAKER_FRONT_RIGHT_OF_CENTER: return MA_CHANNEL_FRONT_RIGHT_CENTER; - case SL_SPEAKER_BACK_CENTER: return MA_CHANNEL_BACK_CENTER; - case SL_SPEAKER_SIDE_LEFT: return MA_CHANNEL_SIDE_LEFT; - case SL_SPEAKER_SIDE_RIGHT: return MA_CHANNEL_SIDE_RIGHT; - case SL_SPEAKER_TOP_CENTER: return MA_CHANNEL_TOP_CENTER; - case SL_SPEAKER_TOP_FRONT_LEFT: return MA_CHANNEL_TOP_FRONT_LEFT; - case SL_SPEAKER_TOP_FRONT_CENTER: return MA_CHANNEL_TOP_FRONT_CENTER; - case SL_SPEAKER_TOP_FRONT_RIGHT: return MA_CHANNEL_TOP_FRONT_RIGHT; - case SL_SPEAKER_TOP_BACK_LEFT: return MA_CHANNEL_TOP_BACK_LEFT; - case SL_SPEAKER_TOP_BACK_CENTER: return MA_CHANNEL_TOP_BACK_CENTER; - case SL_SPEAKER_TOP_BACK_RIGHT: return MA_CHANNEL_TOP_BACK_RIGHT; - default: return 0; - } -} - -/* Converts an individual miniaudio channel identifier (MA_CHANNEL_FRONT_LEFT, etc.) to OpenSL-style. */ -static SLuint32 ma_channel_id_to_opensl(ma_uint8 id) -{ - switch (id) - { - case MA_CHANNEL_MONO: return SL_SPEAKER_FRONT_CENTER; - case MA_CHANNEL_FRONT_LEFT: return SL_SPEAKER_FRONT_LEFT; - case MA_CHANNEL_FRONT_RIGHT: return SL_SPEAKER_FRONT_RIGHT; - case MA_CHANNEL_FRONT_CENTER: return SL_SPEAKER_FRONT_CENTER; - case MA_CHANNEL_LFE: return SL_SPEAKER_LOW_FREQUENCY; - case MA_CHANNEL_BACK_LEFT: return SL_SPEAKER_BACK_LEFT; - case MA_CHANNEL_BACK_RIGHT: return SL_SPEAKER_BACK_RIGHT; - case MA_CHANNEL_FRONT_LEFT_CENTER: return SL_SPEAKER_FRONT_LEFT_OF_CENTER; - case MA_CHANNEL_FRONT_RIGHT_CENTER: return SL_SPEAKER_FRONT_RIGHT_OF_CENTER; - case MA_CHANNEL_BACK_CENTER: return SL_SPEAKER_BACK_CENTER; - case MA_CHANNEL_SIDE_LEFT: return SL_SPEAKER_SIDE_LEFT; - case MA_CHANNEL_SIDE_RIGHT: return SL_SPEAKER_SIDE_RIGHT; - case MA_CHANNEL_TOP_CENTER: return SL_SPEAKER_TOP_CENTER; - case MA_CHANNEL_TOP_FRONT_LEFT: return SL_SPEAKER_TOP_FRONT_LEFT; - case MA_CHANNEL_TOP_FRONT_CENTER: return SL_SPEAKER_TOP_FRONT_CENTER; - case MA_CHANNEL_TOP_FRONT_RIGHT: return SL_SPEAKER_TOP_FRONT_RIGHT; - case MA_CHANNEL_TOP_BACK_LEFT: return SL_SPEAKER_TOP_BACK_LEFT; - case MA_CHANNEL_TOP_BACK_CENTER: return SL_SPEAKER_TOP_BACK_CENTER; - case MA_CHANNEL_TOP_BACK_RIGHT: return SL_SPEAKER_TOP_BACK_RIGHT; - default: return 0; - } -} - -/* Converts a channel mapping to an OpenSL-style channel mask. */ -static SLuint32 ma_channel_map_to_channel_mask__opensl(const ma_channel* pChannelMap, ma_uint32 channels) -{ - SLuint32 channelMask = 0; - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - channelMask |= ma_channel_id_to_opensl(pChannelMap[iChannel]); - } - - return channelMask; -} - -/* Converts an OpenSL-style channel mask to a miniaudio channel map. */ -static void ma_channel_mask_to_channel_map__opensl(SLuint32 channelMask, ma_uint32 channels, ma_channel* pChannelMap) -{ - if (channels == 1 && channelMask == 0) { - pChannelMap[0] = MA_CHANNEL_MONO; - } else if (channels == 2 && channelMask == 0) { - pChannelMap[0] = MA_CHANNEL_FRONT_LEFT; - pChannelMap[1] = MA_CHANNEL_FRONT_RIGHT; - } else { - if (channels == 1 && (channelMask & SL_SPEAKER_FRONT_CENTER) != 0) { - pChannelMap[0] = MA_CHANNEL_MONO; - } else { - /* Just iterate over each bit. */ - ma_uint32 iChannel = 0; - ma_uint32 iBit; - for (iBit = 0; iBit < 32 && iChannel < channels; ++iBit) { - SLuint32 bitValue = (channelMask & (1UL << iBit)); - if (bitValue != 0) { - /* The bit is set. */ - pChannelMap[iChannel] = ma_channel_id_to_ma__opensl(bitValue); - iChannel += 1; - } - } - } - } -} - -static SLuint32 ma_round_to_standard_sample_rate__opensl(SLuint32 samplesPerSec) -{ - if (samplesPerSec <= SL_SAMPLINGRATE_8) { - return SL_SAMPLINGRATE_8; - } - if (samplesPerSec <= SL_SAMPLINGRATE_11_025) { - return SL_SAMPLINGRATE_11_025; - } - if (samplesPerSec <= SL_SAMPLINGRATE_12) { - return SL_SAMPLINGRATE_12; - } - if (samplesPerSec <= SL_SAMPLINGRATE_16) { - return SL_SAMPLINGRATE_16; - } - if (samplesPerSec <= SL_SAMPLINGRATE_22_05) { - return SL_SAMPLINGRATE_22_05; - } - if (samplesPerSec <= SL_SAMPLINGRATE_24) { - return SL_SAMPLINGRATE_24; - } - if (samplesPerSec <= SL_SAMPLINGRATE_32) { - return SL_SAMPLINGRATE_32; - } - if (samplesPerSec <= SL_SAMPLINGRATE_44_1) { - return SL_SAMPLINGRATE_44_1; - } - if (samplesPerSec <= SL_SAMPLINGRATE_48) { - return SL_SAMPLINGRATE_48; - } - - /* Android doesn't support more than 48000. */ -#ifndef MA_ANDROID - if (samplesPerSec <= SL_SAMPLINGRATE_64) { - return SL_SAMPLINGRATE_64; - } - if (samplesPerSec <= SL_SAMPLINGRATE_88_2) { - return SL_SAMPLINGRATE_88_2; - } - if (samplesPerSec <= SL_SAMPLINGRATE_96) { - return SL_SAMPLINGRATE_96; - } - if (samplesPerSec <= SL_SAMPLINGRATE_192) { - return SL_SAMPLINGRATE_192; - } -#endif - - return SL_SAMPLINGRATE_16; -} - - -static SLint32 ma_to_stream_type__opensl(ma_opensl_stream_type streamType) -{ - switch (streamType) { - case ma_opensl_stream_type_voice: return SL_ANDROID_STREAM_VOICE; - case ma_opensl_stream_type_system: return SL_ANDROID_STREAM_SYSTEM; - case ma_opensl_stream_type_ring: return SL_ANDROID_STREAM_RING; - case ma_opensl_stream_type_media: return SL_ANDROID_STREAM_MEDIA; - case ma_opensl_stream_type_alarm: return SL_ANDROID_STREAM_ALARM; - case ma_opensl_stream_type_notification: return SL_ANDROID_STREAM_NOTIFICATION; - default: break; - } - - return SL_ANDROID_STREAM_VOICE; -} - -static SLint32 ma_to_recording_preset__opensl(ma_opensl_recording_preset recordingPreset) -{ - switch (recordingPreset) { - case ma_opensl_recording_preset_generic: return SL_ANDROID_RECORDING_PRESET_GENERIC; - case ma_opensl_recording_preset_camcorder: return SL_ANDROID_RECORDING_PRESET_CAMCORDER; - case ma_opensl_recording_preset_voice_recognition: return SL_ANDROID_RECORDING_PRESET_VOICE_RECOGNITION; - case ma_opensl_recording_preset_voice_communication: return SL_ANDROID_RECORDING_PRESET_VOICE_COMMUNICATION; - case ma_opensl_recording_preset_voice_unprocessed: return SL_ANDROID_RECORDING_PRESET_UNPROCESSED; - default: break; - } - - return SL_ANDROID_RECORDING_PRESET_NONE; -} - - -static ma_result ma_context_enumerate_devices__opensl(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_bool32 cbResult; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - MA_ASSERT(g_maOpenSLInitCounter > 0); /* <-- If you trigger this it means you've either not initialized the context, or you've uninitialized it and then attempted to enumerate devices. */ - if (g_maOpenSLInitCounter == 0) { - return MA_INVALID_OPERATION; - } - - /* - TODO: Test Me. - - This is currently untested, so for now we are just returning default devices. - */ -#if 0 && !defined(MA_ANDROID) - ma_bool32 isTerminated = MA_FALSE; - - SLuint32 pDeviceIDs[128]; - SLint32 deviceCount = sizeof(pDeviceIDs) / sizeof(pDeviceIDs[0]); - - SLAudioIODeviceCapabilitiesItf deviceCaps; - SLresult resultSL = (*g_maEngineObjectSL)->GetInterface(g_maEngineObjectSL, (SLInterfaceID)pContext->opensl.SL_IID_AUDIOIODEVICECAPABILITIES, &deviceCaps); - if (resultSL != SL_RESULT_SUCCESS) { - /* The interface may not be supported so just report a default device. */ - goto return_default_device; - } - - /* Playback */ - if (!isTerminated) { - resultSL = (*deviceCaps)->GetAvailableAudioOutputs(deviceCaps, &deviceCount, pDeviceIDs); - if (resultSL != SL_RESULT_SUCCESS) { - return ma_result_from_OpenSL(resultSL); - } - - for (SLint32 iDevice = 0; iDevice < deviceCount; ++iDevice) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.opensl = pDeviceIDs[iDevice]; - - SLAudioOutputDescriptor desc; - resultSL = (*deviceCaps)->QueryAudioOutputCapabilities(deviceCaps, deviceInfo.id.opensl, &desc); - if (resultSL == SL_RESULT_SUCCESS) { - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), (const char*)desc.pDeviceName, (size_t)-1); - - ma_bool32 cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - if (cbResult == MA_FALSE) { - isTerminated = MA_TRUE; - break; - } - } - } - } - - /* Capture */ - if (!isTerminated) { - resultSL = (*deviceCaps)->GetAvailableAudioInputs(deviceCaps, &deviceCount, pDeviceIDs); - if (resultSL != SL_RESULT_SUCCESS) { - return ma_result_from_OpenSL(resultSL); - } - - for (SLint32 iDevice = 0; iDevice < deviceCount; ++iDevice) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.opensl = pDeviceIDs[iDevice]; - - SLAudioInputDescriptor desc; - resultSL = (*deviceCaps)->QueryAudioInputCapabilities(deviceCaps, deviceInfo.id.opensl, &desc); - if (resultSL == SL_RESULT_SUCCESS) { - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), (const char*)desc.deviceName, (size_t)-1); - - ma_bool32 cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - if (cbResult == MA_FALSE) { - isTerminated = MA_TRUE; - break; - } - } - } - } - - return MA_SUCCESS; -#else - goto return_default_device; -#endif - -return_default_device:; - cbResult = MA_TRUE; - - /* Playback. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.opensl = SL_DEFAULTDEVICEID_AUDIOOUTPUT; - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - - /* Capture. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - deviceInfo.id.opensl = SL_DEFAULTDEVICEID_AUDIOINPUT; - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - - return MA_SUCCESS; -} - -static void ma_context_add_data_format_ex__opensl(ma_context* pContext, ma_format format, ma_uint32 channels, ma_uint32 sampleRate, ma_device_info* pDeviceInfo) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].format = format; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].channels = channels; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].sampleRate = sampleRate; - pDeviceInfo->nativeDataFormats[pDeviceInfo->nativeDataFormatCount].flags = 0; - pDeviceInfo->nativeDataFormatCount += 1; -} - -static void ma_context_add_data_format__opensl(ma_context* pContext, ma_format format, ma_device_info* pDeviceInfo) -{ - ma_uint32 minChannels = 1; - ma_uint32 maxChannels = 2; - ma_uint32 minSampleRate = (ma_uint32)ma_standard_sample_rate_8000; - ma_uint32 maxSampleRate = (ma_uint32)ma_standard_sample_rate_48000; - ma_uint32 iChannel; - ma_uint32 iSampleRate; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(pDeviceInfo != NULL); - - /* - Each sample format can support mono and stereo, and we'll support a small subset of standard - rates (up to 48000). A better solution would be to somehow find a native sample rate. - */ - for (iChannel = minChannels; iChannel < maxChannels; iChannel += 1) { - for (iSampleRate = 0; iSampleRate < ma_countof(g_maStandardSampleRatePriorities); iSampleRate += 1) { - ma_uint32 standardSampleRate = g_maStandardSampleRatePriorities[iSampleRate]; - if (standardSampleRate >= minSampleRate && standardSampleRate <= maxSampleRate) { - ma_context_add_data_format_ex__opensl(pContext, format, iChannel, standardSampleRate, pDeviceInfo); - } - } - } -} - -static ma_result ma_context_get_device_info__opensl(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - MA_ASSERT(pContext != NULL); - - MA_ASSERT(g_maOpenSLInitCounter > 0); /* <-- If you trigger this it means you've either not initialized the context, or you've uninitialized it and then attempted to get device info. */ - if (g_maOpenSLInitCounter == 0) { - return MA_INVALID_OPERATION; - } - - /* - TODO: Test Me. - - This is currently untested, so for now we are just returning default devices. - */ -#if 0 && !defined(MA_ANDROID) - SLAudioIODeviceCapabilitiesItf deviceCaps; - SLresult resultSL = (*g_maEngineObjectSL)->GetInterface(g_maEngineObjectSL, (SLInterfaceID)pContext->opensl.SL_IID_AUDIOIODEVICECAPABILITIES, &deviceCaps); - if (resultSL != SL_RESULT_SUCCESS) { - /* The interface may not be supported so just report a default device. */ - goto return_default_device; - } - - if (deviceType == ma_device_type_playback) { - SLAudioOutputDescriptor desc; - resultSL = (*deviceCaps)->QueryAudioOutputCapabilities(deviceCaps, pDeviceID->opensl, &desc); - if (resultSL != SL_RESULT_SUCCESS) { - return ma_result_from_OpenSL(resultSL); - } - - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), (const char*)desc.pDeviceName, (size_t)-1); - } else { - SLAudioInputDescriptor desc; - resultSL = (*deviceCaps)->QueryAudioInputCapabilities(deviceCaps, pDeviceID->opensl, &desc); - if (resultSL != SL_RESULT_SUCCESS) { - return ma_result_from_OpenSL(resultSL); - } - - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), (const char*)desc.deviceName, (size_t)-1); - } - - goto return_detailed_info; -#else - goto return_default_device; -#endif - -return_default_device: - if (pDeviceID != NULL) { - if ((deviceType == ma_device_type_playback && pDeviceID->opensl != SL_DEFAULTDEVICEID_AUDIOOUTPUT) || - (deviceType == ma_device_type_capture && pDeviceID->opensl != SL_DEFAULTDEVICEID_AUDIOINPUT)) { - return MA_NO_DEVICE; /* Don't know the device. */ - } - } - - /* ID and Name / Description */ - if (deviceType == ma_device_type_playback) { - pDeviceInfo->id.opensl = SL_DEFAULTDEVICEID_AUDIOOUTPUT; - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - pDeviceInfo->id.opensl = SL_DEFAULTDEVICEID_AUDIOINPUT; - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - pDeviceInfo->isDefault = MA_TRUE; - - goto return_detailed_info; - - -return_detailed_info: - - /* - For now we're just outputting a set of values that are supported by the API but not necessarily supported - by the device natively. Later on we should work on this so that it more closely reflects the device's - actual native format. - */ - pDeviceInfo->nativeDataFormatCount = 0; -#if defined(MA_ANDROID) && __ANDROID_API__ >= 21 - ma_context_add_data_format__opensl(pContext, ma_format_f32, pDeviceInfo); -#endif - ma_context_add_data_format__opensl(pContext, ma_format_s16, pDeviceInfo); - ma_context_add_data_format__opensl(pContext, ma_format_u8, pDeviceInfo); - - return MA_SUCCESS; -} - - -#ifdef MA_ANDROID -/*void ma_buffer_queue_callback_capture__opensl_android(SLAndroidSimpleBufferQueueItf pBufferQueue, SLuint32 eventFlags, const void* pBuffer, SLuint32 bufferSize, SLuint32 dataUsed, void* pContext)*/ -static void ma_buffer_queue_callback_capture__opensl_android(SLAndroidSimpleBufferQueueItf pBufferQueue, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - size_t periodSizeInBytes; - ma_uint8* pBuffer; - SLresult resultSL; - - MA_ASSERT(pDevice != NULL); - - (void)pBufferQueue; - - /* - For now, don't do anything unless the buffer was fully processed. From what I can tell, it looks like - OpenSL|ES 1.1 improves on buffer queues to the point that we could much more intelligently handle this, - but unfortunately it looks like Android is only supporting OpenSL|ES 1.0.1 for now :( - */ - - /* Don't do anything if the device is not started. */ - if (ma_device_get_state(pDevice) != ma_device_state_started) { - return; - } - - /* Don't do anything if the device is being drained. */ - if (pDevice->opensl.isDrainingCapture) { - return; - } - - periodSizeInBytes = pDevice->capture.internalPeriodSizeInFrames * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - pBuffer = pDevice->opensl.pBufferCapture + (pDevice->opensl.currentBufferIndexCapture * periodSizeInBytes); - - ma_device_handle_backend_data_callback(pDevice, NULL, pBuffer, pDevice->capture.internalPeriodSizeInFrames); - - resultSL = MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueueCapture)->Enqueue((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueueCapture, pBuffer, periodSizeInBytes); - if (resultSL != SL_RESULT_SUCCESS) { - return; - } - - pDevice->opensl.currentBufferIndexCapture = (pDevice->opensl.currentBufferIndexCapture + 1) % pDevice->capture.internalPeriods; -} - -static void ma_buffer_queue_callback_playback__opensl_android(SLAndroidSimpleBufferQueueItf pBufferQueue, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - size_t periodSizeInBytes; - ma_uint8* pBuffer; - SLresult resultSL; - - MA_ASSERT(pDevice != NULL); - - (void)pBufferQueue; - - /* Don't do anything if the device is not started. */ - if (ma_device_get_state(pDevice) != ma_device_state_started) { - return; - } - - /* Don't do anything if the device is being drained. */ - if (pDevice->opensl.isDrainingPlayback) { - return; - } - - periodSizeInBytes = pDevice->playback.internalPeriodSizeInFrames * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - pBuffer = pDevice->opensl.pBufferPlayback + (pDevice->opensl.currentBufferIndexPlayback * periodSizeInBytes); - - ma_device_handle_backend_data_callback(pDevice, pBuffer, NULL, pDevice->playback.internalPeriodSizeInFrames); - - resultSL = MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueuePlayback)->Enqueue((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueuePlayback, pBuffer, periodSizeInBytes); - if (resultSL != SL_RESULT_SUCCESS) { - return; - } - - pDevice->opensl.currentBufferIndexPlayback = (pDevice->opensl.currentBufferIndexPlayback + 1) % pDevice->playback.internalPeriods; -} -#endif - -static ma_result ma_device_uninit__opensl(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - MA_ASSERT(g_maOpenSLInitCounter > 0); /* <-- If you trigger this it means you've either not initialized the context, or you've uninitialized it before uninitializing the device. */ - if (g_maOpenSLInitCounter == 0) { - return MA_INVALID_OPERATION; - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - if (pDevice->opensl.pAudioRecorderObj) { - MA_OPENSL_OBJ(pDevice->opensl.pAudioRecorderObj)->Destroy((SLObjectItf)pDevice->opensl.pAudioRecorderObj); - } - - ma_free(pDevice->opensl.pBufferCapture, &pDevice->pContext->allocationCallbacks); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - if (pDevice->opensl.pAudioPlayerObj) { - MA_OPENSL_OBJ(pDevice->opensl.pAudioPlayerObj)->Destroy((SLObjectItf)pDevice->opensl.pAudioPlayerObj); - } - if (pDevice->opensl.pOutputMixObj) { - MA_OPENSL_OBJ(pDevice->opensl.pOutputMixObj)->Destroy((SLObjectItf)pDevice->opensl.pOutputMixObj); - } - - ma_free(pDevice->opensl.pBufferPlayback, &pDevice->pContext->allocationCallbacks); - } - - return MA_SUCCESS; -} - -#if defined(MA_ANDROID) && __ANDROID_API__ >= 21 -typedef SLAndroidDataFormat_PCM_EX ma_SLDataFormat_PCM; -#else -typedef SLDataFormat_PCM ma_SLDataFormat_PCM; -#endif - -static ma_result ma_SLDataFormat_PCM_init__opensl(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, const ma_channel* channelMap, ma_SLDataFormat_PCM* pDataFormat) -{ - /* We need to convert our format/channels/rate so that they aren't set to default. */ - if (format == ma_format_unknown) { - format = MA_DEFAULT_FORMAT; - } - if (channels == 0) { - channels = MA_DEFAULT_CHANNELS; - } - if (sampleRate == 0) { - sampleRate = MA_DEFAULT_SAMPLE_RATE; - } - -#if defined(MA_ANDROID) && __ANDROID_API__ >= 21 - if (format == ma_format_f32) { - pDataFormat->formatType = SL_ANDROID_DATAFORMAT_PCM_EX; - pDataFormat->representation = SL_ANDROID_PCM_REPRESENTATION_FLOAT; - } else { - pDataFormat->formatType = SL_DATAFORMAT_PCM; - } -#else - pDataFormat->formatType = SL_DATAFORMAT_PCM; -#endif - - pDataFormat->numChannels = channels; - ((SLDataFormat_PCM*)pDataFormat)->samplesPerSec = ma_round_to_standard_sample_rate__opensl(sampleRate * 1000); /* In millihertz. Annoyingly, the sample rate variable is named differently between SLAndroidDataFormat_PCM_EX and SLDataFormat_PCM */ - pDataFormat->bitsPerSample = ma_get_bytes_per_sample(format) * 8; - pDataFormat->channelMask = ma_channel_map_to_channel_mask__opensl(channelMap, channels); - pDataFormat->endianness = (ma_is_little_endian()) ? SL_BYTEORDER_LITTLEENDIAN : SL_BYTEORDER_BIGENDIAN; - - /* - Android has a few restrictions on the format as documented here: https://developer.android.com/ndk/guides/audio/opensl-for-android.html - - Only mono and stereo is supported. - - Only u8 and s16 formats are supported. - - Maximum sample rate of 48000. - */ -#ifdef MA_ANDROID - if (pDataFormat->numChannels > 2) { - pDataFormat->numChannels = 2; - } -#if __ANDROID_API__ >= 21 - if (pDataFormat->formatType == SL_ANDROID_DATAFORMAT_PCM_EX) { - /* It's floating point. */ - MA_ASSERT(pDataFormat->representation == SL_ANDROID_PCM_REPRESENTATION_FLOAT); - if (pDataFormat->bitsPerSample > 32) { - pDataFormat->bitsPerSample = 32; - } - } else { - if (pDataFormat->bitsPerSample > 16) { - pDataFormat->bitsPerSample = 16; - } - } -#else - if (pDataFormat->bitsPerSample > 16) { - pDataFormat->bitsPerSample = 16; - } -#endif - if (((SLDataFormat_PCM*)pDataFormat)->samplesPerSec > SL_SAMPLINGRATE_48) { - ((SLDataFormat_PCM*)pDataFormat)->samplesPerSec = SL_SAMPLINGRATE_48; - } -#endif - - pDataFormat->containerSize = pDataFormat->bitsPerSample; /* Always tightly packed for now. */ - - return MA_SUCCESS; -} - -static ma_result ma_deconstruct_SLDataFormat_PCM__opensl(ma_SLDataFormat_PCM* pDataFormat, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - ma_bool32 isFloatingPoint = MA_FALSE; -#if defined(MA_ANDROID) && __ANDROID_API__ >= 21 - if (pDataFormat->formatType == SL_ANDROID_DATAFORMAT_PCM_EX) { - MA_ASSERT(pDataFormat->representation == SL_ANDROID_PCM_REPRESENTATION_FLOAT); - isFloatingPoint = MA_TRUE; - } -#endif - if (isFloatingPoint) { - if (pDataFormat->bitsPerSample == 32) { - *pFormat = ma_format_f32; - } - } else { - if (pDataFormat->bitsPerSample == 8) { - *pFormat = ma_format_u8; - } else if (pDataFormat->bitsPerSample == 16) { - *pFormat = ma_format_s16; - } else if (pDataFormat->bitsPerSample == 24) { - *pFormat = ma_format_s24; - } else if (pDataFormat->bitsPerSample == 32) { - *pFormat = ma_format_s32; - } - } - - *pChannels = pDataFormat->numChannels; - *pSampleRate = ((SLDataFormat_PCM*)pDataFormat)->samplesPerSec / 1000; - ma_channel_mask_to_channel_map__opensl(pDataFormat->channelMask, ma_min(pDataFormat->numChannels, channelMapCap), pChannelMap); - - return MA_SUCCESS; -} - -static ma_result ma_device_init__opensl(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ -#ifdef MA_ANDROID - SLDataLocator_AndroidSimpleBufferQueue queue; - SLresult resultSL; - size_t bufferSizeInBytes; - SLInterfaceID itfIDs[2]; - const SLboolean itfIDsRequired[] = { - SL_BOOLEAN_TRUE, /* SL_IID_ANDROIDSIMPLEBUFFERQUEUE */ - SL_BOOLEAN_FALSE /* SL_IID_ANDROIDCONFIGURATION */ - }; -#endif - - MA_ASSERT(g_maOpenSLInitCounter > 0); /* <-- If you trigger this it means you've either not initialized the context, or you've uninitialized it and then attempted to initialize a new device. */ - if (g_maOpenSLInitCounter == 0) { - return MA_INVALID_OPERATION; - } - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* - For now, only supporting Android implementations of OpenSL|ES since that's the only one I've - been able to test with and I currently depend on Android-specific extensions (simple buffer - queues). - */ -#ifdef MA_ANDROID - itfIDs[0] = (SLInterfaceID)pDevice->pContext->opensl.SL_IID_ANDROIDSIMPLEBUFFERQUEUE; - itfIDs[1] = (SLInterfaceID)pDevice->pContext->opensl.SL_IID_ANDROIDCONFIGURATION; - - /* No exclusive mode with OpenSL|ES. */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->shareMode == ma_share_mode_exclusive)) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - /* Now we can start initializing the device properly. */ - MA_ASSERT(pDevice != NULL); - MA_ZERO_OBJECT(&pDevice->opensl); - - queue.locatorType = SL_DATALOCATOR_ANDROIDSIMPLEBUFFERQUEUE; - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - ma_SLDataFormat_PCM pcm; - SLDataLocator_IODevice locatorDevice; - SLDataSource source; - SLDataSink sink; - SLAndroidConfigurationItf pRecorderConfig; - - ma_SLDataFormat_PCM_init__opensl(pDescriptorCapture->format, pDescriptorCapture->channels, pDescriptorCapture->sampleRate, pDescriptorCapture->channelMap, &pcm); - - locatorDevice.locatorType = SL_DATALOCATOR_IODEVICE; - locatorDevice.deviceType = SL_IODEVICE_AUDIOINPUT; - locatorDevice.deviceID = SL_DEFAULTDEVICEID_AUDIOINPUT; /* Must always use the default device with Android. */ - locatorDevice.device = NULL; - - source.pLocator = &locatorDevice; - source.pFormat = NULL; - - queue.numBuffers = pDescriptorCapture->periodCount; - - sink.pLocator = &queue; - sink.pFormat = (SLDataFormat_PCM*)&pcm; - - resultSL = (*g_maEngineSL)->CreateAudioRecorder(g_maEngineSL, (SLObjectItf*)&pDevice->opensl.pAudioRecorderObj, &source, &sink, ma_countof(itfIDs), itfIDs, itfIDsRequired); - if (resultSL == SL_RESULT_CONTENT_UNSUPPORTED || resultSL == SL_RESULT_PARAMETER_INVALID) { - /* Unsupported format. Fall back to something safer and try again. If this fails, just abort. */ - pcm.formatType = SL_DATAFORMAT_PCM; - pcm.numChannels = 1; - ((SLDataFormat_PCM*)&pcm)->samplesPerSec = SL_SAMPLINGRATE_16; /* The name of the sample rate variable is different between SLAndroidDataFormat_PCM_EX and SLDataFormat_PCM. */ - pcm.bitsPerSample = 16; - pcm.containerSize = pcm.bitsPerSample; /* Always tightly packed for now. */ - pcm.channelMask = 0; - resultSL = (*g_maEngineSL)->CreateAudioRecorder(g_maEngineSL, (SLObjectItf*)&pDevice->opensl.pAudioRecorderObj, &source, &sink, ma_countof(itfIDs), itfIDs, itfIDsRequired); - } - - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to create audio recorder."); - return ma_result_from_OpenSL(resultSL); - } - - - /* Set the recording preset before realizing the player. */ - if (pConfig->opensl.recordingPreset != ma_opensl_recording_preset_default) { - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioRecorderObj)->GetInterface((SLObjectItf)pDevice->opensl.pAudioRecorderObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_ANDROIDCONFIGURATION, &pRecorderConfig); - if (resultSL == SL_RESULT_SUCCESS) { - SLint32 recordingPreset = ma_to_recording_preset__opensl(pConfig->opensl.recordingPreset); - resultSL = (*pRecorderConfig)->SetConfiguration(pRecorderConfig, SL_ANDROID_KEY_RECORDING_PRESET, &recordingPreset, sizeof(SLint32)); - if (resultSL != SL_RESULT_SUCCESS) { - /* Failed to set the configuration. Just keep going. */ - } - } - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioRecorderObj)->Realize((SLObjectItf)pDevice->opensl.pAudioRecorderObj, SL_BOOLEAN_FALSE); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to realize audio recorder."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioRecorderObj)->GetInterface((SLObjectItf)pDevice->opensl.pAudioRecorderObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_RECORD, &pDevice->opensl.pAudioRecorder); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to retrieve SL_IID_RECORD interface."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioRecorderObj)->GetInterface((SLObjectItf)pDevice->opensl.pAudioRecorderObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_ANDROIDSIMPLEBUFFERQUEUE, &pDevice->opensl.pBufferQueueCapture); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to retrieve SL_IID_ANDROIDSIMPLEBUFFERQUEUE interface."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueueCapture)->RegisterCallback((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueueCapture, ma_buffer_queue_callback_capture__opensl_android, pDevice); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to register buffer queue callback."); - return ma_result_from_OpenSL(resultSL); - } - - /* The internal format is determined by the "pcm" object. */ - ma_deconstruct_SLDataFormat_PCM__opensl(&pcm, &pDescriptorCapture->format, &pDescriptorCapture->channels, &pDescriptorCapture->sampleRate, pDescriptorCapture->channelMap, ma_countof(pDescriptorCapture->channelMap)); - - /* Buffer. */ - pDescriptorCapture->periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptorCapture, pDescriptorCapture->sampleRate, pConfig->performanceProfile); - pDevice->opensl.currentBufferIndexCapture = 0; - - bufferSizeInBytes = pDescriptorCapture->periodSizeInFrames * ma_get_bytes_per_frame(pDescriptorCapture->format, pDescriptorCapture->channels) * pDescriptorCapture->periodCount; - pDevice->opensl.pBufferCapture = (ma_uint8*)ma_calloc(bufferSizeInBytes, &pDevice->pContext->allocationCallbacks); - if (pDevice->opensl.pBufferCapture == NULL) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to allocate memory for data buffer."); - return MA_OUT_OF_MEMORY; - } - MA_ZERO_MEMORY(pDevice->opensl.pBufferCapture, bufferSizeInBytes); - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_SLDataFormat_PCM pcm; - SLDataSource source; - SLDataLocator_OutputMix outmixLocator; - SLDataSink sink; - SLAndroidConfigurationItf pPlayerConfig; - - ma_SLDataFormat_PCM_init__opensl(pDescriptorPlayback->format, pDescriptorPlayback->channels, pDescriptorPlayback->sampleRate, pDescriptorPlayback->channelMap, &pcm); - - resultSL = (*g_maEngineSL)->CreateOutputMix(g_maEngineSL, (SLObjectItf*)&pDevice->opensl.pOutputMixObj, 0, NULL, NULL); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to create output mix."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pOutputMixObj)->Realize((SLObjectItf)pDevice->opensl.pOutputMixObj, SL_BOOLEAN_FALSE); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to realize output mix object."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pOutputMixObj)->GetInterface((SLObjectItf)pDevice->opensl.pOutputMixObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_OUTPUTMIX, &pDevice->opensl.pOutputMix); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to retrieve SL_IID_OUTPUTMIX interface."); - return ma_result_from_OpenSL(resultSL); - } - - /* Set the output device. */ - if (pDescriptorPlayback->pDeviceID != NULL) { - SLuint32 deviceID_OpenSL = pDescriptorPlayback->pDeviceID->opensl; - MA_OPENSL_OUTPUTMIX(pDevice->opensl.pOutputMix)->ReRoute((SLOutputMixItf)pDevice->opensl.pOutputMix, 1, &deviceID_OpenSL); - } - - queue.numBuffers = pDescriptorPlayback->periodCount; - - source.pLocator = &queue; - source.pFormat = (SLDataFormat_PCM*)&pcm; - - outmixLocator.locatorType = SL_DATALOCATOR_OUTPUTMIX; - outmixLocator.outputMix = (SLObjectItf)pDevice->opensl.pOutputMixObj; - - sink.pLocator = &outmixLocator; - sink.pFormat = NULL; - - resultSL = (*g_maEngineSL)->CreateAudioPlayer(g_maEngineSL, (SLObjectItf*)&pDevice->opensl.pAudioPlayerObj, &source, &sink, ma_countof(itfIDs), itfIDs, itfIDsRequired); - if (resultSL == SL_RESULT_CONTENT_UNSUPPORTED || resultSL == SL_RESULT_PARAMETER_INVALID) { - /* Unsupported format. Fall back to something safer and try again. If this fails, just abort. */ - pcm.formatType = SL_DATAFORMAT_PCM; - pcm.numChannels = 2; - ((SLDataFormat_PCM*)&pcm)->samplesPerSec = SL_SAMPLINGRATE_16; - pcm.bitsPerSample = 16; - pcm.containerSize = pcm.bitsPerSample; /* Always tightly packed for now. */ - pcm.channelMask = SL_SPEAKER_FRONT_LEFT | SL_SPEAKER_FRONT_RIGHT; - resultSL = (*g_maEngineSL)->CreateAudioPlayer(g_maEngineSL, (SLObjectItf*)&pDevice->opensl.pAudioPlayerObj, &source, &sink, ma_countof(itfIDs), itfIDs, itfIDsRequired); - } - - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to create audio player."); - return ma_result_from_OpenSL(resultSL); - } - - - /* Set the stream type before realizing the player. */ - if (pConfig->opensl.streamType != ma_opensl_stream_type_default) { - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioPlayerObj)->GetInterface((SLObjectItf)pDevice->opensl.pAudioPlayerObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_ANDROIDCONFIGURATION, &pPlayerConfig); - if (resultSL == SL_RESULT_SUCCESS) { - SLint32 streamType = ma_to_stream_type__opensl(pConfig->opensl.streamType); - resultSL = (*pPlayerConfig)->SetConfiguration(pPlayerConfig, SL_ANDROID_KEY_STREAM_TYPE, &streamType, sizeof(SLint32)); - if (resultSL != SL_RESULT_SUCCESS) { - /* Failed to set the configuration. Just keep going. */ - } - } - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioPlayerObj)->Realize((SLObjectItf)pDevice->opensl.pAudioPlayerObj, SL_BOOLEAN_FALSE); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to realize audio player."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioPlayerObj)->GetInterface((SLObjectItf)pDevice->opensl.pAudioPlayerObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_PLAY, &pDevice->opensl.pAudioPlayer); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to retrieve SL_IID_PLAY interface."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_OBJ(pDevice->opensl.pAudioPlayerObj)->GetInterface((SLObjectItf)pDevice->opensl.pAudioPlayerObj, (SLInterfaceID)pDevice->pContext->opensl.SL_IID_ANDROIDSIMPLEBUFFERQUEUE, &pDevice->opensl.pBufferQueuePlayback); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to retrieve SL_IID_ANDROIDSIMPLEBUFFERQUEUE interface."); - return ma_result_from_OpenSL(resultSL); - } - - resultSL = MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueuePlayback)->RegisterCallback((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueuePlayback, ma_buffer_queue_callback_playback__opensl_android, pDevice); - if (resultSL != SL_RESULT_SUCCESS) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to register buffer queue callback."); - return ma_result_from_OpenSL(resultSL); - } - - /* The internal format is determined by the "pcm" object. */ - ma_deconstruct_SLDataFormat_PCM__opensl(&pcm, &pDescriptorPlayback->format, &pDescriptorPlayback->channels, &pDescriptorPlayback->sampleRate, pDescriptorPlayback->channelMap, ma_countof(pDescriptorPlayback->channelMap)); - - /* Buffer. */ - pDescriptorPlayback->periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_descriptor(pDescriptorPlayback, pDescriptorPlayback->sampleRate, pConfig->performanceProfile); - pDevice->opensl.currentBufferIndexPlayback = 0; - - bufferSizeInBytes = pDescriptorPlayback->periodSizeInFrames * ma_get_bytes_per_frame(pDescriptorPlayback->format, pDescriptorPlayback->channels) * pDescriptorPlayback->periodCount; - pDevice->opensl.pBufferPlayback = (ma_uint8*)ma_calloc(bufferSizeInBytes, &pDevice->pContext->allocationCallbacks); - if (pDevice->opensl.pBufferPlayback == NULL) { - ma_device_uninit__opensl(pDevice); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to allocate memory for data buffer."); - return MA_OUT_OF_MEMORY; - } - MA_ZERO_MEMORY(pDevice->opensl.pBufferPlayback, bufferSizeInBytes); - } - - return MA_SUCCESS; -#else - return MA_NO_BACKEND; /* Non-Android implementations are not supported. */ -#endif -} - -static ma_result ma_device_start__opensl(ma_device* pDevice) -{ - SLresult resultSL; - size_t periodSizeInBytes; - ma_uint32 iPeriod; - - MA_ASSERT(pDevice != NULL); - - MA_ASSERT(g_maOpenSLInitCounter > 0); /* <-- If you trigger this it means you've either not initialized the context, or you've uninitialized it and then attempted to start the device. */ - if (g_maOpenSLInitCounter == 0) { - return MA_INVALID_OPERATION; - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - resultSL = MA_OPENSL_RECORD(pDevice->opensl.pAudioRecorder)->SetRecordState((SLRecordItf)pDevice->opensl.pAudioRecorder, SL_RECORDSTATE_RECORDING); - if (resultSL != SL_RESULT_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to start internal capture device."); - return ma_result_from_OpenSL(resultSL); - } - - periodSizeInBytes = pDevice->capture.internalPeriodSizeInFrames * ma_get_bytes_per_frame(pDevice->capture.internalFormat, pDevice->capture.internalChannels); - for (iPeriod = 0; iPeriod < pDevice->capture.internalPeriods; ++iPeriod) { - resultSL = MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueueCapture)->Enqueue((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueueCapture, pDevice->opensl.pBufferCapture + (periodSizeInBytes * iPeriod), periodSizeInBytes); - if (resultSL != SL_RESULT_SUCCESS) { - MA_OPENSL_RECORD(pDevice->opensl.pAudioRecorder)->SetRecordState((SLRecordItf)pDevice->opensl.pAudioRecorder, SL_RECORDSTATE_STOPPED); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to enqueue buffer for capture device."); - return ma_result_from_OpenSL(resultSL); - } - } - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - resultSL = MA_OPENSL_PLAY(pDevice->opensl.pAudioPlayer)->SetPlayState((SLPlayItf)pDevice->opensl.pAudioPlayer, SL_PLAYSTATE_PLAYING); - if (resultSL != SL_RESULT_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to start internal playback device."); - return ma_result_from_OpenSL(resultSL); - } - - /* In playback mode (no duplex) we need to load some initial buffers. In duplex mode we need to enqueu silent buffers. */ - if (pDevice->type == ma_device_type_duplex) { - MA_ZERO_MEMORY(pDevice->opensl.pBufferPlayback, pDevice->playback.internalPeriodSizeInFrames * pDevice->playback.internalPeriods * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels)); - } else { - ma_device__read_frames_from_client(pDevice, pDevice->playback.internalPeriodSizeInFrames * pDevice->playback.internalPeriods, pDevice->opensl.pBufferPlayback); - } - - periodSizeInBytes = pDevice->playback.internalPeriodSizeInFrames * ma_get_bytes_per_frame(pDevice->playback.internalFormat, pDevice->playback.internalChannels); - for (iPeriod = 0; iPeriod < pDevice->playback.internalPeriods; ++iPeriod) { - resultSL = MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueuePlayback)->Enqueue((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueuePlayback, pDevice->opensl.pBufferPlayback + (periodSizeInBytes * iPeriod), periodSizeInBytes); - if (resultSL != SL_RESULT_SUCCESS) { - MA_OPENSL_PLAY(pDevice->opensl.pAudioPlayer)->SetPlayState((SLPlayItf)pDevice->opensl.pAudioPlayer, SL_PLAYSTATE_STOPPED); - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to enqueue buffer for playback device."); - return ma_result_from_OpenSL(resultSL); - } - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_drain__opensl(ma_device* pDevice, ma_device_type deviceType) -{ - SLAndroidSimpleBufferQueueItf pBufferQueue; - - MA_ASSERT(deviceType == ma_device_type_capture || deviceType == ma_device_type_playback); - - if (pDevice->type == ma_device_type_capture) { - pBufferQueue = (SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueueCapture; - pDevice->opensl.isDrainingCapture = MA_TRUE; - } else { - pBufferQueue = (SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueuePlayback; - pDevice->opensl.isDrainingPlayback = MA_TRUE; - } - - for (;;) { - SLAndroidSimpleBufferQueueState state; - - MA_OPENSL_BUFFERQUEUE(pBufferQueue)->GetState(pBufferQueue, &state); - if (state.count == 0) { - break; - } - - ma_sleep(10); - } - - if (pDevice->type == ma_device_type_capture) { - pDevice->opensl.isDrainingCapture = MA_FALSE; - } else { - pDevice->opensl.isDrainingPlayback = MA_FALSE; - } - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__opensl(ma_device* pDevice) -{ - SLresult resultSL; - - MA_ASSERT(pDevice != NULL); - - MA_ASSERT(g_maOpenSLInitCounter > 0); /* <-- If you trigger this it means you've either not initialized the context, or you've uninitialized it before stopping/uninitializing the device. */ - if (g_maOpenSLInitCounter == 0) { - return MA_INVALID_OPERATION; - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_device_drain__opensl(pDevice, ma_device_type_capture); - - resultSL = MA_OPENSL_RECORD(pDevice->opensl.pAudioRecorder)->SetRecordState((SLRecordItf)pDevice->opensl.pAudioRecorder, SL_RECORDSTATE_STOPPED); - if (resultSL != SL_RESULT_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to stop internal capture device."); - return ma_result_from_OpenSL(resultSL); - } - - MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueueCapture)->Clear((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueueCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_device_drain__opensl(pDevice, ma_device_type_playback); - - resultSL = MA_OPENSL_PLAY(pDevice->opensl.pAudioPlayer)->SetPlayState((SLPlayItf)pDevice->opensl.pAudioPlayer, SL_PLAYSTATE_STOPPED); - if (resultSL != SL_RESULT_SUCCESS) { - ma_log_post(ma_device_get_log(pDevice), MA_LOG_LEVEL_ERROR, "[OpenSL] Failed to stop internal playback device."); - return ma_result_from_OpenSL(resultSL); - } - - MA_OPENSL_BUFFERQUEUE(pDevice->opensl.pBufferQueuePlayback)->Clear((SLAndroidSimpleBufferQueueItf)pDevice->opensl.pBufferQueuePlayback); - } - - /* Make sure the client is aware that the device has stopped. There may be an OpenSL|ES callback for this, but I haven't found it. */ - ma_device__on_notification_stopped(pDevice); - - return MA_SUCCESS; -} - - -static ma_result ma_context_uninit__opensl(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_opensl); - (void)pContext; - - /* Uninit global data. */ - ma_spinlock_lock(&g_maOpenSLSpinlock); - { - MA_ASSERT(g_maOpenSLInitCounter > 0); /* If you've triggered this, it means you have ma_context_init/uninit mismatch. Each successful call to ma_context_init() must be matched up with a call to ma_context_uninit(). */ - - g_maOpenSLInitCounter -= 1; - if (g_maOpenSLInitCounter == 0) { - (*g_maEngineObjectSL)->Destroy(g_maEngineObjectSL); - } - } - ma_spinlock_unlock(&g_maOpenSLSpinlock); - - return MA_SUCCESS; -} - -static ma_result ma_dlsym_SLInterfaceID__opensl(ma_context* pContext, const char* pName, ma_handle* pHandle) -{ - /* We need to return an error if the symbol cannot be found. This is important because there have been reports that some symbols do not exist. */ - ma_handle* p = (ma_handle*)ma_dlsym(pContext, pContext->opensl.libOpenSLES, pName); - if (p == NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_INFO, "[OpenSL] Cannot find symbol %s", pName); - return MA_NO_BACKEND; - } - - *pHandle = *p; - return MA_SUCCESS; -} - -static ma_result ma_context_init_engine_nolock__opensl(ma_context* pContext) -{ - g_maOpenSLInitCounter += 1; - if (g_maOpenSLInitCounter == 1) { - SLresult resultSL; - - resultSL = ((ma_slCreateEngine_proc)pContext->opensl.slCreateEngine)(&g_maEngineObjectSL, 0, NULL, 0, NULL, NULL); - if (resultSL != SL_RESULT_SUCCESS) { - g_maOpenSLInitCounter -= 1; - return ma_result_from_OpenSL(resultSL); - } - - (*g_maEngineObjectSL)->Realize(g_maEngineObjectSL, SL_BOOLEAN_FALSE); - - resultSL = (*g_maEngineObjectSL)->GetInterface(g_maEngineObjectSL, (SLInterfaceID)pContext->opensl.SL_IID_ENGINE, &g_maEngineSL); - if (resultSL != SL_RESULT_SUCCESS) { - (*g_maEngineObjectSL)->Destroy(g_maEngineObjectSL); - g_maOpenSLInitCounter -= 1; - return ma_result_from_OpenSL(resultSL); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_context_init__opensl(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - ma_result result; - -#if !defined(MA_NO_RUNTIME_LINKING) - size_t i; - const char* libOpenSLESNames[] = { - "libOpenSLES.so" - }; -#endif - - MA_ASSERT(pContext != NULL); - - (void)pConfig; - -#if !defined(MA_NO_RUNTIME_LINKING) - /* - Dynamically link against libOpenSLES.so. I have now had multiple reports that SL_IID_ANDROIDSIMPLEBUFFERQUEUE cannot be found. One - report was happening at compile time and another at runtime. To try working around this, I'm going to link to libOpenSLES at runtime - and extract the symbols rather than reference them directly. This should, hopefully, fix these issues as the compiler won't see any - references to the symbols and will hopefully skip the checks. - */ - for (i = 0; i < ma_countof(libOpenSLESNames); i += 1) { - pContext->opensl.libOpenSLES = ma_dlopen(pContext, libOpenSLESNames[i]); - if (pContext->opensl.libOpenSLES != NULL) { - break; - } - } - - if (pContext->opensl.libOpenSLES == NULL) { - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_INFO, "[OpenSL] Could not find libOpenSLES.so"); - return MA_NO_BACKEND; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_ENGINE", &pContext->opensl.SL_IID_ENGINE); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_AUDIOIODEVICECAPABILITIES", &pContext->opensl.SL_IID_AUDIOIODEVICECAPABILITIES); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_ANDROIDSIMPLEBUFFERQUEUE", &pContext->opensl.SL_IID_ANDROIDSIMPLEBUFFERQUEUE); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_RECORD", &pContext->opensl.SL_IID_RECORD); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_PLAY", &pContext->opensl.SL_IID_PLAY); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_OUTPUTMIX", &pContext->opensl.SL_IID_OUTPUTMIX); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - result = ma_dlsym_SLInterfaceID__opensl(pContext, "SL_IID_ANDROIDCONFIGURATION", &pContext->opensl.SL_IID_ANDROIDCONFIGURATION); - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - return result; - } - - pContext->opensl.slCreateEngine = (ma_proc)ma_dlsym(pContext, pContext->opensl.libOpenSLES, "slCreateEngine"); - if (pContext->opensl.slCreateEngine == NULL) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_INFO, "[OpenSL] Cannot find symbol slCreateEngine."); - return MA_NO_BACKEND; - } -#else - pContext->opensl.SL_IID_ENGINE = (ma_handle)SL_IID_ENGINE; - pContext->opensl.SL_IID_AUDIOIODEVICECAPABILITIES = (ma_handle)SL_IID_AUDIOIODEVICECAPABILITIES; - pContext->opensl.SL_IID_ANDROIDSIMPLEBUFFERQUEUE = (ma_handle)SL_IID_ANDROIDSIMPLEBUFFERQUEUE; - pContext->opensl.SL_IID_RECORD = (ma_handle)SL_IID_RECORD; - pContext->opensl.SL_IID_PLAY = (ma_handle)SL_IID_PLAY; - pContext->opensl.SL_IID_OUTPUTMIX = (ma_handle)SL_IID_OUTPUTMIX; - pContext->opensl.SL_IID_ANDROIDCONFIGURATION = (ma_handle)SL_IID_ANDROIDCONFIGURATION; - pContext->opensl.slCreateEngine = (ma_proc)slCreateEngine; -#endif - - - /* Initialize global data first if applicable. */ - ma_spinlock_lock(&g_maOpenSLSpinlock); - { - result = ma_context_init_engine_nolock__opensl(pContext); - } - ma_spinlock_unlock(&g_maOpenSLSpinlock); - - if (result != MA_SUCCESS) { - ma_dlclose(pContext, pContext->opensl.libOpenSLES); - ma_log_post(ma_context_get_log(pContext), MA_LOG_LEVEL_INFO, "[OpenSL] Failed to initialize OpenSL engine."); - return result; - } - - pCallbacks->onContextInit = ma_context_init__opensl; - pCallbacks->onContextUninit = ma_context_uninit__opensl; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__opensl; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__opensl; - pCallbacks->onDeviceInit = ma_device_init__opensl; - pCallbacks->onDeviceUninit = ma_device_uninit__opensl; - pCallbacks->onDeviceStart = ma_device_start__opensl; - pCallbacks->onDeviceStop = ma_device_stop__opensl; - pCallbacks->onDeviceRead = NULL; /* Not needed because OpenSL|ES is asynchronous. */ - pCallbacks->onDeviceWrite = NULL; /* Not needed because OpenSL|ES is asynchronous. */ - pCallbacks->onDeviceDataLoop = NULL; /* Not needed because OpenSL|ES is asynchronous. */ - - return MA_SUCCESS; -} -#endif /* OpenSL|ES */ - - -/****************************************************************************** - -Web Audio Backend - -******************************************************************************/ -#ifdef MA_HAS_WEBAUDIO -#include - -#if (__EMSCRIPTEN_major__ > 3) || (__EMSCRIPTEN_major__ == 3 && (__EMSCRIPTEN_minor__ > 1 || (__EMSCRIPTEN_minor__ == 1 && __EMSCRIPTEN_tiny__ >= 32))) - #include - #define MA_SUPPORT_AUDIO_WORKLETS -#endif - -/* -TODO: Version 0.12: Swap this logic around so that AudioWorklets are used by default. Add MA_NO_AUDIO_WORKLETS. -*/ -#if defined(MA_ENABLE_AUDIO_WORKLETS) && defined(MA_SUPPORT_AUDIO_WORKLETS) - #define MA_USE_AUDIO_WORKLETS -#endif - -/* The thread stack size must be a multiple of 16. */ -#ifndef MA_AUDIO_WORKLETS_THREAD_STACK_SIZE -#define MA_AUDIO_WORKLETS_THREAD_STACK_SIZE 16384 -#endif - -#if defined(MA_USE_AUDIO_WORKLETS) -#define MA_WEBAUDIO_LATENCY_HINT_BALANCED "balanced" -#define MA_WEBAUDIO_LATENCY_HINT_INTERACTIVE "interactive" -#define MA_WEBAUDIO_LATENCY_HINT_PLAYBACK "playback" -#endif - -static ma_bool32 ma_is_capture_supported__webaudio() -{ - return EM_ASM_INT({ - return (navigator.mediaDevices !== undefined && navigator.mediaDevices.getUserMedia !== undefined); - }, 0) != 0; /* Must pass in a dummy argument for C99 compatibility. */ -} - -#ifdef __cplusplus -extern "C" { -#endif -void* EMSCRIPTEN_KEEPALIVE ma_malloc_emscripten(size_t sz, const ma_allocation_callbacks* pAllocationCallbacks) -{ - return ma_malloc(sz, pAllocationCallbacks); -} - -void EMSCRIPTEN_KEEPALIVE ma_free_emscripten(void* p, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_free(p, pAllocationCallbacks); -} - -void EMSCRIPTEN_KEEPALIVE ma_device_process_pcm_frames_capture__webaudio(ma_device* pDevice, int frameCount, float* pFrames) -{ - ma_device_handle_backend_data_callback(pDevice, NULL, pFrames, (ma_uint32)frameCount); -} - -void EMSCRIPTEN_KEEPALIVE ma_device_process_pcm_frames_playback__webaudio(ma_device* pDevice, int frameCount, float* pFrames) -{ - ma_device_handle_backend_data_callback(pDevice, pFrames, NULL, (ma_uint32)frameCount); -} -#ifdef __cplusplus -} -#endif - -static ma_result ma_context_enumerate_devices__webaudio(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_bool32 cbResult = MA_TRUE; - - MA_ASSERT(pContext != NULL); - MA_ASSERT(callback != NULL); - - /* Only supporting default devices for now. */ - - /* Playback. */ - if (cbResult) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - deviceInfo.isDefault = MA_TRUE; /* Only supporting default devices. */ - cbResult = callback(pContext, ma_device_type_playback, &deviceInfo, pUserData); - } - - /* Capture. */ - if (cbResult) { - if (ma_is_capture_supported__webaudio()) { - ma_device_info deviceInfo; - MA_ZERO_OBJECT(&deviceInfo); - ma_strncpy_s(deviceInfo.name, sizeof(deviceInfo.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - deviceInfo.isDefault = MA_TRUE; /* Only supporting default devices. */ - cbResult = callback(pContext, ma_device_type_capture, &deviceInfo, pUserData); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_context_get_device_info__webaudio(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - MA_ASSERT(pContext != NULL); - - if (deviceType == ma_device_type_capture && !ma_is_capture_supported__webaudio()) { - return MA_NO_DEVICE; - } - - MA_ZERO_MEMORY(pDeviceInfo->id.webaudio, sizeof(pDeviceInfo->id.webaudio)); - - /* Only supporting default devices for now. */ - (void)pDeviceID; - if (deviceType == ma_device_type_playback) { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDeviceInfo->name, sizeof(pDeviceInfo->name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } - - /* Only supporting default devices. */ - pDeviceInfo->isDefault = MA_TRUE; - - /* Web Audio can support any number of channels and sample rates. It only supports f32 formats, however. */ - pDeviceInfo->nativeDataFormats[0].flags = 0; - pDeviceInfo->nativeDataFormats[0].format = ma_format_unknown; - pDeviceInfo->nativeDataFormats[0].channels = 0; /* All channels are supported. */ - pDeviceInfo->nativeDataFormats[0].sampleRate = EM_ASM_INT({ - try { - var temp = new (window.AudioContext || window.webkitAudioContext)(); - var sampleRate = temp.sampleRate; - temp.close(); - return sampleRate; - } catch(e) { - return 0; - } - }, 0); /* Must pass in a dummy argument for C99 compatibility. */ - - if (pDeviceInfo->nativeDataFormats[0].sampleRate == 0) { - return MA_NO_DEVICE; - } - - pDeviceInfo->nativeDataFormatCount = 1; - - return MA_SUCCESS; -} - -#if !defined(MA_USE_AUDIO_WORKLETS) -static void ma_device_uninit_by_index__webaudio(ma_device* pDevice, ma_device_type deviceType, int deviceIndex) -{ - MA_ASSERT(pDevice != NULL); - - EM_ASM({ - var device = miniaudio.get_device_by_index($0); - var pAllocationCallbacks = $3; - - /* Make sure all nodes are disconnected and marked for collection. */ - if (device.scriptNode !== undefined) { - device.scriptNode.onaudioprocess = function(e) {}; /* We want to reset the callback to ensure it doesn't get called after AudioContext.close() has returned. Shouldn't happen since we're disconnecting, but just to be safe... */ - device.scriptNode.disconnect(); - device.scriptNode = undefined; - } - if (device.streamNode !== undefined) { - device.streamNode.disconnect(); - device.streamNode = undefined; - } - - /* - Stop the device. I think there is a chance the callback could get fired after calling this, hence why we want - to clear the callback before closing. - */ - device.webaudio.close(); - device.webaudio = undefined; - - /* Can't forget to free the intermediary buffer. This is the buffer that's shared between JavaScript and C. */ - if (device.intermediaryBuffer !== undefined) { - _ma_free_emscripten(device.intermediaryBuffer, pAllocationCallbacks); - device.intermediaryBuffer = undefined; - device.intermediaryBufferView = undefined; - device.intermediaryBufferSizeInBytes = undefined; - } - - /* Make sure the device is untracked so the slot can be reused later. */ - miniaudio.untrack_device_by_index($0); - }, deviceIndex, deviceType, &pDevice->pContext->allocationCallbacks); -} -#endif - -static void ma_device_uninit_by_type__webaudio(ma_device* pDevice, ma_device_type deviceType) -{ - MA_ASSERT(pDevice != NULL); - MA_ASSERT(deviceType == ma_device_type_capture || deviceType == ma_device_type_playback); - -#if defined(MA_USE_AUDIO_WORKLETS) - if (deviceType == ma_device_type_capture) { - ma_free(pDevice->webaudio.pIntermediaryBufferCapture, &pDevice->pContext->allocationCallbacks); - ma_free(pDevice->webaudio.pStackBufferCapture, &pDevice->pContext->allocationCallbacks); - emscripten_destroy_audio_context(pDevice->webaudio.audioContextCapture); - } else { - ma_free(pDevice->webaudio.pIntermediaryBufferPlayback, &pDevice->pContext->allocationCallbacks); - ma_free(pDevice->webaudio.pStackBufferPlayback, &pDevice->pContext->allocationCallbacks); - emscripten_destroy_audio_context(pDevice->webaudio.audioContextPlayback); - } -#else - if (deviceType == ma_device_type_capture) { - ma_device_uninit_by_index__webaudio(pDevice, ma_device_type_capture, pDevice->webaudio.indexCapture); - } else { - ma_device_uninit_by_index__webaudio(pDevice, ma_device_type_playback, pDevice->webaudio.indexPlayback); - } -#endif -} - -static ma_result ma_device_uninit__webaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - ma_device_uninit_by_type__webaudio(pDevice, ma_device_type_capture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_device_uninit_by_type__webaudio(pDevice, ma_device_type_playback); - } - - return MA_SUCCESS; -} - -static ma_uint32 ma_calculate_period_size_in_frames_from_descriptor__webaudio(const ma_device_descriptor* pDescriptor, ma_uint32 nativeSampleRate, ma_performance_profile performanceProfile) -{ -#if defined(MA_USE_AUDIO_WORKLETS) - (void)pDescriptor; - (void)nativeSampleRate; - (void)performanceProfile; - - return 256; -#else - /* - There have been reports of the default buffer size being too small on some browsers. If we're using - the default buffer size, we'll make sure the period size is bigger than our standard defaults. - */ - ma_uint32 periodSizeInFrames; - - if (pDescriptor->periodSizeInFrames == 0) { - if (pDescriptor->periodSizeInMilliseconds == 0) { - if (performanceProfile == ma_performance_profile_low_latency) { - periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(33, nativeSampleRate); /* 1 frame @ 30 FPS */ - } else { - periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(333, nativeSampleRate); - } - } else { - periodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(pDescriptor->periodSizeInMilliseconds, nativeSampleRate); - } - } else { - periodSizeInFrames = pDescriptor->periodSizeInFrames; - } - - /* The size of the buffer must be a power of 2 and between 256 and 16384. */ - if (periodSizeInFrames < 256) { - periodSizeInFrames = 256; - } else if (periodSizeInFrames > 16384) { - periodSizeInFrames = 16384; - } else { - periodSizeInFrames = ma_next_power_of_2(periodSizeInFrames); - } - - return periodSizeInFrames; -#endif -} - - -#if defined(MA_USE_AUDIO_WORKLETS) -typedef struct -{ - ma_device* pDevice; - const ma_device_config* pConfig; - ma_device_descriptor* pDescriptor; - ma_device_type deviceType; - ma_uint32 channels; -} ma_audio_worklet_thread_initialized_data; - -static EM_BOOL ma_audio_worklet_process_callback__webaudio(int inputCount, const AudioSampleFrame* pInputs, int outputCount, AudioSampleFrame* pOutputs, int paramCount, const AudioParamFrame* pParams, void* pUserData) -{ - ma_device* pDevice = (ma_device*)pUserData; - ma_uint32 frameCount; - ma_uint32 framesProcessed; - - (void)paramCount; - (void)pParams; - - /* - The Emscripten documentation says that it'll always be 128 frames being passed in. Hard coding it like that feels - like a very bad idea to me. Even if it's hard coded in the backend, the API and documentation should always refer - to variables instead of a hard coded number. In any case, will follow along for the time being. - - Unfortunately the audio data is not interleaved so we'll need to convert it before we give the data to miniaudio - for further processing. - */ - frameCount = 128; - - /* Run the conversion logic in a loop for robustness. */ - framesProcessed = 0; - while (framesProcessed < frameCount) { - ma_uint32 framesToProcessThisIteration = frameCount - framesProcessed; - - if (inputCount > 0) { - if (framesToProcessThisIteration > pDevice->webaudio.intermediaryBufferSizeInFramesPlayback) { - framesToProcessThisIteration = pDevice->webaudio.intermediaryBufferSizeInFramesPlayback; - } - - /* Input data needs to be interleaved before we hand it to the client. */ - for (ma_uint32 iFrame = 0; iFrame < framesToProcessThisIteration; iFrame += 1) { - for (ma_uint32 iChannel = 0; iChannel < pDevice->capture.internalChannels; iChannel += 1) { - pDevice->webaudio.pIntermediaryBufferCapture[iFrame*pDevice->capture.internalChannels + iChannel] = pInputs[0].data[frameCount*iChannel + framesProcessed + iFrame]; - } - } - - ma_device_process_pcm_frames_capture__webaudio(pDevice, framesToProcessThisIteration, pDevice->webaudio.pIntermediaryBufferCapture); - } - - if (outputCount > 0) { - ma_device_process_pcm_frames_playback__webaudio(pDevice, framesToProcessThisIteration, pDevice->webaudio.pIntermediaryBufferPlayback); - - /* We've read the data from the client. Now we need to deinterleave the buffer and output to the output buffer. */ - for (ma_uint32 iFrame = 0; iFrame < framesToProcessThisIteration; iFrame += 1) { - for (ma_uint32 iChannel = 0; iChannel < pDevice->playback.internalChannels; iChannel += 1) { - pOutputs[0].data[frameCount*iChannel + framesProcessed + iFrame] = pDevice->webaudio.pIntermediaryBufferPlayback[iFrame*pDevice->playback.internalChannels + iChannel]; - } - } - } - - framesProcessed += framesToProcessThisIteration; - } - - return EM_TRUE; -} - - -static void ma_audio_worklet_processor_created__webaudio(EMSCRIPTEN_WEBAUDIO_T audioContext, EM_BOOL success, void* pUserData) -{ - ma_audio_worklet_thread_initialized_data* pParameters = (ma_audio_worklet_thread_initialized_data*)pUserData; - EmscriptenAudioWorkletNodeCreateOptions workletNodeOptions; - EMSCRIPTEN_AUDIO_WORKLET_NODE_T workletNode; - int outputChannelCount = 0; - - if (success == EM_FALSE) { - pParameters->pDevice->webaudio.isInitialized = MA_TRUE; - return; - } - - MA_ZERO_OBJECT(&workletNodeOptions); - - if (pParameters->deviceType == ma_device_type_capture) { - workletNodeOptions.numberOfInputs = 1; - } else { - outputChannelCount = (int)pParameters->channels; /* Safe cast. */ - - workletNodeOptions.numberOfOutputs = 1; - workletNodeOptions.outputChannelCounts = &outputChannelCount; - } - - /* Here is where we create the node that will do our processing. */ - workletNode = emscripten_create_wasm_audio_worklet_node(audioContext, "miniaudio", &workletNodeOptions, &ma_audio_worklet_process_callback__webaudio, pParameters->pDevice); - - if (pParameters->deviceType == ma_device_type_capture) { - pParameters->pDevice->webaudio.workletNodeCapture = workletNode; - } else { - pParameters->pDevice->webaudio.workletNodePlayback = workletNode; - } - - /* - With the worklet node created we can now attach it to the graph. This is done differently depending on whether or not - it's capture or playback mode. - */ - if (pParameters->deviceType == ma_device_type_capture) { - EM_ASM({ - var workletNode = emscriptenGetAudioObject($0); - var audioContext = emscriptenGetAudioObject($1); - - navigator.mediaDevices.getUserMedia({audio:true, video:false}) - .then(function(stream) { - audioContext.streamNode = audioContext.createMediaStreamSource(stream); - audioContext.streamNode.connect(workletNode); - - /* - Now that the worklet node has been connected, do we need to inspect workletNode.channelCount - to check the actual channel count, or is it safe to assume it's always 2? - */ - }) - .catch(function(error) { - - }); - }, workletNode, audioContext); - } else { - EM_ASM({ - var workletNode = emscriptenGetAudioObject($0); - var audioContext = emscriptenGetAudioObject($1); - workletNode.connect(audioContext.destination); - }, workletNode, audioContext); - } - - pParameters->pDevice->webaudio.isInitialized = MA_TRUE; - - ma_log_postf(ma_device_get_log(pParameters->pDevice), MA_LOG_LEVEL_DEBUG, "AudioWorklets: Created worklet node: %d\n", workletNode); - - /* Our parameter data is no longer needed. */ - ma_free(pParameters, &pParameters->pDevice->pContext->allocationCallbacks); -} - - - -static void ma_audio_worklet_thread_initialized__webaudio(EMSCRIPTEN_WEBAUDIO_T audioContext, EM_BOOL success, void* pUserData) -{ - ma_audio_worklet_thread_initialized_data* pParameters = (ma_audio_worklet_thread_initialized_data*)pUserData; - WebAudioWorkletProcessorCreateOptions workletProcessorOptions; - - MA_ASSERT(pParameters != NULL); - - if (success == EM_FALSE) { - pParameters->pDevice->webaudio.isInitialized = MA_TRUE; - return; - } - - MA_ZERO_OBJECT(&workletProcessorOptions); - workletProcessorOptions.name = "miniaudio"; /* I'm not entirely sure what to call this. Does this need to be globally unique, or does it need only be unique for a given AudioContext? */ - - emscripten_create_wasm_audio_worklet_processor_async(audioContext, &workletProcessorOptions, ma_audio_worklet_processor_created__webaudio, pParameters); -} -#endif - -static ma_result ma_device_init_by_type__webaudio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptor, ma_device_type deviceType) -{ -#if defined(MA_USE_AUDIO_WORKLETS) - EMSCRIPTEN_WEBAUDIO_T audioContext; - void* pStackBuffer; - size_t intermediaryBufferSizeInFrames; - float* pIntermediaryBuffer; -#endif - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint32 periodSizeInFrames; - - MA_ASSERT(pDevice != NULL); - MA_ASSERT(pConfig != NULL); - MA_ASSERT(deviceType != ma_device_type_duplex); - - if (deviceType == ma_device_type_capture && !ma_is_capture_supported__webaudio()) { - return MA_NO_DEVICE; - } - - /* We're going to calculate some stuff in C just to simplify the JS code. */ - channels = (pDescriptor->channels > 0) ? pDescriptor->channels : MA_DEFAULT_CHANNELS; - sampleRate = (pDescriptor->sampleRate > 0) ? pDescriptor->sampleRate : MA_DEFAULT_SAMPLE_RATE; - periodSizeInFrames = ma_calculate_period_size_in_frames_from_descriptor__webaudio(pDescriptor, sampleRate, pConfig->performanceProfile); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "periodSizeInFrames = %d\n", (int)periodSizeInFrames); - -#if defined(MA_USE_AUDIO_WORKLETS) - { - ma_audio_worklet_thread_initialized_data* pInitParameters; - EmscriptenWebAudioCreateAttributes audioContextAttributes; - - audioContextAttributes.latencyHint = MA_WEBAUDIO_LATENCY_HINT_INTERACTIVE; - audioContextAttributes.sampleRate = sampleRate; - - /* It's not clear if this can return an error. None of the tests in the Emscripten repository check for this, so neither am I for now. */ - audioContext = emscripten_create_audio_context(&audioContextAttributes); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "TRACE: AUDIO CONTEXT CREATED\n"); - - /* - We now need to create a worker thread. This is a bit weird because we need to allocate our - own buffer for the thread's stack. The stack needs to be aligned to 16 bytes. I'm going to - allocate this on the heap to keep it simple. - */ - pStackBuffer = ma_aligned_malloc(MA_AUDIO_WORKLETS_THREAD_STACK_SIZE, 16, &pDevice->pContext->allocationCallbacks); - if (pStackBuffer == NULL) { - emscripten_destroy_audio_context(audioContext); - return MA_OUT_OF_MEMORY; - } - - /* - We need an intermediary buffer for data conversion. WebAudio reports data in uninterleaved - format whereas we require it to be interleaved. We'll do this in chunks of 128 frames. - */ - intermediaryBufferSizeInFrames = 128; - pIntermediaryBuffer = ma_malloc(intermediaryBufferSizeInFrames * channels * sizeof(float), &pDevice->pContext->allocationCallbacks); - if (pIntermediaryBuffer == NULL) { - ma_free(pStackBuffer, &pDevice->pContext->allocationCallbacks); - emscripten_destroy_audio_context(audioContext); - return MA_OUT_OF_MEMORY; - } - - pInitParameters = ma_malloc(sizeof(*pInitParameters), &pDevice->pContext->allocationCallbacks); - if (pInitParameters == NULL) { - ma_free(pIntermediaryBuffer, &pDevice->pContext->allocationCallbacks); - ma_free(pStackBuffer, &pDevice->pContext->allocationCallbacks); - emscripten_destroy_audio_context(audioContext); - return MA_OUT_OF_MEMORY; - } - - pInitParameters->pDevice = pDevice; - pInitParameters->pConfig = pConfig; - pInitParameters->pDescriptor = pDescriptor; - pInitParameters->deviceType = deviceType; - pInitParameters->channels = channels; - - /* - We need to flag the device as not yet initialized so we can wait on it later. Unfortunately all of - the Emscripten WebAudio stuff is asynchronous. - */ - pDevice->webaudio.isInitialized = MA_FALSE; - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "TRACE: CREATING WORKLET\n"); - - emscripten_start_wasm_audio_worklet_thread_async(audioContext, pStackBuffer, MA_AUDIO_WORKLETS_THREAD_STACK_SIZE, ma_audio_worklet_thread_initialized__webaudio, pInitParameters); - - /* We must wait for initialization to complete. We're just spinning here. The emscripten_sleep() call is why we need to build with `-sASYNCIFY`. */ - while (pDevice->webaudio.isInitialized == MA_FALSE) { - emscripten_sleep(1); - } - - /* - Now that initialization is finished we can go ahead and extract our channel count so that - miniaudio can set up a data converter at a higher level. - */ - if (deviceType == ma_device_type_capture) { - /* - For capture we won't actually know what the channel count is. Everything I've seen seems - to indicate that the default channel count is 2, so I'm sticking with that. - */ - channels = 2; - } else { - /* Get the channel count from the audio context. */ - channels = (ma_uint32)EM_ASM_INT({ - return emscriptenGetAudioObject($0).destination.channelCount; - }, audioContext); - } - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_DEBUG, "TRACE: INITIALIZED. channels = %u\n", channels); - } -#else - /* We create the device on the JavaScript side and reference it using an index. We use this to make it possible to reference the device between JavaScript and C. */ - int deviceIndex = EM_ASM_INT({ - var channels = $0; - var sampleRate = $1; - var bufferSize = $2; /* In PCM frames. */ - var isCapture = $3; - var pDevice = $4; - var pAllocationCallbacks = $5; - - if (typeof(window.miniaudio) === 'undefined') { - return -1; /* Context not initialized. */ - } - - var device = {}; - - /* The AudioContext must be created in a suspended state. */ - device.webaudio = new (window.AudioContext || window.webkitAudioContext)({sampleRate:sampleRate}); - device.webaudio.suspend(); - device.state = 1; /* ma_device_state_stopped */ - - /* We need an intermediary buffer which we use for JavaScript and C interop. This buffer stores interleaved f32 PCM data. */ - device.intermediaryBufferSizeInBytes = channels * bufferSize * 4; - device.intermediaryBuffer = _ma_malloc_emscripten(device.intermediaryBufferSizeInBytes, pAllocationCallbacks); - device.intermediaryBufferView = new Float32Array(Module.HEAPF32.buffer, device.intermediaryBuffer, device.intermediaryBufferSizeInBytes); - - /* - Both playback and capture devices use a ScriptProcessorNode for performing per-sample operations. - - ScriptProcessorNode is actually deprecated so this is likely to be temporary. The way this works for playback is very simple. You just set a callback - that's periodically fired, just like a normal audio callback function. But apparently this design is "flawed" and is now deprecated in favour of - something called AudioWorklets which _forces_ you to load a _separate_ .js file at run time... nice... Hopefully ScriptProcessorNode will continue to - work for years to come, but this may need to change to use AudioSourceBufferNode instead, which I think is what Emscripten uses for it's built-in SDL - implementation. I'll be avoiding that insane AudioWorklet API like the plague... - - For capture it is a bit unintuitive. We use the ScriptProccessorNode _only_ to get the raw PCM data. It is connected to an AudioContext just like the - playback case, however we just output silence to the AudioContext instead of passing any real data. It would make more sense to me to use the - MediaRecorder API, but unfortunately you need to specify a MIME time (Opus, Vorbis, etc.) for the binary blob that's returned to the client, but I've - been unable to figure out how to get this as raw PCM. The closest I can think is to use the MIME type for WAV files and just parse it, but I don't know - how well this would work. Although ScriptProccessorNode is deprecated, in practice it seems to have pretty good browser support so I'm leaving it like - this for now. If anyone knows how I could get raw PCM data using the MediaRecorder API please let me know! - */ - device.scriptNode = device.webaudio.createScriptProcessor(bufferSize, (isCapture) ? channels : 0, (isCapture) ? 0 : channels); - - if (isCapture) { - device.scriptNode.onaudioprocess = function(e) { - if (device.intermediaryBuffer === undefined) { - return; /* This means the device has been uninitialized. */ - } - - if (device.intermediaryBufferView.length == 0) { - /* Recreate intermediaryBufferView when losing reference to the underlying buffer, probably due to emscripten resizing heap. */ - device.intermediaryBufferView = new Float32Array(Module.HEAPF32.buffer, device.intermediaryBuffer, device.intermediaryBufferSizeInBytes); - } - - /* Make sure silence it output to the AudioContext destination. Not doing this will cause sound to come out of the speakers! */ - for (var iChannel = 0; iChannel < e.outputBuffer.numberOfChannels; ++iChannel) { - e.outputBuffer.getChannelData(iChannel).fill(0.0); - } - - /* There are some situations where we may want to send silence to the client. */ - var sendSilence = false; - if (device.streamNode === undefined) { - sendSilence = true; - } - - /* Sanity check. This will never happen, right? */ - if (e.inputBuffer.numberOfChannels != channels) { - console.log("Capture: Channel count mismatch. " + e.inputBufer.numberOfChannels + " != " + channels + ". Sending silence."); - sendSilence = true; - } - - /* This looped design guards against the situation where e.inputBuffer is a different size to the original buffer size. Should never happen in practice. */ - var totalFramesProcessed = 0; - while (totalFramesProcessed < e.inputBuffer.length) { - var framesRemaining = e.inputBuffer.length - totalFramesProcessed; - var framesToProcess = framesRemaining; - if (framesToProcess > (device.intermediaryBufferSizeInBytes/channels/4)) { - framesToProcess = (device.intermediaryBufferSizeInBytes/channels/4); - } - - /* We need to do the reverse of the playback case. We need to interleave the input data and copy it into the intermediary buffer. Then we send it to the client. */ - if (sendSilence) { - device.intermediaryBufferView.fill(0.0); - } else { - for (var iFrame = 0; iFrame < framesToProcess; ++iFrame) { - for (var iChannel = 0; iChannel < e.inputBuffer.numberOfChannels; ++iChannel) { - device.intermediaryBufferView[iFrame*channels + iChannel] = e.inputBuffer.getChannelData(iChannel)[totalFramesProcessed + iFrame]; - } - } - } - - /* Send data to the client from our intermediary buffer. */ - _ma_device_process_pcm_frames_capture__webaudio(pDevice, framesToProcess, device.intermediaryBuffer); - - totalFramesProcessed += framesToProcess; - } - }; - - navigator.mediaDevices.getUserMedia({audio:true, video:false}) - .then(function(stream) { - device.streamNode = device.webaudio.createMediaStreamSource(stream); - device.streamNode.connect(device.scriptNode); - device.scriptNode.connect(device.webaudio.destination); - }) - .catch(function(error) { - /* I think this should output silence... */ - device.scriptNode.connect(device.webaudio.destination); - }); - } else { - device.scriptNode.onaudioprocess = function(e) { - if (device.intermediaryBuffer === undefined) { - return; /* This means the device has been uninitialized. */ - } - - if(device.intermediaryBufferView.length == 0) { - /* Recreate intermediaryBufferView when losing reference to the underlying buffer, probably due to emscripten resizing heap. */ - device.intermediaryBufferView = new Float32Array(Module.HEAPF32.buffer, device.intermediaryBuffer, device.intermediaryBufferSizeInBytes); - } - - var outputSilence = false; - - /* Sanity check. This will never happen, right? */ - if (e.outputBuffer.numberOfChannels != channels) { - console.log("Playback: Channel count mismatch. " + e.outputBufer.numberOfChannels + " != " + channels + ". Outputting silence."); - outputSilence = true; - return; - } - - /* This looped design guards against the situation where e.outputBuffer is a different size to the original buffer size. Should never happen in practice. */ - var totalFramesProcessed = 0; - while (totalFramesProcessed < e.outputBuffer.length) { - var framesRemaining = e.outputBuffer.length - totalFramesProcessed; - var framesToProcess = framesRemaining; - if (framesToProcess > (device.intermediaryBufferSizeInBytes/channels/4)) { - framesToProcess = (device.intermediaryBufferSizeInBytes/channels/4); - } - - /* Read data from the client into our intermediary buffer. */ - _ma_device_process_pcm_frames_playback__webaudio(pDevice, framesToProcess, device.intermediaryBuffer); - - /* At this point we'll have data in our intermediary buffer which we now need to deinterleave and copy over to the output buffers. */ - if (outputSilence) { - for (var iChannel = 0; iChannel < e.outputBuffer.numberOfChannels; ++iChannel) { - e.outputBuffer.getChannelData(iChannel).fill(0.0); - } - } else { - for (var iChannel = 0; iChannel < e.outputBuffer.numberOfChannels; ++iChannel) { - var outputBuffer = e.outputBuffer.getChannelData(iChannel); - var intermediaryBuffer = device.intermediaryBufferView; - for (var iFrame = 0; iFrame < framesToProcess; ++iFrame) { - outputBuffer[totalFramesProcessed + iFrame] = intermediaryBuffer[iFrame*channels + iChannel]; - } - } - } - - totalFramesProcessed += framesToProcess; - } - }; - - device.scriptNode.connect(device.webaudio.destination); - } - - return miniaudio.track_device(device); - }, channels, sampleRate, periodSizeInFrames, deviceType == ma_device_type_capture, pDevice, &pDevice->pContext->allocationCallbacks); - - if (deviceIndex < 0) { - return MA_FAILED_TO_OPEN_BACKEND_DEVICE; - } -#endif - -#if defined(MA_USE_AUDIO_WORKLETS) - if (deviceType == ma_device_type_capture) { - pDevice->webaudio.audioContextCapture = audioContext; - pDevice->webaudio.pStackBufferCapture = pStackBuffer; - pDevice->webaudio.intermediaryBufferSizeInFramesCapture = intermediaryBufferSizeInFrames; - pDevice->webaudio.pIntermediaryBufferCapture = pIntermediaryBuffer; - } else { - pDevice->webaudio.audioContextPlayback = audioContext; - pDevice->webaudio.pStackBufferPlayback = pStackBuffer; - pDevice->webaudio.intermediaryBufferSizeInFramesPlayback = intermediaryBufferSizeInFrames; - pDevice->webaudio.pIntermediaryBufferPlayback = pIntermediaryBuffer; - } -#else - if (deviceType == ma_device_type_capture) { - pDevice->webaudio.indexCapture = deviceIndex; - } else { - pDevice->webaudio.indexPlayback = deviceIndex; - } -#endif - - pDescriptor->format = ma_format_f32; - pDescriptor->channels = channels; - ma_channel_map_init_standard(ma_standard_channel_map_webaudio, pDescriptor->channelMap, ma_countof(pDescriptor->channelMap), pDescriptor->channels); - pDescriptor->periodSizeInFrames = periodSizeInFrames; - pDescriptor->periodCount = 1; - -#if defined(MA_USE_AUDIO_WORKLETS) - pDescriptor->sampleRate = sampleRate; /* Is this good enough to be used in the general case? */ -#else - pDescriptor->sampleRate = EM_ASM_INT({ return miniaudio.get_device_by_index($0).webaudio.sampleRate; }, deviceIndex); -#endif - - return MA_SUCCESS; -} - -static ma_result ma_device_init__webaudio(ma_device* pDevice, const ma_device_config* pConfig, ma_device_descriptor* pDescriptorPlayback, ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - - if (pConfig->deviceType == ma_device_type_loopback) { - return MA_DEVICE_TYPE_NOT_SUPPORTED; - } - - /* No exclusive mode with Web Audio. */ - if (((pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) && pDescriptorPlayback->shareMode == ma_share_mode_exclusive) || - ((pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) && pDescriptorCapture->shareMode == ma_share_mode_exclusive)) { - return MA_SHARE_MODE_NOT_SUPPORTED; - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - result = ma_device_init_by_type__webaudio(pDevice, pConfig, pDescriptorCapture, ma_device_type_capture); - if (result != MA_SUCCESS) { - return result; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - result = ma_device_init_by_type__webaudio(pDevice, pConfig, pDescriptorPlayback, ma_device_type_playback); - if (result != MA_SUCCESS) { - if (pConfig->deviceType == ma_device_type_duplex) { - ma_device_uninit_by_type__webaudio(pDevice, ma_device_type_capture); - } - return result; - } - } - - return MA_SUCCESS; -} - -static ma_result ma_device_start__webaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - -#if defined(MA_USE_AUDIO_WORKLETS) - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - emscripten_resume_audio_context_sync(pDevice->webaudio.audioContextCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - emscripten_resume_audio_context_sync(pDevice->webaudio.audioContextPlayback); - } -#else - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - EM_ASM({ - var device = miniaudio.get_device_by_index($0); - device.webaudio.resume(); - device.state = 2; /* ma_device_state_started */ - }, pDevice->webaudio.indexCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - EM_ASM({ - var device = miniaudio.get_device_by_index($0); - device.webaudio.resume(); - device.state = 2; /* ma_device_state_started */ - }, pDevice->webaudio.indexPlayback); - } -#endif - - return MA_SUCCESS; -} - -static ma_result ma_device_stop__webaudio(ma_device* pDevice) -{ - MA_ASSERT(pDevice != NULL); - - /* - From the WebAudio API documentation for AudioContext.suspend(): - - Suspends the progression of AudioContext's currentTime, allows any current context processing blocks that are already processed to be played to the - destination, and then allows the system to release its claim on audio hardware. - - I read this to mean that "any current context processing blocks" are processed by suspend() - i.e. They they are drained. We therefore shouldn't need to - do any kind of explicit draining. - */ - -#if defined(MA_USE_AUDIO_WORKLETS) - /* I can't seem to find a way to suspend an AudioContext via the C Emscripten API. Is this an oversight? */ - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - EM_ASM({ - emscriptenGetAudioObject($0).suspend(); - }, pDevice->webaudio.audioContextCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - EM_ASM({ - emscriptenGetAudioObject($0).suspend(); - }, pDevice->webaudio.audioContextPlayback); - } -#else - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex) { - EM_ASM({ - var device = miniaudio.get_device_by_index($0); - device.webaudio.suspend(); - device.state = 1; /* ma_device_state_stopped */ - }, pDevice->webaudio.indexCapture); - } - - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - EM_ASM({ - var device = miniaudio.get_device_by_index($0); - device.webaudio.suspend(); - device.state = 1; /* ma_device_state_stopped */ - }, pDevice->webaudio.indexPlayback); - } -#endif - - ma_device__on_notification_stopped(pDevice); - - return MA_SUCCESS; -} - -static ma_result ma_context_uninit__webaudio(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - MA_ASSERT(pContext->backend == ma_backend_webaudio); - - (void)pContext; /* Unused. */ - - /* Remove the global miniaudio object from window if there are no more references to it. */ - EM_ASM({ - if (typeof(window.miniaudio) !== 'undefined') { - window.miniaudio.referenceCount--; - if (window.miniaudio.referenceCount === 0) { - delete window.miniaudio; - } - } - }); - - return MA_SUCCESS; -} - -static ma_result ma_context_init__webaudio(ma_context* pContext, const ma_context_config* pConfig, ma_backend_callbacks* pCallbacks) -{ - int resultFromJS; - - MA_ASSERT(pContext != NULL); - - (void)pConfig; /* Unused. */ - - /* Here is where our global JavaScript object is initialized. */ - resultFromJS = EM_ASM_INT({ - if (typeof window === 'undefined' || (window.AudioContext || window.webkitAudioContext) === undefined) { - return 0; /* Web Audio not supported. */ - } - - if (typeof(window.miniaudio) === 'undefined') { - window.miniaudio = { - referenceCount: 0 - }; - miniaudio.devices = []; /* Device cache for mapping devices to indexes for JavaScript/C interop. */ - - miniaudio.track_device = function(device) { - /* Try inserting into a free slot first. */ - for (var iDevice = 0; iDevice < miniaudio.devices.length; ++iDevice) { - if (miniaudio.devices[iDevice] == null) { - miniaudio.devices[iDevice] = device; - return iDevice; - } - } - - /* Getting here means there is no empty slots in the array so we just push to the end. */ - miniaudio.devices.push(device); - return miniaudio.devices.length - 1; - }; - - miniaudio.untrack_device_by_index = function(deviceIndex) { - /* We just set the device's slot to null. The slot will get reused in the next call to ma_track_device. */ - miniaudio.devices[deviceIndex] = null; - - /* Trim the array if possible. */ - while (miniaudio.devices.length > 0) { - if (miniaudio.devices[miniaudio.devices.length-1] == null) { - miniaudio.devices.pop(); - } else { - break; - } - } - }; - - miniaudio.untrack_device = function(device) { - for (var iDevice = 0; iDevice < miniaudio.devices.length; ++iDevice) { - if (miniaudio.devices[iDevice] == device) { - return miniaudio.untrack_device_by_index(iDevice); - } - } - }; - - miniaudio.get_device_by_index = function(deviceIndex) { - return miniaudio.devices[deviceIndex]; - }; - - miniaudio.unlock_event_types = (function(){ - return ['touchstart', 'touchend', 'click']; - })(); - - miniaudio.unlock = function() { - for(var i = 0; i < miniaudio.devices.length; ++i) { - var device = miniaudio.devices[i]; - if (device != null && device.webaudio != null && device.state === 2 /* ma_device_state_started */) { - device.webaudio.resume(); - } - } - miniaudio.unlock_event_types.map(function(event_type) { - document.removeEventListener(event_type, miniaudio.unlock, true); - }); - }; - - miniaudio.unlock_event_types.map(function(event_type) { - document.addEventListener(event_type, miniaudio.unlock, true); - }); - } - - window.miniaudio.referenceCount++; - - return 1; - }, 0); /* Must pass in a dummy argument for C99 compatibility. */ - - if (resultFromJS != 1) { - return MA_FAILED_TO_INIT_BACKEND; - } - - pCallbacks->onContextInit = ma_context_init__webaudio; - pCallbacks->onContextUninit = ma_context_uninit__webaudio; - pCallbacks->onContextEnumerateDevices = ma_context_enumerate_devices__webaudio; - pCallbacks->onContextGetDeviceInfo = ma_context_get_device_info__webaudio; - pCallbacks->onDeviceInit = ma_device_init__webaudio; - pCallbacks->onDeviceUninit = ma_device_uninit__webaudio; - pCallbacks->onDeviceStart = ma_device_start__webaudio; - pCallbacks->onDeviceStop = ma_device_stop__webaudio; - pCallbacks->onDeviceRead = NULL; /* Not needed because WebAudio is asynchronous. */ - pCallbacks->onDeviceWrite = NULL; /* Not needed because WebAudio is asynchronous. */ - pCallbacks->onDeviceDataLoop = NULL; /* Not needed because WebAudio is asynchronous. */ - - return MA_SUCCESS; -} -#endif /* Web Audio */ - - - -static ma_bool32 ma__is_channel_map_valid(const ma_channel* pChannelMap, ma_uint32 channels) -{ - /* A blank channel map should be allowed, in which case it should use an appropriate default which will depend on context. */ - if (pChannelMap != NULL && pChannelMap[0] != MA_CHANNEL_NONE) { - ma_uint32 iChannel; - - if (channels == 0 || channels > MA_MAX_CHANNELS) { - return MA_FALSE; /* Channel count out of range. */ - } - - /* A channel cannot be present in the channel map more than once. */ - for (iChannel = 0; iChannel < channels; ++iChannel) { - ma_uint32 jChannel; - for (jChannel = iChannel + 1; jChannel < channels; ++jChannel) { - if (pChannelMap[iChannel] == pChannelMap[jChannel]) { - return MA_FALSE; - } - } - } - } - - return MA_TRUE; -} - - -static ma_bool32 ma_context_is_backend_asynchronous(ma_context* pContext) -{ - MA_ASSERT(pContext != NULL); - - if (pContext->callbacks.onDeviceRead == NULL && pContext->callbacks.onDeviceWrite == NULL) { - if (pContext->callbacks.onDeviceDataLoop == NULL) { - return MA_TRUE; - } else { - return MA_FALSE; - } - } else { - return MA_FALSE; - } -} - - -static ma_result ma_device__post_init_setup(ma_device* pDevice, ma_device_type deviceType) -{ - ma_result result; - - MA_ASSERT(pDevice != NULL); - - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex || deviceType == ma_device_type_loopback) { - if (pDevice->capture.format == ma_format_unknown) { - pDevice->capture.format = pDevice->capture.internalFormat; - } - if (pDevice->capture.channels == 0) { - pDevice->capture.channels = pDevice->capture.internalChannels; - } - if (pDevice->capture.channelMap[0] == MA_CHANNEL_NONE) { - MA_ASSERT(pDevice->capture.channels <= MA_MAX_CHANNELS); - if (pDevice->capture.internalChannels == pDevice->capture.channels) { - ma_channel_map_copy(pDevice->capture.channelMap, pDevice->capture.internalChannelMap, pDevice->capture.channels); - } else { - if (pDevice->capture.channelMixMode == ma_channel_mix_mode_simple) { - ma_channel_map_init_blank(pDevice->capture.channelMap, pDevice->capture.channels); - } else { - ma_channel_map_init_standard(ma_standard_channel_map_default, pDevice->capture.channelMap, ma_countof(pDevice->capture.channelMap), pDevice->capture.channels); - } - } - } - } - - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - if (pDevice->playback.format == ma_format_unknown) { - pDevice->playback.format = pDevice->playback.internalFormat; - } - if (pDevice->playback.channels == 0) { - pDevice->playback.channels = pDevice->playback.internalChannels; - } - if (pDevice->playback.channelMap[0] == MA_CHANNEL_NONE) { - MA_ASSERT(pDevice->playback.channels <= MA_MAX_CHANNELS); - if (pDevice->playback.internalChannels == pDevice->playback.channels) { - ma_channel_map_copy(pDevice->playback.channelMap, pDevice->playback.internalChannelMap, pDevice->playback.channels); - } else { - if (pDevice->playback.channelMixMode == ma_channel_mix_mode_simple) { - ma_channel_map_init_blank(pDevice->playback.channelMap, pDevice->playback.channels); - } else { - ma_channel_map_init_standard(ma_standard_channel_map_default, pDevice->playback.channelMap, ma_countof(pDevice->playback.channelMap), pDevice->playback.channels); - } - } - } - } - - if (pDevice->sampleRate == 0) { - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex || deviceType == ma_device_type_loopback) { - pDevice->sampleRate = pDevice->capture.internalSampleRate; - } else { - pDevice->sampleRate = pDevice->playback.internalSampleRate; - } - } - - /* Data converters. */ - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex || deviceType == ma_device_type_loopback) { - /* Converting from internal device format to client format. */ - ma_data_converter_config converterConfig = ma_data_converter_config_init_default(); - converterConfig.formatIn = pDevice->capture.internalFormat; - converterConfig.channelsIn = pDevice->capture.internalChannels; - converterConfig.sampleRateIn = pDevice->capture.internalSampleRate; - converterConfig.pChannelMapIn = pDevice->capture.internalChannelMap; - converterConfig.formatOut = pDevice->capture.format; - converterConfig.channelsOut = pDevice->capture.channels; - converterConfig.sampleRateOut = pDevice->sampleRate; - converterConfig.pChannelMapOut = pDevice->capture.channelMap; - converterConfig.channelMixMode = pDevice->capture.channelMixMode; - converterConfig.calculateLFEFromSpatialChannels = pDevice->capture.calculateLFEFromSpatialChannels; - converterConfig.allowDynamicSampleRate = MA_FALSE; - converterConfig.resampling.algorithm = pDevice->resampling.algorithm; - converterConfig.resampling.linear.lpfOrder = pDevice->resampling.linear.lpfOrder; - converterConfig.resampling.pBackendVTable = pDevice->resampling.pBackendVTable; - converterConfig.resampling.pBackendUserData = pDevice->resampling.pBackendUserData; - - /* Make sure the old converter is uninitialized first. */ - if (ma_device_get_state(pDevice) != ma_device_state_uninitialized) { - ma_data_converter_uninit(&pDevice->capture.converter, &pDevice->pContext->allocationCallbacks); - } - - result = ma_data_converter_init(&converterConfig, &pDevice->pContext->allocationCallbacks, &pDevice->capture.converter); - if (result != MA_SUCCESS) { - return result; - } - } - - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - /* Converting from client format to device format. */ - ma_data_converter_config converterConfig = ma_data_converter_config_init_default(); - converterConfig.formatIn = pDevice->playback.format; - converterConfig.channelsIn = pDevice->playback.channels; - converterConfig.sampleRateIn = pDevice->sampleRate; - converterConfig.pChannelMapIn = pDevice->playback.channelMap; - converterConfig.formatOut = pDevice->playback.internalFormat; - converterConfig.channelsOut = pDevice->playback.internalChannels; - converterConfig.sampleRateOut = pDevice->playback.internalSampleRate; - converterConfig.pChannelMapOut = pDevice->playback.internalChannelMap; - converterConfig.channelMixMode = pDevice->playback.channelMixMode; - converterConfig.calculateLFEFromSpatialChannels = pDevice->playback.calculateLFEFromSpatialChannels; - converterConfig.allowDynamicSampleRate = MA_FALSE; - converterConfig.resampling.algorithm = pDevice->resampling.algorithm; - converterConfig.resampling.linear.lpfOrder = pDevice->resampling.linear.lpfOrder; - converterConfig.resampling.pBackendVTable = pDevice->resampling.pBackendVTable; - converterConfig.resampling.pBackendUserData = pDevice->resampling.pBackendUserData; - - /* Make sure the old converter is uninitialized first. */ - if (ma_device_get_state(pDevice) != ma_device_state_uninitialized) { - ma_data_converter_uninit(&pDevice->playback.converter, &pDevice->pContext->allocationCallbacks); - } - - result = ma_data_converter_init(&converterConfig, &pDevice->pContext->allocationCallbacks, &pDevice->playback.converter); - if (result != MA_SUCCESS) { - return result; - } - } - - - /* - If the device is doing playback (ma_device_type_playback or ma_device_type_duplex), there's - a couple of situations where we'll need a heap allocated cache. - - The first is a duplex device for backends that use a callback for data delivery. The reason - this is needed is that the input stage needs to have a buffer to place the input data while it - waits for the playback stage, after which the miniaudio data callback will get fired. This is - not needed for backends that use a blocking API because miniaudio manages temporary buffers on - the stack to achieve this. - - The other situation is when the data converter does not have the ability to query the number - of input frames that are required in order to process a given number of output frames. When - performing data conversion, it's useful if miniaudio know exactly how many frames it needs - from the client in order to generate a given number of output frames. This way, only exactly - the number of frames are needed to be read from the client which means no cache is necessary. - On the other hand, if miniaudio doesn't know how many frames to read, it is forced to read - in fixed sized chunks and then cache any residual unused input frames, those of which will be - processed at a later stage. - */ - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - ma_uint64 unused; - - pDevice->playback.inputCacheConsumed = 0; - pDevice->playback.inputCacheRemaining = 0; - - if ((pDevice->type == ma_device_type_duplex && ma_context_is_backend_asynchronous(pDevice->pContext)) || /* Duplex with asynchronous backend. */ - ma_data_converter_get_required_input_frame_count(&pDevice->playback.converter, 1, &unused) != MA_SUCCESS) /* Data conversion required input frame calculation not supported. */ - { - /* We need a heap allocated cache. We want to size this based on the period size. */ - void* pNewInputCache; - ma_uint64 newInputCacheCap; - ma_uint64 newInputCacheSizeInBytes; - - newInputCacheCap = ma_calculate_frame_count_after_resampling(pDevice->playback.internalSampleRate, pDevice->sampleRate, pDevice->playback.internalPeriodSizeInFrames); - - newInputCacheSizeInBytes = newInputCacheCap * ma_get_bytes_per_frame(pDevice->playback.format, pDevice->playback.channels); - if (newInputCacheSizeInBytes > MA_SIZE_MAX) { - ma_free(pDevice->playback.pInputCache, &pDevice->pContext->allocationCallbacks); - pDevice->playback.pInputCache = NULL; - pDevice->playback.inputCacheCap = 0; - return MA_OUT_OF_MEMORY; /* Allocation too big. Should never hit this, but makes the cast below safer for 32-bit builds. */ - } - - pNewInputCache = ma_realloc(pDevice->playback.pInputCache, (size_t)newInputCacheSizeInBytes, &pDevice->pContext->allocationCallbacks); - if (pNewInputCache == NULL) { - ma_free(pDevice->playback.pInputCache, &pDevice->pContext->allocationCallbacks); - pDevice->playback.pInputCache = NULL; - pDevice->playback.inputCacheCap = 0; - return MA_OUT_OF_MEMORY; - } - - pDevice->playback.pInputCache = pNewInputCache; - pDevice->playback.inputCacheCap = newInputCacheCap; - } else { - /* Heap allocation not required. Make sure we clear out the old cache just in case this function was called in response to a route change. */ - ma_free(pDevice->playback.pInputCache, &pDevice->pContext->allocationCallbacks); - pDevice->playback.pInputCache = NULL; - pDevice->playback.inputCacheCap = 0; - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_device_post_init(ma_device* pDevice, ma_device_type deviceType, const ma_device_descriptor* pDescriptorPlayback, const ma_device_descriptor* pDescriptorCapture) -{ - ma_result result; - - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - /* Capture. */ - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex || deviceType == ma_device_type_loopback) { - if (ma_device_descriptor_is_valid(pDescriptorCapture) == MA_FALSE) { - return MA_INVALID_ARGS; - } - - pDevice->capture.internalFormat = pDescriptorCapture->format; - pDevice->capture.internalChannels = pDescriptorCapture->channels; - pDevice->capture.internalSampleRate = pDescriptorCapture->sampleRate; - MA_COPY_MEMORY(pDevice->capture.internalChannelMap, pDescriptorCapture->channelMap, sizeof(pDescriptorCapture->channelMap)); - pDevice->capture.internalPeriodSizeInFrames = pDescriptorCapture->periodSizeInFrames; - pDevice->capture.internalPeriods = pDescriptorCapture->periodCount; - - if (pDevice->capture.internalPeriodSizeInFrames == 0) { - pDevice->capture.internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(pDescriptorCapture->periodSizeInMilliseconds, pDescriptorCapture->sampleRate); - } - } - - /* Playback. */ - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - if (ma_device_descriptor_is_valid(pDescriptorPlayback) == MA_FALSE) { - return MA_INVALID_ARGS; - } - - pDevice->playback.internalFormat = pDescriptorPlayback->format; - pDevice->playback.internalChannels = pDescriptorPlayback->channels; - pDevice->playback.internalSampleRate = pDescriptorPlayback->sampleRate; - MA_COPY_MEMORY(pDevice->playback.internalChannelMap, pDescriptorPlayback->channelMap, sizeof(pDescriptorPlayback->channelMap)); - pDevice->playback.internalPeriodSizeInFrames = pDescriptorPlayback->periodSizeInFrames; - pDevice->playback.internalPeriods = pDescriptorPlayback->periodCount; - - if (pDevice->playback.internalPeriodSizeInFrames == 0) { - pDevice->playback.internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(pDescriptorPlayback->periodSizeInMilliseconds, pDescriptorPlayback->sampleRate); - } - } - - /* - The name of the device can be retrieved from device info. This may be temporary and replaced with a `ma_device_get_info(pDevice, deviceType)` instead. - For loopback devices, we need to retrieve the name of the playback device. - */ - { - ma_device_info deviceInfo; - - if (deviceType == ma_device_type_capture || deviceType == ma_device_type_duplex || deviceType == ma_device_type_loopback) { - result = ma_device_get_info(pDevice, (deviceType == ma_device_type_loopback) ? ma_device_type_playback : ma_device_type_capture, &deviceInfo); - if (result == MA_SUCCESS) { - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), deviceInfo.name, (size_t)-1); - } else { - /* We failed to retrieve the device info. Fall back to a default name. */ - if (pDescriptorCapture->pDeviceID == NULL) { - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), "Capture Device", (size_t)-1); - } - } - } - - if (deviceType == ma_device_type_playback || deviceType == ma_device_type_duplex) { - result = ma_device_get_info(pDevice, ma_device_type_playback, &deviceInfo); - if (result == MA_SUCCESS) { - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), deviceInfo.name, (size_t)-1); - } else { - /* We failed to retrieve the device info. Fall back to a default name. */ - if (pDescriptorPlayback->pDeviceID == NULL) { - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), "Playback Device", (size_t)-1); - } - } - } - } - - /* Update data conversion. */ - return ma_device__post_init_setup(pDevice, deviceType); /* TODO: Should probably rename ma_device__post_init_setup() to something better. */ -} - - -static ma_thread_result MA_THREADCALL ma_worker_thread(void* pData) -{ - ma_device* pDevice = (ma_device*)pData; - MA_ASSERT(pDevice != NULL); - -#ifdef MA_WIN32 - ma_CoInitializeEx(pDevice->pContext, NULL, MA_COINIT_VALUE); -#endif - - /* - When the device is being initialized it's initial state is set to ma_device_state_uninitialized. Before returning from - ma_device_init(), the state needs to be set to something valid. In miniaudio the device's default state immediately - after initialization is stopped, so therefore we need to mark the device as such. miniaudio will wait on the worker - thread to signal an event to know when the worker thread is ready for action. - */ - ma_device__set_state(pDevice, ma_device_state_stopped); - ma_event_signal(&pDevice->stopEvent); - - for (;;) { /* <-- This loop just keeps the thread alive. The main audio loop is inside. */ - ma_result startResult; - ma_result stopResult; /* <-- This will store the result from onDeviceStop(). If it returns an error, we don't fire the stopped notification callback. */ - - /* We wait on an event to know when something has requested that the device be started and the main loop entered. */ - ma_event_wait(&pDevice->wakeupEvent); - - /* Default result code. */ - pDevice->workResult = MA_SUCCESS; - - /* If the reason for the wake up is that we are terminating, just break from the loop. */ - if (ma_device_get_state(pDevice) == ma_device_state_uninitialized) { - break; - } - - /* - Getting to this point means the device is wanting to get started. The function that has requested that the device - be started will be waiting on an event (pDevice->startEvent) which means we need to make sure we signal the event - in both the success and error case. It's important that the state of the device is set _before_ signaling the event. - */ - MA_ASSERT(ma_device_get_state(pDevice) == ma_device_state_starting); - - /* If the device has a start callback, start it now. */ - if (pDevice->pContext->callbacks.onDeviceStart != NULL) { - startResult = pDevice->pContext->callbacks.onDeviceStart(pDevice); - } else { - startResult = MA_SUCCESS; - } - - /* - If starting was not successful we'll need to loop back to the start and wait for something - to happen (pDevice->wakeupEvent). - */ - if (startResult != MA_SUCCESS) { - pDevice->workResult = startResult; - ma_event_signal(&pDevice->startEvent); /* <-- Always signal the start event so ma_device_start() can return as it'll be waiting on it. */ - continue; - } - - /* Make sure the state is set appropriately. */ - ma_device__set_state(pDevice, ma_device_state_started); /* <-- Set this before signaling the event so that the state is always guaranteed to be good after ma_device_start() has returned. */ - ma_event_signal(&pDevice->startEvent); - - ma_device__on_notification_started(pDevice); - - if (pDevice->pContext->callbacks.onDeviceDataLoop != NULL) { - pDevice->pContext->callbacks.onDeviceDataLoop(pDevice); - } else { - /* The backend is not using a custom main loop implementation, so now fall back to the blocking read-write implementation. */ - ma_device_audio_thread__default_read_write(pDevice); - } - - /* Getting here means we have broken from the main loop which happens the application has requested that device be stopped. */ - if (pDevice->pContext->callbacks.onDeviceStop != NULL) { - stopResult = pDevice->pContext->callbacks.onDeviceStop(pDevice); - } else { - stopResult = MA_SUCCESS; /* No stop callback with the backend. Just assume successful. */ - } - - /* - After the device has stopped, make sure an event is posted. Don't post a stopped event if - stopping failed. This can happen on some backends when the underlying stream has been - stopped due to the device being physically unplugged or disabled via an OS setting. - */ - if (stopResult == MA_SUCCESS) { - ma_device__on_notification_stopped(pDevice); - } - - /* A function somewhere is waiting for the device to have stopped for real so we need to signal an event to allow it to continue. */ - ma_device__set_state(pDevice, ma_device_state_stopped); - ma_event_signal(&pDevice->stopEvent); - } - -#ifdef MA_WIN32 - ma_CoUninitialize(pDevice->pContext); -#endif - - return (ma_thread_result)0; -} - - -/* Helper for determining whether or not the given device is initialized. */ -static ma_bool32 ma_device__is_initialized(ma_device* pDevice) -{ - if (pDevice == NULL) { - return MA_FALSE; - } - - return ma_device_get_state(pDevice) != ma_device_state_uninitialized; -} - - -#ifdef MA_WIN32 -static ma_result ma_context_uninit_backend_apis__win32(ma_context* pContext) -{ - /* For some reason UWP complains when CoUninitialize() is called. I'm just not going to call it on UWP. */ -#ifdef MA_WIN32_DESKTOP - ma_CoUninitialize(pContext); - ma_dlclose(pContext, pContext->win32.hUser32DLL); - ma_dlclose(pContext, pContext->win32.hOle32DLL); - ma_dlclose(pContext, pContext->win32.hAdvapi32DLL); -#else - (void)pContext; -#endif - - return MA_SUCCESS; -} - -static ma_result ma_context_init_backend_apis__win32(ma_context* pContext) -{ -#ifdef MA_WIN32_DESKTOP - /* Ole32.dll */ - pContext->win32.hOle32DLL = ma_dlopen(pContext, "ole32.dll"); - if (pContext->win32.hOle32DLL == NULL) { - return MA_FAILED_TO_INIT_BACKEND; - } - - pContext->win32.CoInitialize = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "CoInitialize"); - pContext->win32.CoInitializeEx = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "CoInitializeEx"); - pContext->win32.CoUninitialize = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "CoUninitialize"); - pContext->win32.CoCreateInstance = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "CoCreateInstance"); - pContext->win32.CoTaskMemFree = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "CoTaskMemFree"); - pContext->win32.PropVariantClear = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "PropVariantClear"); - pContext->win32.StringFromGUID2 = (ma_proc)ma_dlsym(pContext, pContext->win32.hOle32DLL, "StringFromGUID2"); - - - /* User32.dll */ - pContext->win32.hUser32DLL = ma_dlopen(pContext, "user32.dll"); - if (pContext->win32.hUser32DLL == NULL) { - return MA_FAILED_TO_INIT_BACKEND; - } - - pContext->win32.GetForegroundWindow = (ma_proc)ma_dlsym(pContext, pContext->win32.hUser32DLL, "GetForegroundWindow"); - pContext->win32.GetDesktopWindow = (ma_proc)ma_dlsym(pContext, pContext->win32.hUser32DLL, "GetDesktopWindow"); - - - /* Advapi32.dll */ - pContext->win32.hAdvapi32DLL = ma_dlopen(pContext, "advapi32.dll"); - if (pContext->win32.hAdvapi32DLL == NULL) { - return MA_FAILED_TO_INIT_BACKEND; - } - - pContext->win32.RegOpenKeyExA = (ma_proc)ma_dlsym(pContext, pContext->win32.hAdvapi32DLL, "RegOpenKeyExA"); - pContext->win32.RegCloseKey = (ma_proc)ma_dlsym(pContext, pContext->win32.hAdvapi32DLL, "RegCloseKey"); - pContext->win32.RegQueryValueExA = (ma_proc)ma_dlsym(pContext, pContext->win32.hAdvapi32DLL, "RegQueryValueExA"); -#else - (void)pContext; /* Unused. */ -#endif - - ma_CoInitializeEx(pContext, NULL, MA_COINIT_VALUE); - return MA_SUCCESS; -} -#else -static ma_result ma_context_uninit_backend_apis__nix(ma_context* pContext) -{ - (void)pContext; - - return MA_SUCCESS; -} - -static ma_result ma_context_init_backend_apis__nix(ma_context* pContext) -{ - (void)pContext; - - return MA_SUCCESS; -} -#endif - -static ma_result ma_context_init_backend_apis(ma_context* pContext) -{ - ma_result result; -#ifdef MA_WIN32 - result = ma_context_init_backend_apis__win32(pContext); -#else - result = ma_context_init_backend_apis__nix(pContext); -#endif - - return result; -} - -static ma_result ma_context_uninit_backend_apis(ma_context* pContext) -{ - ma_result result; -#ifdef MA_WIN32 - result = ma_context_uninit_backend_apis__win32(pContext); -#else - result = ma_context_uninit_backend_apis__nix(pContext); -#endif - - return result; -} - - -/* The default capacity doesn't need to be too big. */ -#ifndef MA_DEFAULT_DEVICE_JOB_QUEUE_CAPACITY -#define MA_DEFAULT_DEVICE_JOB_QUEUE_CAPACITY 32 -#endif - -MA_API ma_device_job_thread_config ma_device_job_thread_config_init(void) -{ - ma_device_job_thread_config config; - - MA_ZERO_OBJECT(&config); - config.noThread = MA_FALSE; - config.jobQueueCapacity = MA_DEFAULT_DEVICE_JOB_QUEUE_CAPACITY; - config.jobQueueFlags = 0; - - return config; -} - - -static ma_thread_result MA_THREADCALL ma_device_job_thread_entry(void* pUserData) -{ - ma_device_job_thread* pJobThread = (ma_device_job_thread*)pUserData; - MA_ASSERT(pJobThread != NULL); - - for (;;) { - ma_result result; - ma_job job; - - result = ma_device_job_thread_next(pJobThread, &job); - if (result != MA_SUCCESS) { - break; - } - - if (job.toc.breakup.code == MA_JOB_TYPE_QUIT) { - break; - } - - ma_job_process(&job); - } - - return (ma_thread_result)0; -} - -MA_API ma_result ma_device_job_thread_init(const ma_device_job_thread_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_device_job_thread* pJobThread) -{ - ma_result result; - ma_job_queue_config jobQueueConfig; - - if (pJobThread == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pJobThread); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - - /* Initialize the job queue before the thread to ensure it's in a valid state. */ - jobQueueConfig = ma_job_queue_config_init(pConfig->jobQueueFlags, pConfig->jobQueueCapacity); - - result = ma_job_queue_init(&jobQueueConfig, pAllocationCallbacks, &pJobThread->jobQueue); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize job queue. */ - } - - - /* The thread needs to be initialized after the job queue to ensure the thread doesn't try to access it prematurely. */ - if (pConfig->noThread == MA_FALSE) { - result = ma_thread_create(&pJobThread->thread, ma_thread_priority_normal, 0, ma_device_job_thread_entry, pJobThread, pAllocationCallbacks); - if (result != MA_SUCCESS) { - ma_job_queue_uninit(&pJobThread->jobQueue, pAllocationCallbacks); - return result; /* Failed to create the job thread. */ - } - - pJobThread->_hasThread = MA_TRUE; - } else { - pJobThread->_hasThread = MA_FALSE; - } - - - return MA_SUCCESS; -} - -MA_API void ma_device_job_thread_uninit(ma_device_job_thread* pJobThread, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pJobThread == NULL) { - return; - } - - /* The first thing to do is post a quit message to the job queue. If we're using a thread we'll need to wait for it. */ - { - ma_job job = ma_job_init(MA_JOB_TYPE_QUIT); - ma_device_job_thread_post(pJobThread, &job); - } - - /* Wait for the thread to terminate naturally. */ - if (pJobThread->_hasThread) { - ma_thread_wait(&pJobThread->thread); - } - - /* At this point the thread should be terminated so we can safely uninitialize the job queue. */ - ma_job_queue_uninit(&pJobThread->jobQueue, pAllocationCallbacks); -} - -MA_API ma_result ma_device_job_thread_post(ma_device_job_thread* pJobThread, const ma_job* pJob) -{ - if (pJobThread == NULL || pJob == NULL) { - return MA_INVALID_ARGS; - } - - return ma_job_queue_post(&pJobThread->jobQueue, pJob); -} - -MA_API ma_result ma_device_job_thread_next(ma_device_job_thread* pJobThread, ma_job* pJob) -{ - if (pJob == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pJob); - - if (pJobThread == NULL) { - return MA_INVALID_ARGS; - } - - return ma_job_queue_next(&pJobThread->jobQueue, pJob); -} - - - -MA_API ma_context_config ma_context_config_init(void) -{ - ma_context_config config; - MA_ZERO_OBJECT(&config); - - return config; -} - -MA_API ma_result ma_context_init(const ma_backend backends[], ma_uint32 backendCount, const ma_context_config* pConfig, ma_context* pContext) -{ - ma_result result; - ma_context_config defaultConfig; - ma_backend defaultBackends[ma_backend_null+1]; - ma_uint32 iBackend; - ma_backend* pBackendsToIterate; - ma_uint32 backendsToIterateCount; - - if (pContext == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pContext); - - /* Always make sure the config is set first to ensure properties are available as soon as possible. */ - if (pConfig == NULL) { - defaultConfig = ma_context_config_init(); - pConfig = &defaultConfig; - } - - /* Allocation callbacks need to come first because they'll be passed around to other areas. */ - result = ma_allocation_callbacks_init_copy(&pContext->allocationCallbacks, &pConfig->allocationCallbacks); - if (result != MA_SUCCESS) { - return result; - } - - /* Get a lot set up first so we can start logging ASAP. */ - if (pConfig->pLog != NULL) { - pContext->pLog = pConfig->pLog; - } else { - result = ma_log_init(&pContext->allocationCallbacks, &pContext->log); - if (result == MA_SUCCESS) { - pContext->pLog = &pContext->log; - } else { - pContext->pLog = NULL; /* Logging is not available. */ - } - } - - pContext->threadPriority = pConfig->threadPriority; - pContext->threadStackSize = pConfig->threadStackSize; - pContext->pUserData = pConfig->pUserData; - - /* Backend APIs need to be initialized first. This is where external libraries will be loaded and linked. */ - result = ma_context_init_backend_apis(pContext); - if (result != MA_SUCCESS) { - return result; - } - - for (iBackend = 0; iBackend <= ma_backend_null; ++iBackend) { - defaultBackends[iBackend] = (ma_backend)iBackend; - } - - pBackendsToIterate = (ma_backend*)backends; - backendsToIterateCount = backendCount; - if (pBackendsToIterate == NULL) { - pBackendsToIterate = (ma_backend*)defaultBackends; - backendsToIterateCount = ma_countof(defaultBackends); - } - - MA_ASSERT(pBackendsToIterate != NULL); - - for (iBackend = 0; iBackend < backendsToIterateCount; iBackend += 1) { - ma_backend backend = pBackendsToIterate[iBackend]; - - /* Make sure all callbacks are reset so we don't accidentally drag in any from previously failed initialization attempts. */ - MA_ZERO_OBJECT(&pContext->callbacks); - - /* These backends are using the new callback system. */ - switch (backend) { - #ifdef MA_HAS_WASAPI - case ma_backend_wasapi: - { - pContext->callbacks.onContextInit = ma_context_init__wasapi; - } break; - #endif - #ifdef MA_HAS_DSOUND - case ma_backend_dsound: - { - pContext->callbacks.onContextInit = ma_context_init__dsound; - } break; - #endif - #ifdef MA_HAS_WINMM - case ma_backend_winmm: - { - pContext->callbacks.onContextInit = ma_context_init__winmm; - } break; - #endif - #ifdef MA_HAS_COREAUDIO - case ma_backend_coreaudio: - { - pContext->callbacks.onContextInit = ma_context_init__coreaudio; - } break; - #endif - #ifdef MA_HAS_SNDIO - case ma_backend_sndio: - { - pContext->callbacks.onContextInit = ma_context_init__sndio; - } break; - #endif - #ifdef MA_HAS_AUDIO4 - case ma_backend_audio4: - { - pContext->callbacks.onContextInit = ma_context_init__audio4; - } break; - #endif - #ifdef MA_HAS_OSS - case ma_backend_oss: - { - pContext->callbacks.onContextInit = ma_context_init__oss; - } break; - #endif - #ifdef MA_HAS_PULSEAUDIO - case ma_backend_pulseaudio: - { - pContext->callbacks.onContextInit = ma_context_init__pulse; - } break; - #endif - #ifdef MA_HAS_ALSA - case ma_backend_alsa: - { - pContext->callbacks.onContextInit = ma_context_init__alsa; - } break; - #endif - #ifdef MA_HAS_JACK - case ma_backend_jack: - { - pContext->callbacks.onContextInit = ma_context_init__jack; - } break; - #endif - #ifdef MA_HAS_AAUDIO - case ma_backend_aaudio: - { - if (ma_is_backend_enabled(backend)) { - pContext->callbacks.onContextInit = ma_context_init__aaudio; - } - } break; - #endif - #ifdef MA_HAS_OPENSL - case ma_backend_opensl: - { - if (ma_is_backend_enabled(backend)) { - pContext->callbacks.onContextInit = ma_context_init__opensl; - } - } break; - #endif - #ifdef MA_HAS_WEBAUDIO - case ma_backend_webaudio: - { - pContext->callbacks.onContextInit = ma_context_init__webaudio; - } break; - #endif - #ifdef MA_HAS_CUSTOM - case ma_backend_custom: - { - /* Slightly different logic for custom backends. Custom backends can optionally set all of their callbacks in the config. */ - pContext->callbacks = pConfig->custom; - } break; - #endif - #ifdef MA_HAS_NULL - case ma_backend_null: - { - pContext->callbacks.onContextInit = ma_context_init__null; - } break; - #endif - - default: break; - } - - if (pContext->callbacks.onContextInit != NULL) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "Attempting to initialize %s backend...\n", ma_get_backend_name(backend)); - result = pContext->callbacks.onContextInit(pContext, pConfig, &pContext->callbacks); - } else { - /* Getting here means the onContextInit callback is not set which means the backend is not enabled. Special case for the custom backend. */ - if (backend != ma_backend_custom) { - result = MA_BACKEND_NOT_ENABLED; - } else { - #if !defined(MA_HAS_CUSTOM) - result = MA_BACKEND_NOT_ENABLED; - #else - result = MA_NO_BACKEND; - #endif - } - } - - /* If this iteration was successful, return. */ - if (result == MA_SUCCESS) { - result = ma_mutex_init(&pContext->deviceEnumLock); - if (result != MA_SUCCESS) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "Failed to initialize mutex for device enumeration. ma_context_get_devices() is not thread safe.\n"); - } - - result = ma_mutex_init(&pContext->deviceInfoLock); - if (result != MA_SUCCESS) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_WARNING, "Failed to initialize mutex for device info retrieval. ma_context_get_device_info() is not thread safe.\n"); - } - - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "System Architecture:\n"); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " Endian: %s\n", ma_is_little_endian() ? "LE" : "BE"); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " SSE2: %s\n", ma_has_sse2() ? "YES" : "NO"); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " AVX2: %s\n", ma_has_avx2() ? "YES" : "NO"); - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, " NEON: %s\n", ma_has_neon() ? "YES" : "NO"); - - pContext->backend = backend; - return result; - } else { - if (result == MA_BACKEND_NOT_ENABLED) { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "%s backend is disabled.\n", ma_get_backend_name(backend)); - } else { - ma_log_postf(ma_context_get_log(pContext), MA_LOG_LEVEL_DEBUG, "Failed to initialize %s backend.\n", ma_get_backend_name(backend)); - } - } - } - - /* If we get here it means an error occurred. */ - MA_ZERO_OBJECT(pContext); /* Safety. */ - return MA_NO_BACKEND; -} - -MA_API ma_result ma_context_uninit(ma_context* pContext) -{ - if (pContext == NULL) { - return MA_INVALID_ARGS; - } - - if (pContext->callbacks.onContextUninit != NULL) { - pContext->callbacks.onContextUninit(pContext); - } - - ma_mutex_uninit(&pContext->deviceEnumLock); - ma_mutex_uninit(&pContext->deviceInfoLock); - ma_free(pContext->pDeviceInfos, &pContext->allocationCallbacks); - ma_context_uninit_backend_apis(pContext); - - if (pContext->pLog == &pContext->log) { - ma_log_uninit(&pContext->log); - } - - return MA_SUCCESS; -} - -MA_API size_t ma_context_sizeof() -{ - return sizeof(ma_context); -} - - -MA_API ma_log* ma_context_get_log(ma_context* pContext) -{ - if (pContext == NULL) { - return NULL; - } - - return pContext->pLog; -} - - -MA_API ma_result ma_context_enumerate_devices(ma_context* pContext, ma_enum_devices_callback_proc callback, void* pUserData) -{ - ma_result result; - - if (pContext == NULL || callback == NULL) { - return MA_INVALID_ARGS; - } - - if (pContext->callbacks.onContextEnumerateDevices == NULL) { - return MA_INVALID_OPERATION; - } - - ma_mutex_lock(&pContext->deviceEnumLock); - { - result = pContext->callbacks.onContextEnumerateDevices(pContext, callback, pUserData); - } - ma_mutex_unlock(&pContext->deviceEnumLock); - - return result; -} - - -static ma_bool32 ma_context_get_devices__enum_callback(ma_context* pContext, ma_device_type deviceType, const ma_device_info* pInfo, void* pUserData) -{ - /* - We need to insert the device info into our main internal buffer. Where it goes depends on the device type. If it's a capture device - it's just appended to the end. If it's a playback device it's inserted just before the first capture device. - */ - - /* - First make sure we have room. Since the number of devices we add to the list is usually relatively small I've decided to use a - simple fixed size increment for buffer expansion. - */ - const ma_uint32 bufferExpansionCount = 2; - const ma_uint32 totalDeviceInfoCount = pContext->playbackDeviceInfoCount + pContext->captureDeviceInfoCount; - - if (totalDeviceInfoCount >= pContext->deviceInfoCapacity) { - ma_uint32 newCapacity = pContext->deviceInfoCapacity + bufferExpansionCount; - ma_device_info* pNewInfos = (ma_device_info*)ma_realloc(pContext->pDeviceInfos, sizeof(*pContext->pDeviceInfos)*newCapacity, &pContext->allocationCallbacks); - if (pNewInfos == NULL) { - return MA_FALSE; /* Out of memory. */ - } - - pContext->pDeviceInfos = pNewInfos; - pContext->deviceInfoCapacity = newCapacity; - } - - if (deviceType == ma_device_type_playback) { - /* Playback. Insert just before the first capture device. */ - - /* The first thing to do is move all of the capture devices down a slot. */ - ma_uint32 iFirstCaptureDevice = pContext->playbackDeviceInfoCount; - size_t iCaptureDevice; - for (iCaptureDevice = totalDeviceInfoCount; iCaptureDevice > iFirstCaptureDevice; --iCaptureDevice) { - pContext->pDeviceInfos[iCaptureDevice] = pContext->pDeviceInfos[iCaptureDevice-1]; - } - - /* Now just insert where the first capture device was before moving it down a slot. */ - pContext->pDeviceInfos[iFirstCaptureDevice] = *pInfo; - pContext->playbackDeviceInfoCount += 1; - } else { - /* Capture. Insert at the end. */ - pContext->pDeviceInfos[totalDeviceInfoCount] = *pInfo; - pContext->captureDeviceInfoCount += 1; - } - - (void)pUserData; - return MA_TRUE; -} - -MA_API ma_result ma_context_get_devices(ma_context* pContext, ma_device_info** ppPlaybackDeviceInfos, ma_uint32* pPlaybackDeviceCount, ma_device_info** ppCaptureDeviceInfos, ma_uint32* pCaptureDeviceCount) -{ - ma_result result; - - /* Safety. */ - if (ppPlaybackDeviceInfos != NULL) *ppPlaybackDeviceInfos = NULL; - if (pPlaybackDeviceCount != NULL) *pPlaybackDeviceCount = 0; - if (ppCaptureDeviceInfos != NULL) *ppCaptureDeviceInfos = NULL; - if (pCaptureDeviceCount != NULL) *pCaptureDeviceCount = 0; - - if (pContext == NULL) { - return MA_INVALID_ARGS; - } - - if (pContext->callbacks.onContextEnumerateDevices == NULL) { - return MA_INVALID_OPERATION; - } - - /* Note that we don't use ma_context_enumerate_devices() here because we want to do locking at a higher level. */ - ma_mutex_lock(&pContext->deviceEnumLock); - { - /* Reset everything first. */ - pContext->playbackDeviceInfoCount = 0; - pContext->captureDeviceInfoCount = 0; - - /* Now enumerate over available devices. */ - result = pContext->callbacks.onContextEnumerateDevices(pContext, ma_context_get_devices__enum_callback, NULL); - if (result == MA_SUCCESS) { - /* Playback devices. */ - if (ppPlaybackDeviceInfos != NULL) { - *ppPlaybackDeviceInfos = pContext->pDeviceInfos; - } - if (pPlaybackDeviceCount != NULL) { - *pPlaybackDeviceCount = pContext->playbackDeviceInfoCount; - } - - /* Capture devices. */ - if (ppCaptureDeviceInfos != NULL) { - *ppCaptureDeviceInfos = pContext->pDeviceInfos; - /* Capture devices come after playback devices. */ - if (pContext->playbackDeviceInfoCount > 0) { - /* Conditional, because NULL+0 is undefined behavior. */ - *ppCaptureDeviceInfos += pContext->playbackDeviceInfoCount; - } - } - if (pCaptureDeviceCount != NULL) { - *pCaptureDeviceCount = pContext->captureDeviceInfoCount; - } - } - } - ma_mutex_unlock(&pContext->deviceEnumLock); - - return result; -} - -MA_API ma_result ma_context_get_device_info(ma_context* pContext, ma_device_type deviceType, const ma_device_id* pDeviceID, ma_device_info* pDeviceInfo) -{ - ma_result result; - ma_device_info deviceInfo; - - /* NOTE: Do not clear pDeviceInfo on entry. The reason is the pDeviceID may actually point to pDeviceInfo->id which will break things. */ - if (pContext == NULL || pDeviceInfo == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(&deviceInfo); - - /* Help the backend out by copying over the device ID if we have one. */ - if (pDeviceID != NULL) { - MA_COPY_MEMORY(&deviceInfo.id, pDeviceID, sizeof(*pDeviceID)); - } - - if (pContext->callbacks.onContextGetDeviceInfo == NULL) { - return MA_INVALID_OPERATION; - } - - ma_mutex_lock(&pContext->deviceInfoLock); - { - result = pContext->callbacks.onContextGetDeviceInfo(pContext, deviceType, pDeviceID, &deviceInfo); - } - ma_mutex_unlock(&pContext->deviceInfoLock); - - *pDeviceInfo = deviceInfo; - return result; -} - -MA_API ma_bool32 ma_context_is_loopback_supported(ma_context* pContext) -{ - if (pContext == NULL) { - return MA_FALSE; - } - - return ma_is_loopback_supported(pContext->backend); -} - - -MA_API ma_device_config ma_device_config_init(ma_device_type deviceType) -{ - ma_device_config config; - MA_ZERO_OBJECT(&config); - config.deviceType = deviceType; - config.resampling = ma_resampler_config_init(ma_format_unknown, 0, 0, 0, ma_resample_algorithm_linear); /* Format/channels/rate don't matter here. */ - - return config; -} - -MA_API ma_result ma_device_init(ma_context* pContext, const ma_device_config* pConfig, ma_device* pDevice) -{ - ma_result result; - ma_device_descriptor descriptorPlayback; - ma_device_descriptor descriptorCapture; - - /* The context can be null, in which case we self-manage it. */ - if (pContext == NULL) { - return ma_device_init_ex(NULL, 0, NULL, pConfig, pDevice); - } - - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDevice); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Check that we have our callbacks defined. */ - if (pContext->callbacks.onDeviceInit == NULL) { - return MA_INVALID_OPERATION; - } - - /* Basic config validation. */ - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex) { - if (pConfig->capture.channels > MA_MAX_CHANNELS) { - return MA_INVALID_ARGS; - } - - if (!ma__is_channel_map_valid(pConfig->capture.pChannelMap, pConfig->capture.channels)) { - return MA_INVALID_ARGS; - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex || pConfig->deviceType == ma_device_type_loopback) { - if (pConfig->playback.channels > MA_MAX_CHANNELS) { - return MA_INVALID_ARGS; - } - - if (!ma__is_channel_map_valid(pConfig->playback.pChannelMap, pConfig->playback.channels)) { - return MA_INVALID_ARGS; - } - } - - pDevice->pContext = pContext; - - /* Set the user data and log callback ASAP to ensure it is available for the entire initialization process. */ - pDevice->pUserData = pConfig->pUserData; - pDevice->onData = pConfig->dataCallback; - pDevice->onNotification = pConfig->notificationCallback; - pDevice->onStop = pConfig->stopCallback; - - if (pConfig->playback.pDeviceID != NULL) { - MA_COPY_MEMORY(&pDevice->playback.id, pConfig->playback.pDeviceID, sizeof(pDevice->playback.id)); - pDevice->playback.pID = &pDevice->playback.id; - } else { - pDevice->playback.pID = NULL; - } - - if (pConfig->capture.pDeviceID != NULL) { - MA_COPY_MEMORY(&pDevice->capture.id, pConfig->capture.pDeviceID, sizeof(pDevice->capture.id)); - pDevice->capture.pID = &pDevice->capture.id; - } else { - pDevice->capture.pID = NULL; - } - - pDevice->noPreSilencedOutputBuffer = pConfig->noPreSilencedOutputBuffer; - pDevice->noClip = pConfig->noClip; - pDevice->noDisableDenormals = pConfig->noDisableDenormals; - pDevice->noFixedSizedCallback = pConfig->noFixedSizedCallback; - ma_atomic_float_set(&pDevice->masterVolumeFactor, 1); - - pDevice->type = pConfig->deviceType; - pDevice->sampleRate = pConfig->sampleRate; - pDevice->resampling.algorithm = pConfig->resampling.algorithm; - pDevice->resampling.linear.lpfOrder = pConfig->resampling.linear.lpfOrder; - pDevice->resampling.pBackendVTable = pConfig->resampling.pBackendVTable; - pDevice->resampling.pBackendUserData = pConfig->resampling.pBackendUserData; - - pDevice->capture.shareMode = pConfig->capture.shareMode; - pDevice->capture.format = pConfig->capture.format; - pDevice->capture.channels = pConfig->capture.channels; - ma_channel_map_copy_or_default(pDevice->capture.channelMap, ma_countof(pDevice->capture.channelMap), pConfig->capture.pChannelMap, pConfig->capture.channels); - pDevice->capture.channelMixMode = pConfig->capture.channelMixMode; - pDevice->capture.calculateLFEFromSpatialChannels = pConfig->capture.calculateLFEFromSpatialChannels; - - pDevice->playback.shareMode = pConfig->playback.shareMode; - pDevice->playback.format = pConfig->playback.format; - pDevice->playback.channels = pConfig->playback.channels; - ma_channel_map_copy_or_default(pDevice->playback.channelMap, ma_countof(pDevice->playback.channelMap), pConfig->playback.pChannelMap, pConfig->playback.channels); - pDevice->playback.channelMixMode = pConfig->playback.channelMixMode; - pDevice->playback.calculateLFEFromSpatialChannels = pConfig->playback.calculateLFEFromSpatialChannels; - - result = ma_mutex_init(&pDevice->startStopLock); - if (result != MA_SUCCESS) { - return result; - } - - /* - When the device is started, the worker thread is the one that does the actual startup of the backend device. We - use a semaphore to wait for the background thread to finish the work. The same applies for stopping the device. - - Each of these semaphores is released internally by the worker thread when the work is completed. The start - semaphore is also used to wake up the worker thread. - */ - result = ma_event_init(&pDevice->wakeupEvent); - if (result != MA_SUCCESS) { - ma_mutex_uninit(&pDevice->startStopLock); - return result; - } - - result = ma_event_init(&pDevice->startEvent); - if (result != MA_SUCCESS) { - ma_event_uninit(&pDevice->wakeupEvent); - ma_mutex_uninit(&pDevice->startStopLock); - return result; - } - - result = ma_event_init(&pDevice->stopEvent); - if (result != MA_SUCCESS) { - ma_event_uninit(&pDevice->startEvent); - ma_event_uninit(&pDevice->wakeupEvent); - ma_mutex_uninit(&pDevice->startStopLock); - return result; - } - - - MA_ZERO_OBJECT(&descriptorPlayback); - descriptorPlayback.pDeviceID = pConfig->playback.pDeviceID; - descriptorPlayback.shareMode = pConfig->playback.shareMode; - descriptorPlayback.format = pConfig->playback.format; - descriptorPlayback.channels = pConfig->playback.channels; - descriptorPlayback.sampleRate = pConfig->sampleRate; - ma_channel_map_copy_or_default(descriptorPlayback.channelMap, ma_countof(descriptorPlayback.channelMap), pConfig->playback.pChannelMap, pConfig->playback.channels); - descriptorPlayback.periodSizeInFrames = pConfig->periodSizeInFrames; - descriptorPlayback.periodSizeInMilliseconds = pConfig->periodSizeInMilliseconds; - descriptorPlayback.periodCount = pConfig->periods; - - if (descriptorPlayback.periodCount == 0) { - descriptorPlayback.periodCount = MA_DEFAULT_PERIODS; - } - - - MA_ZERO_OBJECT(&descriptorCapture); - descriptorCapture.pDeviceID = pConfig->capture.pDeviceID; - descriptorCapture.shareMode = pConfig->capture.shareMode; - descriptorCapture.format = pConfig->capture.format; - descriptorCapture.channels = pConfig->capture.channels; - descriptorCapture.sampleRate = pConfig->sampleRate; - ma_channel_map_copy_or_default(descriptorCapture.channelMap, ma_countof(descriptorCapture.channelMap), pConfig->capture.pChannelMap, pConfig->capture.channels); - descriptorCapture.periodSizeInFrames = pConfig->periodSizeInFrames; - descriptorCapture.periodSizeInMilliseconds = pConfig->periodSizeInMilliseconds; - descriptorCapture.periodCount = pConfig->periods; - - if (descriptorCapture.periodCount == 0) { - descriptorCapture.periodCount = MA_DEFAULT_PERIODS; - } - - - result = pContext->callbacks.onDeviceInit(pDevice, pConfig, &descriptorPlayback, &descriptorCapture); - if (result != MA_SUCCESS) { - ma_event_uninit(&pDevice->startEvent); - ma_event_uninit(&pDevice->wakeupEvent); - ma_mutex_uninit(&pDevice->startStopLock); - return result; - } - -#if 0 - /* - On output the descriptors will contain the *actual* data format of the device. We need this to know how to convert the data between - the requested format and the internal format. - */ - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex || pConfig->deviceType == ma_device_type_loopback) { - if (!ma_device_descriptor_is_valid(&descriptorCapture)) { - ma_device_uninit(pDevice); - return MA_INVALID_ARGS; - } - - pDevice->capture.internalFormat = descriptorCapture.format; - pDevice->capture.internalChannels = descriptorCapture.channels; - pDevice->capture.internalSampleRate = descriptorCapture.sampleRate; - ma_channel_map_copy(pDevice->capture.internalChannelMap, descriptorCapture.channelMap, descriptorCapture.channels); - pDevice->capture.internalPeriodSizeInFrames = descriptorCapture.periodSizeInFrames; - pDevice->capture.internalPeriods = descriptorCapture.periodCount; - - if (pDevice->capture.internalPeriodSizeInFrames == 0) { - pDevice->capture.internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(descriptorCapture.periodSizeInMilliseconds, descriptorCapture.sampleRate); - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - if (!ma_device_descriptor_is_valid(&descriptorPlayback)) { - ma_device_uninit(pDevice); - return MA_INVALID_ARGS; - } - - pDevice->playback.internalFormat = descriptorPlayback.format; - pDevice->playback.internalChannels = descriptorPlayback.channels; - pDevice->playback.internalSampleRate = descriptorPlayback.sampleRate; - ma_channel_map_copy(pDevice->playback.internalChannelMap, descriptorPlayback.channelMap, descriptorPlayback.channels); - pDevice->playback.internalPeriodSizeInFrames = descriptorPlayback.periodSizeInFrames; - pDevice->playback.internalPeriods = descriptorPlayback.periodCount; - - if (pDevice->playback.internalPeriodSizeInFrames == 0) { - pDevice->playback.internalPeriodSizeInFrames = ma_calculate_buffer_size_in_frames_from_milliseconds(descriptorPlayback.periodSizeInMilliseconds, descriptorPlayback.sampleRate); - } - } - - - /* - The name of the device can be retrieved from device info. This may be temporary and replaced with a `ma_device_get_info(pDevice, deviceType)` instead. - For loopback devices, we need to retrieve the name of the playback device. - */ - { - ma_device_info deviceInfo; - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex || pConfig->deviceType == ma_device_type_loopback) { - result = ma_device_get_info(pDevice, (pConfig->deviceType == ma_device_type_loopback) ? ma_device_type_playback : ma_device_type_capture, &deviceInfo); - if (result == MA_SUCCESS) { - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), deviceInfo.name, (size_t)-1); - } else { - /* We failed to retrieve the device info. Fall back to a default name. */ - if (descriptorCapture.pDeviceID == NULL) { - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), MA_DEFAULT_CAPTURE_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDevice->capture.name, sizeof(pDevice->capture.name), "Capture Device", (size_t)-1); - } - } - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - result = ma_device_get_info(pDevice, ma_device_type_playback, &deviceInfo); - if (result == MA_SUCCESS) { - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), deviceInfo.name, (size_t)-1); - } else { - /* We failed to retrieve the device info. Fall back to a default name. */ - if (descriptorPlayback.pDeviceID == NULL) { - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), MA_DEFAULT_PLAYBACK_DEVICE_NAME, (size_t)-1); - } else { - ma_strncpy_s(pDevice->playback.name, sizeof(pDevice->playback.name), "Playback Device", (size_t)-1); - } - } - } - } - - - ma_device__post_init_setup(pDevice, pConfig->deviceType); -#endif - - result = ma_device_post_init(pDevice, pConfig->deviceType, &descriptorPlayback, &descriptorCapture); - if (result != MA_SUCCESS) { - ma_device_uninit(pDevice); - return result; - } - - - - /* - If we're using fixed sized callbacks we'll need to make use of an intermediary buffer. Needs to - be done after post_init_setup() because we'll need access to the sample rate. - */ - if (pConfig->noFixedSizedCallback == MA_FALSE) { - /* We're using a fixed sized data callback so we'll need an intermediary buffer. */ - ma_uint32 intermediaryBufferCap = pConfig->periodSizeInFrames; - if (intermediaryBufferCap == 0) { - intermediaryBufferCap = ma_calculate_buffer_size_in_frames_from_milliseconds(pConfig->periodSizeInMilliseconds, pDevice->sampleRate); - } - - if (pConfig->deviceType == ma_device_type_capture || pConfig->deviceType == ma_device_type_duplex || pConfig->deviceType == ma_device_type_loopback) { - ma_uint32 intermediaryBufferSizeInBytes; - - pDevice->capture.intermediaryBufferLen = 0; - pDevice->capture.intermediaryBufferCap = intermediaryBufferCap; - if (pDevice->capture.intermediaryBufferCap == 0) { - pDevice->capture.intermediaryBufferCap = pDevice->capture.internalPeriodSizeInFrames; - } - - intermediaryBufferSizeInBytes = pDevice->capture.intermediaryBufferCap * ma_get_bytes_per_frame(pDevice->capture.format, pDevice->capture.channels); - - pDevice->capture.pIntermediaryBuffer = ma_malloc((size_t)intermediaryBufferSizeInBytes, &pContext->allocationCallbacks); - if (pDevice->capture.pIntermediaryBuffer == NULL) { - ma_device_uninit(pDevice); - return MA_OUT_OF_MEMORY; - } - - /* Silence the buffer for safety. */ - ma_silence_pcm_frames(pDevice->capture.pIntermediaryBuffer, pDevice->capture.intermediaryBufferCap, pDevice->capture.format, pDevice->capture.channels); - pDevice->capture.intermediaryBufferLen = pDevice->capture.intermediaryBufferCap; - } - - if (pConfig->deviceType == ma_device_type_playback || pConfig->deviceType == ma_device_type_duplex) { - ma_uint64 intermediaryBufferSizeInBytes; - - pDevice->playback.intermediaryBufferLen = 0; - if (pConfig->deviceType == ma_device_type_duplex) { - pDevice->playback.intermediaryBufferCap = pDevice->capture.intermediaryBufferCap; /* In duplex mode, make sure the intermediary buffer is always the same size as the capture side. */ - } else { - pDevice->playback.intermediaryBufferCap = intermediaryBufferCap; - if (pDevice->playback.intermediaryBufferCap == 0) { - pDevice->playback.intermediaryBufferCap = pDevice->playback.internalPeriodSizeInFrames; - } - } - - intermediaryBufferSizeInBytes = pDevice->playback.intermediaryBufferCap * ma_get_bytes_per_frame(pDevice->playback.format, pDevice->playback.channels); - - pDevice->playback.pIntermediaryBuffer = ma_malloc((size_t)intermediaryBufferSizeInBytes, &pContext->allocationCallbacks); - if (pDevice->playback.pIntermediaryBuffer == NULL) { - ma_device_uninit(pDevice); - return MA_OUT_OF_MEMORY; - } - - /* Silence the buffer for safety. */ - ma_silence_pcm_frames(pDevice->playback.pIntermediaryBuffer, pDevice->playback.intermediaryBufferCap, pDevice->playback.format, pDevice->playback.channels); - pDevice->playback.intermediaryBufferLen = 0; - } - } else { - /* Not using a fixed sized data callback so no need for an intermediary buffer. */ - } - - - /* Some backends don't require the worker thread. */ - if (!ma_context_is_backend_asynchronous(pContext)) { - /* The worker thread. */ - result = ma_thread_create(&pDevice->thread, pContext->threadPriority, pContext->threadStackSize, ma_worker_thread, pDevice, &pContext->allocationCallbacks); - if (result != MA_SUCCESS) { - ma_device_uninit(pDevice); - return result; - } - - /* Wait for the worker thread to put the device into it's stopped state for real. */ - ma_event_wait(&pDevice->stopEvent); - MA_ASSERT(ma_device_get_state(pDevice) == ma_device_state_stopped); - } else { - /* - If the backend is asynchronous and the device is duplex, we'll need an intermediary ring buffer. Note that this needs to be done - after ma_device__post_init_setup(). - */ - if (ma_context_is_backend_asynchronous(pContext)) { - if (pConfig->deviceType == ma_device_type_duplex) { - result = ma_duplex_rb_init(pDevice->capture.format, pDevice->capture.channels, pDevice->sampleRate, pDevice->capture.internalSampleRate, pDevice->capture.internalPeriodSizeInFrames, &pDevice->pContext->allocationCallbacks, &pDevice->duplexRB); - if (result != MA_SUCCESS) { - ma_device_uninit(pDevice); - return result; - } - } - } - - ma_device__set_state(pDevice, ma_device_state_stopped); - } - - /* Log device information. */ - { - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, "[%s]\n", ma_get_backend_name(pDevice->pContext->backend)); - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex || pDevice->type == ma_device_type_loopback) { - char name[MA_MAX_DEVICE_NAME_LENGTH + 1]; - ma_device_get_name(pDevice, (pDevice->type == ma_device_type_loopback) ? ma_device_type_playback : ma_device_type_capture, name, sizeof(name), NULL); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " %s (%s)\n", name, "Capture"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Format: %s -> %s\n", ma_get_format_name(pDevice->capture.internalFormat), ma_get_format_name(pDevice->capture.format)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channels: %d -> %d\n", pDevice->capture.internalChannels, pDevice->capture.channels); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Sample Rate: %d -> %d\n", pDevice->capture.internalSampleRate, pDevice->sampleRate); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Buffer Size: %d*%d (%d)\n", pDevice->capture.internalPeriodSizeInFrames, pDevice->capture.internalPeriods, (pDevice->capture.internalPeriodSizeInFrames * pDevice->capture.internalPeriods)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Conversion:\n"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Pre Format Conversion: %s\n", pDevice->capture.converter.hasPreFormatConversion ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Post Format Conversion: %s\n", pDevice->capture.converter.hasPostFormatConversion ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channel Routing: %s\n", pDevice->capture.converter.hasChannelConverter ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Resampling: %s\n", pDevice->capture.converter.hasResampler ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Passthrough: %s\n", pDevice->capture.converter.isPassthrough ? "YES" : "NO"); - { - char channelMapStr[1024]; - ma_channel_map_to_string(pDevice->capture.internalChannelMap, pDevice->capture.internalChannels, channelMapStr, sizeof(channelMapStr)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channel Map In: {%s}\n", channelMapStr); - - ma_channel_map_to_string(pDevice->capture.channelMap, pDevice->capture.channels, channelMapStr, sizeof(channelMapStr)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channel Map Out: {%s}\n", channelMapStr); - } - } - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - char name[MA_MAX_DEVICE_NAME_LENGTH + 1]; - ma_device_get_name(pDevice, ma_device_type_playback, name, sizeof(name), NULL); - - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " %s (%s)\n", name, "Playback"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Format: %s -> %s\n", ma_get_format_name(pDevice->playback.format), ma_get_format_name(pDevice->playback.internalFormat)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channels: %d -> %d\n", pDevice->playback.channels, pDevice->playback.internalChannels); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Sample Rate: %d -> %d\n", pDevice->sampleRate, pDevice->playback.internalSampleRate); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Buffer Size: %d*%d (%d)\n", pDevice->playback.internalPeriodSizeInFrames, pDevice->playback.internalPeriods, (pDevice->playback.internalPeriodSizeInFrames * pDevice->playback.internalPeriods)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Conversion:\n"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Pre Format Conversion: %s\n", pDevice->playback.converter.hasPreFormatConversion ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Post Format Conversion: %s\n", pDevice->playback.converter.hasPostFormatConversion ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channel Routing: %s\n", pDevice->playback.converter.hasChannelConverter ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Resampling: %s\n", pDevice->playback.converter.hasResampler ? "YES" : "NO"); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Passthrough: %s\n", pDevice->playback.converter.isPassthrough ? "YES" : "NO"); - { - char channelMapStr[1024]; - ma_channel_map_to_string(pDevice->playback.channelMap, pDevice->playback.channels, channelMapStr, sizeof(channelMapStr)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channel Map In: {%s}\n", channelMapStr); - - ma_channel_map_to_string(pDevice->playback.internalChannelMap, pDevice->playback.internalChannels, channelMapStr, sizeof(channelMapStr)); - ma_log_postf(ma_device_get_log(pDevice), MA_LOG_LEVEL_INFO, " Channel Map Out: {%s}\n", channelMapStr); - } - } - } - - MA_ASSERT(ma_device_get_state(pDevice) == ma_device_state_stopped); - return MA_SUCCESS; -} - -MA_API ma_result ma_device_init_ex(const ma_backend backends[], ma_uint32 backendCount, const ma_context_config* pContextConfig, const ma_device_config* pConfig, ma_device* pDevice) -{ - ma_result result; - ma_context* pContext; - ma_backend defaultBackends[ma_backend_null+1]; - ma_uint32 iBackend; - ma_backend* pBackendsToIterate; - ma_uint32 backendsToIterateCount; - ma_allocation_callbacks allocationCallbacks; - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pContextConfig != NULL) { - result = ma_allocation_callbacks_init_copy(&allocationCallbacks, &pContextConfig->allocationCallbacks); - if (result != MA_SUCCESS) { - return result; - } - } else { - allocationCallbacks = ma_allocation_callbacks_init_default(); - } - - pContext = (ma_context*)ma_malloc(sizeof(*pContext), &allocationCallbacks); - if (pContext == NULL) { - return MA_OUT_OF_MEMORY; - } - - for (iBackend = 0; iBackend <= ma_backend_null; ++iBackend) { - defaultBackends[iBackend] = (ma_backend)iBackend; - } - - pBackendsToIterate = (ma_backend*)backends; - backendsToIterateCount = backendCount; - if (pBackendsToIterate == NULL) { - pBackendsToIterate = (ma_backend*)defaultBackends; - backendsToIterateCount = ma_countof(defaultBackends); - } - - result = MA_NO_BACKEND; - - for (iBackend = 0; iBackend < backendsToIterateCount; ++iBackend) { - /* - This is a hack for iOS. If the context config is null, there's a good chance the - `ma_device_init(NULL, &deviceConfig, pDevice);` pattern is being used. In this - case, set the session category based on the device type. - */ - #if defined(MA_APPLE_MOBILE) - ma_context_config contextConfig; - - if (pContextConfig == NULL) { - contextConfig = ma_context_config_init(); - switch (pConfig->deviceType) { - case ma_device_type_duplex: { - contextConfig.coreaudio.sessionCategory = ma_ios_session_category_play_and_record; - } break; - case ma_device_type_capture: { - contextConfig.coreaudio.sessionCategory = ma_ios_session_category_record; - } break; - case ma_device_type_playback: - default: { - contextConfig.coreaudio.sessionCategory = ma_ios_session_category_playback; - } break; - } - - pContextConfig = &contextConfig; - } - #endif - - result = ma_context_init(&pBackendsToIterate[iBackend], 1, pContextConfig, pContext); - if (result == MA_SUCCESS) { - result = ma_device_init(pContext, pConfig, pDevice); - if (result == MA_SUCCESS) { - break; /* Success. */ - } else { - ma_context_uninit(pContext); /* Failure. */ - } - } - } - - if (result != MA_SUCCESS) { - ma_free(pContext, &allocationCallbacks); - return result; - } - - pDevice->isOwnerOfContext = MA_TRUE; - return result; -} - -MA_API void ma_device_uninit(ma_device* pDevice) -{ - if (!ma_device__is_initialized(pDevice)) { - return; - } - - /* Make sure the device is stopped first. The backends will probably handle this naturally, but I like to do it explicitly for my own sanity. */ - if (ma_device_is_started(pDevice)) { - ma_device_stop(pDevice); - } - - /* Putting the device into an uninitialized state will make the worker thread return. */ - ma_device__set_state(pDevice, ma_device_state_uninitialized); - - /* Wake up the worker thread and wait for it to properly terminate. */ - if (!ma_context_is_backend_asynchronous(pDevice->pContext)) { - ma_event_signal(&pDevice->wakeupEvent); - ma_thread_wait(&pDevice->thread); - } - - if (pDevice->pContext->callbacks.onDeviceUninit != NULL) { - pDevice->pContext->callbacks.onDeviceUninit(pDevice); - } - - - ma_event_uninit(&pDevice->stopEvent); - ma_event_uninit(&pDevice->startEvent); - ma_event_uninit(&pDevice->wakeupEvent); - ma_mutex_uninit(&pDevice->startStopLock); - - if (ma_context_is_backend_asynchronous(pDevice->pContext)) { - if (pDevice->type == ma_device_type_duplex) { - ma_duplex_rb_uninit(&pDevice->duplexRB); - } - } - - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_duplex || pDevice->type == ma_device_type_loopback) { - ma_data_converter_uninit(&pDevice->capture.converter, &pDevice->pContext->allocationCallbacks); - } - if (pDevice->type == ma_device_type_playback || pDevice->type == ma_device_type_duplex) { - ma_data_converter_uninit(&pDevice->playback.converter, &pDevice->pContext->allocationCallbacks); - } - - if (pDevice->playback.pInputCache != NULL) { - ma_free(pDevice->playback.pInputCache, &pDevice->pContext->allocationCallbacks); - } - - if (pDevice->capture.pIntermediaryBuffer != NULL) { - ma_free(pDevice->capture.pIntermediaryBuffer, &pDevice->pContext->allocationCallbacks); - } - if (pDevice->playback.pIntermediaryBuffer != NULL) { - ma_free(pDevice->playback.pIntermediaryBuffer, &pDevice->pContext->allocationCallbacks); - } - - if (pDevice->isOwnerOfContext) { - ma_allocation_callbacks allocationCallbacks = pDevice->pContext->allocationCallbacks; - - ma_context_uninit(pDevice->pContext); - ma_free(pDevice->pContext, &allocationCallbacks); - } - - MA_ZERO_OBJECT(pDevice); -} - -MA_API ma_context* ma_device_get_context(ma_device* pDevice) -{ - if (pDevice == NULL) { - return NULL; - } - - return pDevice->pContext; -} - -MA_API ma_log* ma_device_get_log(ma_device* pDevice) -{ - return ma_context_get_log(ma_device_get_context(pDevice)); -} - -MA_API ma_result ma_device_get_info(ma_device* pDevice, ma_device_type type, ma_device_info* pDeviceInfo) -{ - if (pDeviceInfo == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDeviceInfo); - - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - /* If the onDeviceGetInfo() callback is set, use that. Otherwise we'll fall back to ma_context_get_device_info(). */ - if (pDevice->pContext->callbacks.onDeviceGetInfo != NULL) { - return pDevice->pContext->callbacks.onDeviceGetInfo(pDevice, type, pDeviceInfo); - } - - /* Getting here means onDeviceGetInfo is not implemented so we need to fall back to an alternative. */ - if (type == ma_device_type_playback) { - return ma_context_get_device_info(pDevice->pContext, type, pDevice->playback.pID, pDeviceInfo); - } else { - return ma_context_get_device_info(pDevice->pContext, type, pDevice->capture.pID, pDeviceInfo); - } -} - -MA_API ma_result ma_device_get_name(ma_device* pDevice, ma_device_type type, char* pName, size_t nameCap, size_t* pLengthNotIncludingNullTerminator) -{ - ma_result result; - ma_device_info deviceInfo; - - if (pLengthNotIncludingNullTerminator != NULL) { - *pLengthNotIncludingNullTerminator = 0; - } - - if (pName != NULL && nameCap > 0) { - pName[0] = '\0'; - } - - result = ma_device_get_info(pDevice, type, &deviceInfo); - if (result != MA_SUCCESS) { - return result; - } - - if (pName != NULL) { - ma_strncpy_s(pName, nameCap, deviceInfo.name, (size_t)-1); - - /* - For safety, make sure the length is based on the truncated output string rather than the - source. Otherwise the caller might assume the output buffer contains more content than it - actually does. - */ - if (pLengthNotIncludingNullTerminator != NULL) { - *pLengthNotIncludingNullTerminator = strlen(pName); - } - } else { - /* Name not specified. Just report the length of the source string. */ - if (pLengthNotIncludingNullTerminator != NULL) { - *pLengthNotIncludingNullTerminator = strlen(deviceInfo.name); - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_device_start(ma_device* pDevice) -{ - ma_result result; - - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_device_get_state(pDevice) == ma_device_state_uninitialized) { - return MA_INVALID_OPERATION; /* Not initialized. */ - } - - if (ma_device_get_state(pDevice) == ma_device_state_started) { - return MA_SUCCESS; /* Already started. */ - } - - ma_mutex_lock(&pDevice->startStopLock); - { - /* Starting and stopping are wrapped in a mutex which means we can assert that the device is in a stopped or paused state. */ - MA_ASSERT(ma_device_get_state(pDevice) == ma_device_state_stopped); - - ma_device__set_state(pDevice, ma_device_state_starting); - - /* Asynchronous backends need to be handled differently. */ - if (ma_context_is_backend_asynchronous(pDevice->pContext)) { - if (pDevice->pContext->callbacks.onDeviceStart != NULL) { - result = pDevice->pContext->callbacks.onDeviceStart(pDevice); - } else { - result = MA_INVALID_OPERATION; - } - - if (result == MA_SUCCESS) { - ma_device__set_state(pDevice, ma_device_state_started); - ma_device__on_notification_started(pDevice); - } - } else { - /* - Synchronous backends are started by signaling an event that's being waited on in the worker thread. We first wake up the - thread and then wait for the start event. - */ - ma_event_signal(&pDevice->wakeupEvent); - - /* - Wait for the worker thread to finish starting the device. Note that the worker thread will be the one who puts the device - into the started state. Don't call ma_device__set_state() here. - */ - ma_event_wait(&pDevice->startEvent); - result = pDevice->workResult; - } - - /* We changed the state from stopped to started, so if we failed, make sure we put the state back to stopped. */ - if (result != MA_SUCCESS) { - ma_device__set_state(pDevice, ma_device_state_stopped); - } - } - ma_mutex_unlock(&pDevice->startStopLock); - - return result; -} - -MA_API ma_result ma_device_stop(ma_device* pDevice) -{ - ma_result result; - - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_device_get_state(pDevice) == ma_device_state_uninitialized) { - return MA_INVALID_OPERATION; /* Not initialized. */ - } - - if (ma_device_get_state(pDevice) == ma_device_state_stopped) { - return MA_SUCCESS; /* Already stopped. */ - } - - ma_mutex_lock(&pDevice->startStopLock); - { - /* Starting and stopping are wrapped in a mutex which means we can assert that the device is in a started or paused state. */ - MA_ASSERT(ma_device_get_state(pDevice) == ma_device_state_started); - - ma_device__set_state(pDevice, ma_device_state_stopping); - - /* Asynchronous backends need to be handled differently. */ - if (ma_context_is_backend_asynchronous(pDevice->pContext)) { - /* Asynchronous backends must have a stop operation. */ - if (pDevice->pContext->callbacks.onDeviceStop != NULL) { - result = pDevice->pContext->callbacks.onDeviceStop(pDevice); - } else { - result = MA_INVALID_OPERATION; - } - - ma_device__set_state(pDevice, ma_device_state_stopped); - } else { - /* - Synchronous backends. The stop callback is always called from the worker thread. Do not call the stop callback here. If - the backend is implementing it's own audio thread loop we'll need to wake it up if required. Note that we need to make - sure the state of the device is *not* playing right now, which it shouldn't be since we set it above. This is super - important though, so I'm asserting it here as well for extra safety in case we accidentally change something later. - */ - MA_ASSERT(ma_device_get_state(pDevice) != ma_device_state_started); - - if (pDevice->pContext->callbacks.onDeviceDataLoopWakeup != NULL) { - pDevice->pContext->callbacks.onDeviceDataLoopWakeup(pDevice); - } - - /* - We need to wait for the worker thread to become available for work before returning. Note that the worker thread will be - the one who puts the device into the stopped state. Don't call ma_device__set_state() here. - */ - ma_event_wait(&pDevice->stopEvent); - result = MA_SUCCESS; - } - - /* - This is a safety measure to ensure the internal buffer has been cleared so any leftover - does not get played the next time the device starts. Ideally this should be drained by - the backend first. - */ - pDevice->playback.intermediaryBufferLen = 0; - pDevice->playback.inputCacheConsumed = 0; - pDevice->playback.inputCacheRemaining = 0; - } - ma_mutex_unlock(&pDevice->startStopLock); - - return result; -} - -MA_API ma_bool32 ma_device_is_started(const ma_device* pDevice) -{ - return ma_device_get_state(pDevice) == ma_device_state_started; -} - -MA_API ma_device_state ma_device_get_state(const ma_device* pDevice) -{ - if (pDevice == NULL) { - return ma_device_state_uninitialized; - } - - return ma_atomic_device_state_get((ma_atomic_device_state*)&pDevice->state); /* Naughty cast to get rid of a const warning. */ -} - -MA_API ma_result ma_device_set_master_volume(ma_device* pDevice, float volume) -{ - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - if (volume < 0.0f) { - return MA_INVALID_ARGS; - } - - ma_atomic_float_set(&pDevice->masterVolumeFactor, volume); - - return MA_SUCCESS; -} - -MA_API ma_result ma_device_get_master_volume(ma_device* pDevice, float* pVolume) -{ - if (pVolume == NULL) { - return MA_INVALID_ARGS; - } - - if (pDevice == NULL) { - *pVolume = 0; - return MA_INVALID_ARGS; - } - - *pVolume = ma_atomic_float_get(&pDevice->masterVolumeFactor); - - return MA_SUCCESS; -} - -MA_API ma_result ma_device_set_master_volume_db(ma_device* pDevice, float gainDB) -{ - if (gainDB > 0) { - return MA_INVALID_ARGS; - } - - return ma_device_set_master_volume(pDevice, ma_volume_db_to_linear(gainDB)); -} - -MA_API ma_result ma_device_get_master_volume_db(ma_device* pDevice, float* pGainDB) -{ - float factor; - ma_result result; - - if (pGainDB == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_device_get_master_volume(pDevice, &factor); - if (result != MA_SUCCESS) { - *pGainDB = 0; - return result; - } - - *pGainDB = ma_volume_linear_to_db(factor); - - return MA_SUCCESS; -} - - -MA_API ma_result ma_device_handle_backend_data_callback(ma_device* pDevice, void* pOutput, const void* pInput, ma_uint32 frameCount) -{ - if (pDevice == NULL) { - return MA_INVALID_ARGS; - } - - if (pOutput == NULL && pInput == NULL) { - return MA_INVALID_ARGS; - } - - if (pDevice->type == ma_device_type_duplex) { - if (pInput != NULL) { - ma_device__handle_duplex_callback_capture(pDevice, frameCount, pInput, &pDevice->duplexRB.rb); - } - - if (pOutput != NULL) { - ma_device__handle_duplex_callback_playback(pDevice, frameCount, pOutput, &pDevice->duplexRB.rb); - } - } else { - if (pDevice->type == ma_device_type_capture || pDevice->type == ma_device_type_loopback) { - if (pInput == NULL) { - return MA_INVALID_ARGS; - } - - ma_device__send_frames_to_client(pDevice, frameCount, pInput); - } - - if (pDevice->type == ma_device_type_playback) { - if (pOutput == NULL) { - return MA_INVALID_ARGS; - } - - ma_device__read_frames_from_client(pDevice, frameCount, pOutput); - } - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_calculate_buffer_size_in_frames_from_descriptor(const ma_device_descriptor* pDescriptor, ma_uint32 nativeSampleRate, ma_performance_profile performanceProfile) -{ - if (pDescriptor == NULL) { - return 0; - } - - /* - We must have a non-0 native sample rate, but some backends don't allow retrieval of this at the - time when the size of the buffer needs to be determined. In this case we need to just take a best - guess and move on. We'll try using the sample rate in pDescriptor first. If that's not set we'll - just fall back to MA_DEFAULT_SAMPLE_RATE. - */ - if (nativeSampleRate == 0) { - nativeSampleRate = pDescriptor->sampleRate; - } - if (nativeSampleRate == 0) { - nativeSampleRate = MA_DEFAULT_SAMPLE_RATE; - } - - MA_ASSERT(nativeSampleRate != 0); - - if (pDescriptor->periodSizeInFrames == 0) { - if (pDescriptor->periodSizeInMilliseconds == 0) { - if (performanceProfile == ma_performance_profile_low_latency) { - return ma_calculate_buffer_size_in_frames_from_milliseconds(MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_LOW_LATENCY, nativeSampleRate); - } else { - return ma_calculate_buffer_size_in_frames_from_milliseconds(MA_DEFAULT_PERIOD_SIZE_IN_MILLISECONDS_CONSERVATIVE, nativeSampleRate); - } - } else { - return ma_calculate_buffer_size_in_frames_from_milliseconds(pDescriptor->periodSizeInMilliseconds, nativeSampleRate); - } - } else { - return pDescriptor->periodSizeInFrames; - } -} -#endif /* MA_NO_DEVICE_IO */ - - -MA_API ma_uint32 ma_calculate_buffer_size_in_milliseconds_from_frames(ma_uint32 bufferSizeInFrames, ma_uint32 sampleRate) -{ - /* Prevent a division by zero. */ - if (sampleRate == 0) { - return 0; - } - - return bufferSizeInFrames*1000 / sampleRate; -} - -MA_API ma_uint32 ma_calculate_buffer_size_in_frames_from_milliseconds(ma_uint32 bufferSizeInMilliseconds, ma_uint32 sampleRate) -{ - /* Prevent a division by zero. */ - if (sampleRate == 0) { - return 0; - } - - return bufferSizeInMilliseconds*sampleRate / 1000; -} - -MA_API void ma_copy_pcm_frames(void* dst, const void* src, ma_uint64 frameCount, ma_format format, ma_uint32 channels) -{ - if (dst == src) { - return; /* No-op. */ - } - - ma_copy_memory_64(dst, src, frameCount * ma_get_bytes_per_frame(format, channels)); -} - -MA_API void ma_silence_pcm_frames(void* p, ma_uint64 frameCount, ma_format format, ma_uint32 channels) -{ - if (format == ma_format_u8) { - ma_uint64 sampleCount = frameCount * channels; - ma_uint64 iSample; - for (iSample = 0; iSample < sampleCount; iSample += 1) { - ((ma_uint8*)p)[iSample] = 128; - } - } else { - ma_zero_memory_64(p, frameCount * ma_get_bytes_per_frame(format, channels)); - } -} - -MA_API void* ma_offset_pcm_frames_ptr(void* p, ma_uint64 offsetInFrames, ma_format format, ma_uint32 channels) -{ - return ma_offset_ptr(p, offsetInFrames * ma_get_bytes_per_frame(format, channels)); -} - -MA_API const void* ma_offset_pcm_frames_const_ptr(const void* p, ma_uint64 offsetInFrames, ma_format format, ma_uint32 channels) -{ - return ma_offset_ptr(p, offsetInFrames * ma_get_bytes_per_frame(format, channels)); -} - - -MA_API void ma_clip_samples_u8(ma_uint8* pDst, const ma_int16* pSrc, ma_uint64 count) -{ - ma_uint64 iSample; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_u8(pSrc[iSample]); - } -} - -MA_API void ma_clip_samples_s16(ma_int16* pDst, const ma_int32* pSrc, ma_uint64 count) -{ - ma_uint64 iSample; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_s16(pSrc[iSample]); - } -} - -MA_API void ma_clip_samples_s24(ma_uint8* pDst, const ma_int64* pSrc, ma_uint64 count) -{ - ma_uint64 iSample; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - for (iSample = 0; iSample < count; iSample += 1) { - ma_int64 s = ma_clip_s24(pSrc[iSample]); - pDst[iSample*3 + 0] = (ma_uint8)((s & 0x000000FF) >> 0); - pDst[iSample*3 + 1] = (ma_uint8)((s & 0x0000FF00) >> 8); - pDst[iSample*3 + 2] = (ma_uint8)((s & 0x00FF0000) >> 16); - } -} - -MA_API void ma_clip_samples_s32(ma_int32* pDst, const ma_int64* pSrc, ma_uint64 count) -{ - ma_uint64 iSample; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_s32(pSrc[iSample]); - } -} - -MA_API void ma_clip_samples_f32(float* pDst, const float* pSrc, ma_uint64 count) -{ - ma_uint64 iSample; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_f32(pSrc[iSample]); - } -} - -MA_API void ma_clip_pcm_frames(void* pDst, const void* pSrc, ma_uint64 frameCount, ma_format format, ma_uint32 channels) -{ - ma_uint64 sampleCount; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - sampleCount = frameCount * channels; - - switch (format) { - case ma_format_u8: ma_clip_samples_u8( (ma_uint8*)pDst, (const ma_int16*)pSrc, sampleCount); break; - case ma_format_s16: ma_clip_samples_s16((ma_int16*)pDst, (const ma_int32*)pSrc, sampleCount); break; - case ma_format_s24: ma_clip_samples_s24((ma_uint8*)pDst, (const ma_int64*)pSrc, sampleCount); break; - case ma_format_s32: ma_clip_samples_s32((ma_int32*)pDst, (const ma_int64*)pSrc, sampleCount); break; - case ma_format_f32: ma_clip_samples_f32(( float*)pDst, (const float*)pSrc, sampleCount); break; - - /* Do nothing if we don't know the format. We're including these here to silence a compiler warning about enums not being handled by the switch. */ - case ma_format_unknown: - case ma_format_count: - break; - } -} - - -MA_API void ma_copy_and_apply_volume_factor_u8(ma_uint8* pSamplesOut, const ma_uint8* pSamplesIn, ma_uint64 sampleCount, float factor) -{ - ma_uint64 iSample; - - if (pSamplesOut == NULL || pSamplesIn == NULL) { - return; - } - - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamplesOut[iSample] = (ma_uint8)(pSamplesIn[iSample] * factor); - } -} - -MA_API void ma_copy_and_apply_volume_factor_s16(ma_int16* pSamplesOut, const ma_int16* pSamplesIn, ma_uint64 sampleCount, float factor) -{ - ma_uint64 iSample; - - if (pSamplesOut == NULL || pSamplesIn == NULL) { - return; - } - - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamplesOut[iSample] = (ma_int16)(pSamplesIn[iSample] * factor); - } -} - -MA_API void ma_copy_and_apply_volume_factor_s24(void* pSamplesOut, const void* pSamplesIn, ma_uint64 sampleCount, float factor) -{ - ma_uint64 iSample; - ma_uint8* pSamplesOut8; - ma_uint8* pSamplesIn8; - - if (pSamplesOut == NULL || pSamplesIn == NULL) { - return; - } - - pSamplesOut8 = (ma_uint8*)pSamplesOut; - pSamplesIn8 = (ma_uint8*)pSamplesIn; - - for (iSample = 0; iSample < sampleCount; iSample += 1) { - ma_int32 sampleS32; - - sampleS32 = (ma_int32)(((ma_uint32)(pSamplesIn8[iSample*3+0]) << 8) | ((ma_uint32)(pSamplesIn8[iSample*3+1]) << 16) | ((ma_uint32)(pSamplesIn8[iSample*3+2])) << 24); - sampleS32 = (ma_int32)(sampleS32 * factor); - - pSamplesOut8[iSample*3+0] = (ma_uint8)(((ma_uint32)sampleS32 & 0x0000FF00) >> 8); - pSamplesOut8[iSample*3+1] = (ma_uint8)(((ma_uint32)sampleS32 & 0x00FF0000) >> 16); - pSamplesOut8[iSample*3+2] = (ma_uint8)(((ma_uint32)sampleS32 & 0xFF000000) >> 24); - } -} - -MA_API void ma_copy_and_apply_volume_factor_s32(ma_int32* pSamplesOut, const ma_int32* pSamplesIn, ma_uint64 sampleCount, float factor) -{ - ma_uint64 iSample; - - if (pSamplesOut == NULL || pSamplesIn == NULL) { - return; - } - - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamplesOut[iSample] = (ma_int32)(pSamplesIn[iSample] * factor); - } -} - -MA_API void ma_copy_and_apply_volume_factor_f32(float* pSamplesOut, const float* pSamplesIn, ma_uint64 sampleCount, float factor) -{ - ma_uint64 iSample; - - if (pSamplesOut == NULL || pSamplesIn == NULL) { - return; - } - - if (factor == 1) { - if (pSamplesOut == pSamplesIn) { - /* In place. No-op. */ - } else { - /* Just a copy. */ - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamplesOut[iSample] = pSamplesIn[iSample]; - } - } - } else { - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamplesOut[iSample] = pSamplesIn[iSample] * factor; - } - } -} - -MA_API void ma_apply_volume_factor_u8(ma_uint8* pSamples, ma_uint64 sampleCount, float factor) -{ - ma_copy_and_apply_volume_factor_u8(pSamples, pSamples, sampleCount, factor); -} - -MA_API void ma_apply_volume_factor_s16(ma_int16* pSamples, ma_uint64 sampleCount, float factor) -{ - ma_copy_and_apply_volume_factor_s16(pSamples, pSamples, sampleCount, factor); -} - -MA_API void ma_apply_volume_factor_s24(void* pSamples, ma_uint64 sampleCount, float factor) -{ - ma_copy_and_apply_volume_factor_s24(pSamples, pSamples, sampleCount, factor); -} - -MA_API void ma_apply_volume_factor_s32(ma_int32* pSamples, ma_uint64 sampleCount, float factor) -{ - ma_copy_and_apply_volume_factor_s32(pSamples, pSamples, sampleCount, factor); -} - -MA_API void ma_apply_volume_factor_f32(float* pSamples, ma_uint64 sampleCount, float factor) -{ - ma_copy_and_apply_volume_factor_f32(pSamples, pSamples, sampleCount, factor); -} - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_u8(ma_uint8* pFramesOut, const ma_uint8* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_u8(pFramesOut, pFramesIn, frameCount*channels, factor); -} - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_s16(ma_int16* pFramesOut, const ma_int16* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_s16(pFramesOut, pFramesIn, frameCount*channels, factor); -} - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_s24(void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_s24(pFramesOut, pFramesIn, frameCount*channels, factor); -} - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_s32(ma_int32* pFramesOut, const ma_int32* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_s32(pFramesOut, pFramesIn, frameCount*channels, factor); -} - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames_f32(float* pFramesOut, const float* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_f32(pFramesOut, pFramesIn, frameCount*channels, factor); -} - -MA_API void ma_copy_and_apply_volume_factor_pcm_frames(void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount, ma_format format, ma_uint32 channels, float factor) -{ - switch (format) - { - case ma_format_u8: ma_copy_and_apply_volume_factor_pcm_frames_u8 ((ma_uint8*)pFramesOut, (const ma_uint8*)pFramesIn, frameCount, channels, factor); return; - case ma_format_s16: ma_copy_and_apply_volume_factor_pcm_frames_s16((ma_int16*)pFramesOut, (const ma_int16*)pFramesIn, frameCount, channels, factor); return; - case ma_format_s24: ma_copy_and_apply_volume_factor_pcm_frames_s24( pFramesOut, pFramesIn, frameCount, channels, factor); return; - case ma_format_s32: ma_copy_and_apply_volume_factor_pcm_frames_s32((ma_int32*)pFramesOut, (const ma_int32*)pFramesIn, frameCount, channels, factor); return; - case ma_format_f32: ma_copy_and_apply_volume_factor_pcm_frames_f32( (float*)pFramesOut, (const float*)pFramesIn, frameCount, channels, factor); return; - default: return; /* Do nothing. */ - } -} - -MA_API void ma_apply_volume_factor_pcm_frames_u8(ma_uint8* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_pcm_frames_u8(pFrames, pFrames, frameCount, channels, factor); -} - -MA_API void ma_apply_volume_factor_pcm_frames_s16(ma_int16* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_pcm_frames_s16(pFrames, pFrames, frameCount, channels, factor); -} - -MA_API void ma_apply_volume_factor_pcm_frames_s24(void* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_pcm_frames_s24(pFrames, pFrames, frameCount, channels, factor); -} - -MA_API void ma_apply_volume_factor_pcm_frames_s32(ma_int32* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_pcm_frames_s32(pFrames, pFrames, frameCount, channels, factor); -} - -MA_API void ma_apply_volume_factor_pcm_frames_f32(float* pFrames, ma_uint64 frameCount, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_pcm_frames_f32(pFrames, pFrames, frameCount, channels, factor); -} - -MA_API void ma_apply_volume_factor_pcm_frames(void* pFramesOut, ma_uint64 frameCount, ma_format format, ma_uint32 channels, float factor) -{ - ma_copy_and_apply_volume_factor_pcm_frames(pFramesOut, pFramesOut, frameCount, format, channels, factor); -} - - -MA_API void ma_copy_and_apply_volume_factor_per_channel_f32(float* pFramesOut, const float* pFramesIn, ma_uint64 frameCount, ma_uint32 channels, float* pChannelGains) -{ - ma_uint64 iFrame; - - if (channels == 2) { - /* TODO: Do an optimized implementation for stereo and mono. Can do a SIMD optimized implementation as well. */ - } - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOut[iFrame * channels + iChannel] = pFramesIn[iFrame * channels + iChannel] * pChannelGains[iChannel]; - } - } -} - - - -static MA_INLINE ma_int16 ma_apply_volume_unclipped_u8(ma_int16 x, ma_int16 volume) -{ - return (ma_int16)(((ma_int32)x * (ma_int32)volume) >> 8); -} - -static MA_INLINE ma_int32 ma_apply_volume_unclipped_s16(ma_int32 x, ma_int16 volume) -{ - return (ma_int32)((x * volume) >> 8); -} - -static MA_INLINE ma_int64 ma_apply_volume_unclipped_s24(ma_int64 x, ma_int16 volume) -{ - return (ma_int64)((x * volume) >> 8); -} - -static MA_INLINE ma_int64 ma_apply_volume_unclipped_s32(ma_int64 x, ma_int16 volume) -{ - return (ma_int64)((x * volume) >> 8); -} - -static MA_INLINE float ma_apply_volume_unclipped_f32(float x, float volume) -{ - return x * volume; -} - - -MA_API void ma_copy_and_apply_volume_and_clip_samples_u8(ma_uint8* pDst, const ma_int16* pSrc, ma_uint64 count, float volume) -{ - ma_uint64 iSample; - ma_int16 volumeFixed; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - volumeFixed = ma_float_to_fixed_16(volume); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_u8(ma_apply_volume_unclipped_u8(pSrc[iSample], volumeFixed)); - } -} - -MA_API void ma_copy_and_apply_volume_and_clip_samples_s16(ma_int16* pDst, const ma_int32* pSrc, ma_uint64 count, float volume) -{ - ma_uint64 iSample; - ma_int16 volumeFixed; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - volumeFixed = ma_float_to_fixed_16(volume); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_s16(ma_apply_volume_unclipped_s16(pSrc[iSample], volumeFixed)); - } -} - -MA_API void ma_copy_and_apply_volume_and_clip_samples_s24(ma_uint8* pDst, const ma_int64* pSrc, ma_uint64 count, float volume) -{ - ma_uint64 iSample; - ma_int16 volumeFixed; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - volumeFixed = ma_float_to_fixed_16(volume); - - for (iSample = 0; iSample < count; iSample += 1) { - ma_int64 s = ma_clip_s24(ma_apply_volume_unclipped_s24(pSrc[iSample], volumeFixed)); - pDst[iSample*3 + 0] = (ma_uint8)((s & 0x000000FF) >> 0); - pDst[iSample*3 + 1] = (ma_uint8)((s & 0x0000FF00) >> 8); - pDst[iSample*3 + 2] = (ma_uint8)((s & 0x00FF0000) >> 16); - } -} - -MA_API void ma_copy_and_apply_volume_and_clip_samples_s32(ma_int32* pDst, const ma_int64* pSrc, ma_uint64 count, float volume) -{ - ma_uint64 iSample; - ma_int16 volumeFixed; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - volumeFixed = ma_float_to_fixed_16(volume); - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_s32(ma_apply_volume_unclipped_s32(pSrc[iSample], volumeFixed)); - } -} - -MA_API void ma_copy_and_apply_volume_and_clip_samples_f32(float* pDst, const float* pSrc, ma_uint64 count, float volume) -{ - ma_uint64 iSample; - - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - /* For the f32 case we need to make sure this supports in-place processing where the input and output buffers are the same. */ - - for (iSample = 0; iSample < count; iSample += 1) { - pDst[iSample] = ma_clip_f32(ma_apply_volume_unclipped_f32(pSrc[iSample], volume)); - } -} - -MA_API void ma_copy_and_apply_volume_and_clip_pcm_frames(void* pDst, const void* pSrc, ma_uint64 frameCount, ma_format format, ma_uint32 channels, float volume) -{ - MA_ASSERT(pDst != NULL); - MA_ASSERT(pSrc != NULL); - - if (volume == 1) { - ma_clip_pcm_frames(pDst, pSrc, frameCount, format, channels); /* Optimized case for volume = 1. */ - } else if (volume == 0) { - ma_silence_pcm_frames(pDst, frameCount, format, channels); /* Optimized case for volume = 0. */ - } else { - ma_uint64 sampleCount = frameCount * channels; - - switch (format) { - case ma_format_u8: ma_copy_and_apply_volume_and_clip_samples_u8( (ma_uint8*)pDst, (const ma_int16*)pSrc, sampleCount, volume); break; - case ma_format_s16: ma_copy_and_apply_volume_and_clip_samples_s16((ma_int16*)pDst, (const ma_int32*)pSrc, sampleCount, volume); break; - case ma_format_s24: ma_copy_and_apply_volume_and_clip_samples_s24((ma_uint8*)pDst, (const ma_int64*)pSrc, sampleCount, volume); break; - case ma_format_s32: ma_copy_and_apply_volume_and_clip_samples_s32((ma_int32*)pDst, (const ma_int64*)pSrc, sampleCount, volume); break; - case ma_format_f32: ma_copy_and_apply_volume_and_clip_samples_f32(( float*)pDst, (const float*)pSrc, sampleCount, volume); break; - - /* Do nothing if we don't know the format. We're including these here to silence a compiler warning about enums not being handled by the switch. */ - case ma_format_unknown: - case ma_format_count: - break; - } - } -} - - - -MA_API float ma_volume_linear_to_db(float factor) -{ - return 20*ma_log10f(factor); -} - -MA_API float ma_volume_db_to_linear(float gain) -{ - return ma_powf(10, gain/20.0f); -} - - -MA_API ma_result ma_mix_pcm_frames_f32(float* pDst, const float* pSrc, ma_uint64 frameCount, ma_uint32 channels, float volume) -{ - ma_uint64 iSample; - ma_uint64 sampleCount; - - if (pDst == NULL || pSrc == NULL || channels == 0) { - return MA_INVALID_ARGS; - } - - if (volume == 0) { - return MA_SUCCESS; /* No changes if the volume is 0. */ - } - - sampleCount = frameCount * channels; - - if (volume == 1) { - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pDst[iSample] += pSrc[iSample]; - } - } else { - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pDst[iSample] += ma_apply_volume_unclipped_f32(pSrc[iSample], volume); - } - } - - return MA_SUCCESS; -} - - - -/************************************************************************************************************************************************************** - -Format Conversion - -**************************************************************************************************************************************************************/ - -static MA_INLINE ma_int16 ma_pcm_sample_f32_to_s16(float x) -{ - return (ma_int16)(x * 32767.0f); -} - -static MA_INLINE ma_int16 ma_pcm_sample_u8_to_s16_no_scale(ma_uint8 x) -{ - return (ma_int16)((ma_int16)x - 128); -} - -static MA_INLINE ma_int64 ma_pcm_sample_s24_to_s32_no_scale(const ma_uint8* x) -{ - return (ma_int64)(((ma_uint64)x[0] << 40) | ((ma_uint64)x[1] << 48) | ((ma_uint64)x[2] << 56)) >> 40; /* Make sure the sign bits are maintained. */ -} - -static MA_INLINE void ma_pcm_sample_s32_to_s24_no_scale(ma_int64 x, ma_uint8* s24) -{ - s24[0] = (ma_uint8)((x & 0x000000FF) >> 0); - s24[1] = (ma_uint8)((x & 0x0000FF00) >> 8); - s24[2] = (ma_uint8)((x & 0x00FF0000) >> 16); -} - - -/* u8 */ -MA_API void ma_pcm_u8_to_u8(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - (void)ditherMode; - ma_copy_memory_64(dst, src, count * sizeof(ma_uint8)); -} - - -static MA_INLINE void ma_pcm_u8_to_s16__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int16* dst_s16 = (ma_int16*)dst; - const ma_uint8* src_u8 = (const ma_uint8*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int16 x = src_u8[i]; - x = (ma_int16)(x - 128); - x = (ma_int16)(x << 8); - dst_s16[i] = x; - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_u8_to_s16__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s16__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_u8_to_s16__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s16__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_u8_to_s16__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s16__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_u8_to_s16(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_u8_to_s16__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_u8_to_s16__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_u8_to_s16__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_u8_to_s16__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_u8_to_s24__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_s24 = (ma_uint8*)dst; - const ma_uint8* src_u8 = (const ma_uint8*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int16 x = src_u8[i]; - x = (ma_int16)(x - 128); - - dst_s24[i*3+0] = 0; - dst_s24[i*3+1] = 0; - dst_s24[i*3+2] = (ma_uint8)((ma_int8)x); - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_u8_to_s24__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s24__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_u8_to_s24__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s24__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_u8_to_s24__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s24__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_u8_to_s24(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_u8_to_s24__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_u8_to_s24__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_u8_to_s24__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_u8_to_s24__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_u8_to_s32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int32* dst_s32 = (ma_int32*)dst; - const ma_uint8* src_u8 = (const ma_uint8*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = src_u8[i]; - x = x - 128; - x = x << 24; - dst_s32[i] = x; - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_u8_to_s32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_u8_to_s32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_u8_to_s32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_s32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_u8_to_s32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_u8_to_s32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_u8_to_s32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_u8_to_s32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_u8_to_s32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_u8_to_f32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - float* dst_f32 = (float*)dst; - const ma_uint8* src_u8 = (const ma_uint8*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - float x = (float)src_u8[i]; - x = x * 0.00784313725490196078f; /* 0..255 to 0..2 */ - x = x - 1; /* 0..2 to -1..1 */ - - dst_f32[i] = x; - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_u8_to_f32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_f32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_u8_to_f32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_f32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_u8_to_f32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_u8_to_f32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_u8_to_f32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_u8_to_f32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_u8_to_f32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_u8_to_f32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_u8_to_f32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -#ifdef MA_USE_REFERENCE_CONVERSION_APIS -static MA_INLINE void ma_pcm_interleave_u8__reference(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_uint8* dst_u8 = (ma_uint8*)dst; - const ma_uint8** src_u8 = (const ma_uint8**)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_u8[iFrame*channels + iChannel] = src_u8[iChannel][iFrame]; - } - } -} -#else -static MA_INLINE void ma_pcm_interleave_u8__optimized(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_uint8* dst_u8 = (ma_uint8*)dst; - const ma_uint8** src_u8 = (const ma_uint8**)src; - - if (channels == 1) { - ma_copy_memory_64(dst, src[0], frameCount * sizeof(ma_uint8)); - } else if (channels == 2) { - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - dst_u8[iFrame*2 + 0] = src_u8[0][iFrame]; - dst_u8[iFrame*2 + 1] = src_u8[1][iFrame]; - } - } else { - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_u8[iFrame*channels + iChannel] = src_u8[iChannel][iFrame]; - } - } - } -} -#endif - -MA_API void ma_pcm_interleave_u8(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_interleave_u8__reference(dst, src, frameCount, channels); -#else - ma_pcm_interleave_u8__optimized(dst, src, frameCount, channels); -#endif -} - - -static MA_INLINE void ma_pcm_deinterleave_u8__reference(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_uint8** dst_u8 = (ma_uint8**)dst; - const ma_uint8* src_u8 = (const ma_uint8*)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_u8[iChannel][iFrame] = src_u8[iFrame*channels + iChannel]; - } - } -} - -static MA_INLINE void ma_pcm_deinterleave_u8__optimized(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_deinterleave_u8__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_deinterleave_u8(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_deinterleave_u8__reference(dst, src, frameCount, channels); -#else - ma_pcm_deinterleave_u8__optimized(dst, src, frameCount, channels); -#endif -} - - -/* s16 */ -static MA_INLINE void ma_pcm_s16_to_u8__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_u8 = (ma_uint8*)dst; - const ma_int16* src_s16 = (const ma_int16*)src; - - if (ditherMode == ma_dither_mode_none) { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int16 x = src_s16[i]; - x = (ma_int16)(x >> 8); - x = (ma_int16)(x + 128); - dst_u8[i] = (ma_uint8)x; - } - } else { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int16 x = src_s16[i]; - - /* Dither. Don't overflow. */ - ma_int32 dither = ma_dither_s32(ditherMode, -0x80, 0x7F); - if ((x + dither) <= 0x7FFF) { - x = (ma_int16)(x + dither); - } else { - x = 0x7FFF; - } - - x = (ma_int16)(x >> 8); - x = (ma_int16)(x + 128); - dst_u8[i] = (ma_uint8)x; - } - } -} - -static MA_INLINE void ma_pcm_s16_to_u8__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_u8__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s16_to_u8__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_u8__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s16_to_u8__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_u8__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s16_to_u8(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s16_to_u8__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s16_to_u8__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s16_to_u8__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s16_to_u8__optimized(dst, src, count, ditherMode); - } -#endif -} - - -MA_API void ma_pcm_s16_to_s16(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - (void)ditherMode; - ma_copy_memory_64(dst, src, count * sizeof(ma_int16)); -} - - -static MA_INLINE void ma_pcm_s16_to_s24__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_s24 = (ma_uint8*)dst; - const ma_int16* src_s16 = (const ma_int16*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - dst_s24[i*3+0] = 0; - dst_s24[i*3+1] = (ma_uint8)(src_s16[i] & 0xFF); - dst_s24[i*3+2] = (ma_uint8)(src_s16[i] >> 8); - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_s16_to_s24__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_s24__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s16_to_s24__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_s24__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s16_to_s24__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_s24__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s16_to_s24(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s16_to_s24__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s16_to_s24__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s16_to_s24__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s16_to_s24__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_s16_to_s32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int32* dst_s32 = (ma_int32*)dst; - const ma_int16* src_s16 = (const ma_int16*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - dst_s32[i] = src_s16[i] << 16; - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_s16_to_s32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_s32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s16_to_s32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_s32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s16_to_s32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_s32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s16_to_s32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s16_to_s32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s16_to_s32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s16_to_s32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s16_to_s32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_s16_to_f32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - float* dst_f32 = (float*)dst; - const ma_int16* src_s16 = (const ma_int16*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - float x = (float)src_s16[i]; - -#if 0 - /* The accurate way. */ - x = x + 32768.0f; /* -32768..32767 to 0..65535 */ - x = x * 0.00003051804379339284f; /* 0..65535 to 0..2 */ - x = x - 1; /* 0..2 to -1..1 */ -#else - /* The fast way. */ - x = x * 0.000030517578125f; /* -32768..32767 to -1..0.999969482421875 */ -#endif - - dst_f32[i] = x; - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_s16_to_f32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_f32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s16_to_f32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_f32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s16_to_f32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s16_to_f32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s16_to_f32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s16_to_f32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s16_to_f32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s16_to_f32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s16_to_f32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_interleave_s16__reference(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_int16* dst_s16 = (ma_int16*)dst; - const ma_int16** src_s16 = (const ma_int16**)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_s16[iFrame*channels + iChannel] = src_s16[iChannel][iFrame]; - } - } -} - -static MA_INLINE void ma_pcm_interleave_s16__optimized(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_interleave_s16__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_interleave_s16(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_interleave_s16__reference(dst, src, frameCount, channels); -#else - ma_pcm_interleave_s16__optimized(dst, src, frameCount, channels); -#endif -} - - -static MA_INLINE void ma_pcm_deinterleave_s16__reference(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_int16** dst_s16 = (ma_int16**)dst; - const ma_int16* src_s16 = (const ma_int16*)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_s16[iChannel][iFrame] = src_s16[iFrame*channels + iChannel]; - } - } -} - -static MA_INLINE void ma_pcm_deinterleave_s16__optimized(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_deinterleave_s16__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_deinterleave_s16(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_deinterleave_s16__reference(dst, src, frameCount, channels); -#else - ma_pcm_deinterleave_s16__optimized(dst, src, frameCount, channels); -#endif -} - - -/* s24 */ -static MA_INLINE void ma_pcm_s24_to_u8__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_u8 = (ma_uint8*)dst; - const ma_uint8* src_s24 = (const ma_uint8*)src; - - if (ditherMode == ma_dither_mode_none) { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - dst_u8[i] = (ma_uint8)((ma_int8)src_s24[i*3 + 2] + 128); - } - } else { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = (ma_int32)(((ma_uint32)(src_s24[i*3+0]) << 8) | ((ma_uint32)(src_s24[i*3+1]) << 16) | ((ma_uint32)(src_s24[i*3+2])) << 24); - - /* Dither. Don't overflow. */ - ma_int32 dither = ma_dither_s32(ditherMode, -0x800000, 0x7FFFFF); - if ((ma_int64)x + dither <= 0x7FFFFFFF) { - x = x + dither; - } else { - x = 0x7FFFFFFF; - } - - x = x >> 24; - x = x + 128; - dst_u8[i] = (ma_uint8)x; - } - } -} - -static MA_INLINE void ma_pcm_s24_to_u8__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_u8__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s24_to_u8__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_u8__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s24_to_u8__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_u8__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s24_to_u8(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s24_to_u8__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s24_to_u8__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s24_to_u8__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s24_to_u8__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_s24_to_s16__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int16* dst_s16 = (ma_int16*)dst; - const ma_uint8* src_s24 = (const ma_uint8*)src; - - if (ditherMode == ma_dither_mode_none) { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_uint16 dst_lo = ((ma_uint16)src_s24[i*3 + 1]); - ma_uint16 dst_hi = (ma_uint16)((ma_uint16)src_s24[i*3 + 2] << 8); - dst_s16[i] = (ma_int16)(dst_lo | dst_hi); - } - } else { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = (ma_int32)(((ma_uint32)(src_s24[i*3+0]) << 8) | ((ma_uint32)(src_s24[i*3+1]) << 16) | ((ma_uint32)(src_s24[i*3+2])) << 24); - - /* Dither. Don't overflow. */ - ma_int32 dither = ma_dither_s32(ditherMode, -0x8000, 0x7FFF); - if ((ma_int64)x + dither <= 0x7FFFFFFF) { - x = x + dither; - } else { - x = 0x7FFFFFFF; - } - - x = x >> 16; - dst_s16[i] = (ma_int16)x; - } - } -} - -static MA_INLINE void ma_pcm_s24_to_s16__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_s16__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s24_to_s16__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_s16__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s24_to_s16__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_s16__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s24_to_s16(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s24_to_s16__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s24_to_s16__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s24_to_s16__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s24_to_s16__optimized(dst, src, count, ditherMode); - } -#endif -} - - -MA_API void ma_pcm_s24_to_s24(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - (void)ditherMode; - - ma_copy_memory_64(dst, src, count * 3); -} - - -static MA_INLINE void ma_pcm_s24_to_s32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int32* dst_s32 = (ma_int32*)dst; - const ma_uint8* src_s24 = (const ma_uint8*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - dst_s32[i] = (ma_int32)(((ma_uint32)(src_s24[i*3+0]) << 8) | ((ma_uint32)(src_s24[i*3+1]) << 16) | ((ma_uint32)(src_s24[i*3+2])) << 24); - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_s24_to_s32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_s32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s24_to_s32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_s32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s24_to_s32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_s32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s24_to_s32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s24_to_s32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s24_to_s32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s24_to_s32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s24_to_s32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_s24_to_f32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - float* dst_f32 = (float*)dst; - const ma_uint8* src_s24 = (const ma_uint8*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - float x = (float)(((ma_int32)(((ma_uint32)(src_s24[i*3+0]) << 8) | ((ma_uint32)(src_s24[i*3+1]) << 16) | ((ma_uint32)(src_s24[i*3+2])) << 24)) >> 8); - -#if 0 - /* The accurate way. */ - x = x + 8388608.0f; /* -8388608..8388607 to 0..16777215 */ - x = x * 0.00000011920929665621f; /* 0..16777215 to 0..2 */ - x = x - 1; /* 0..2 to -1..1 */ -#else - /* The fast way. */ - x = x * 0.00000011920928955078125f; /* -8388608..8388607 to -1..0.999969482421875 */ -#endif - - dst_f32[i] = x; - } - - (void)ditherMode; -} - -static MA_INLINE void ma_pcm_s24_to_f32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_f32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s24_to_f32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_f32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s24_to_f32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s24_to_f32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s24_to_f32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s24_to_f32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s24_to_f32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s24_to_f32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s24_to_f32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_interleave_s24__reference(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_uint8* dst8 = (ma_uint8*)dst; - const ma_uint8** src8 = (const ma_uint8**)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst8[iFrame*3*channels + iChannel*3 + 0] = src8[iChannel][iFrame*3 + 0]; - dst8[iFrame*3*channels + iChannel*3 + 1] = src8[iChannel][iFrame*3 + 1]; - dst8[iFrame*3*channels + iChannel*3 + 2] = src8[iChannel][iFrame*3 + 2]; - } - } -} - -static MA_INLINE void ma_pcm_interleave_s24__optimized(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_interleave_s24__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_interleave_s24(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_interleave_s24__reference(dst, src, frameCount, channels); -#else - ma_pcm_interleave_s24__optimized(dst, src, frameCount, channels); -#endif -} - - -static MA_INLINE void ma_pcm_deinterleave_s24__reference(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_uint8** dst8 = (ma_uint8**)dst; - const ma_uint8* src8 = (const ma_uint8*)src; - - ma_uint32 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst8[iChannel][iFrame*3 + 0] = src8[iFrame*3*channels + iChannel*3 + 0]; - dst8[iChannel][iFrame*3 + 1] = src8[iFrame*3*channels + iChannel*3 + 1]; - dst8[iChannel][iFrame*3 + 2] = src8[iFrame*3*channels + iChannel*3 + 2]; - } - } -} - -static MA_INLINE void ma_pcm_deinterleave_s24__optimized(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_deinterleave_s24__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_deinterleave_s24(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_deinterleave_s24__reference(dst, src, frameCount, channels); -#else - ma_pcm_deinterleave_s24__optimized(dst, src, frameCount, channels); -#endif -} - - - -/* s32 */ -static MA_INLINE void ma_pcm_s32_to_u8__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_u8 = (ma_uint8*)dst; - const ma_int32* src_s32 = (const ma_int32*)src; - - if (ditherMode == ma_dither_mode_none) { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = src_s32[i]; - x = x >> 24; - x = x + 128; - dst_u8[i] = (ma_uint8)x; - } - } else { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = src_s32[i]; - - /* Dither. Don't overflow. */ - ma_int32 dither = ma_dither_s32(ditherMode, -0x800000, 0x7FFFFF); - if ((ma_int64)x + dither <= 0x7FFFFFFF) { - x = x + dither; - } else { - x = 0x7FFFFFFF; - } - - x = x >> 24; - x = x + 128; - dst_u8[i] = (ma_uint8)x; - } - } -} - -static MA_INLINE void ma_pcm_s32_to_u8__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_u8__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s32_to_u8__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_u8__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s32_to_u8__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_u8__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s32_to_u8(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s32_to_u8__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s32_to_u8__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s32_to_u8__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s32_to_u8__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_s32_to_s16__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int16* dst_s16 = (ma_int16*)dst; - const ma_int32* src_s32 = (const ma_int32*)src; - - if (ditherMode == ma_dither_mode_none) { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = src_s32[i]; - x = x >> 16; - dst_s16[i] = (ma_int16)x; - } - } else { - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 x = src_s32[i]; - - /* Dither. Don't overflow. */ - ma_int32 dither = ma_dither_s32(ditherMode, -0x8000, 0x7FFF); - if ((ma_int64)x + dither <= 0x7FFFFFFF) { - x = x + dither; - } else { - x = 0x7FFFFFFF; - } - - x = x >> 16; - dst_s16[i] = (ma_int16)x; - } - } -} - -static MA_INLINE void ma_pcm_s32_to_s16__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_s16__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s32_to_s16__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_s16__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s32_to_s16__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_s16__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s32_to_s16(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s32_to_s16__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s32_to_s16__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s32_to_s16__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s32_to_s16__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_s32_to_s24__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_s24 = (ma_uint8*)dst; - const ma_int32* src_s32 = (const ma_int32*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_uint32 x = (ma_uint32)src_s32[i]; - dst_s24[i*3+0] = (ma_uint8)((x & 0x0000FF00) >> 8); - dst_s24[i*3+1] = (ma_uint8)((x & 0x00FF0000) >> 16); - dst_s24[i*3+2] = (ma_uint8)((x & 0xFF000000) >> 24); - } - - (void)ditherMode; /* No dithering for s32 -> s24. */ -} - -static MA_INLINE void ma_pcm_s32_to_s24__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_s24__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s32_to_s24__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_s24__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s32_to_s24__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_s24__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s32_to_s24(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s32_to_s24__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s32_to_s24__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s32_to_s24__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s32_to_s24__optimized(dst, src, count, ditherMode); - } -#endif -} - - -MA_API void ma_pcm_s32_to_s32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - (void)ditherMode; - - ma_copy_memory_64(dst, src, count * sizeof(ma_int32)); -} - - -static MA_INLINE void ma_pcm_s32_to_f32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - float* dst_f32 = (float*)dst; - const ma_int32* src_s32 = (const ma_int32*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - double x = src_s32[i]; - -#if 0 - x = x + 2147483648.0; - x = x * 0.0000000004656612873077392578125; - x = x - 1; -#else - x = x / 2147483648.0; -#endif - - dst_f32[i] = (float)x; - } - - (void)ditherMode; /* No dithering for s32 -> f32. */ -} - -static MA_INLINE void ma_pcm_s32_to_f32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_f32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_s32_to_f32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_f32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_s32_to_f32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_s32_to_f32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_s32_to_f32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_s32_to_f32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_s32_to_f32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_s32_to_f32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_s32_to_f32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_interleave_s32__reference(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_int32* dst_s32 = (ma_int32*)dst; - const ma_int32** src_s32 = (const ma_int32**)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_s32[iFrame*channels + iChannel] = src_s32[iChannel][iFrame]; - } - } -} - -static MA_INLINE void ma_pcm_interleave_s32__optimized(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_interleave_s32__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_interleave_s32(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_interleave_s32__reference(dst, src, frameCount, channels); -#else - ma_pcm_interleave_s32__optimized(dst, src, frameCount, channels); -#endif -} - - -static MA_INLINE void ma_pcm_deinterleave_s32__reference(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_int32** dst_s32 = (ma_int32**)dst; - const ma_int32* src_s32 = (const ma_int32*)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_s32[iChannel][iFrame] = src_s32[iFrame*channels + iChannel]; - } - } -} - -static MA_INLINE void ma_pcm_deinterleave_s32__optimized(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_deinterleave_s32__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_deinterleave_s32(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_deinterleave_s32__reference(dst, src, frameCount, channels); -#else - ma_pcm_deinterleave_s32__optimized(dst, src, frameCount, channels); -#endif -} - - -/* f32 */ -static MA_INLINE void ma_pcm_f32_to_u8__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint64 i; - - ma_uint8* dst_u8 = (ma_uint8*)dst; - const float* src_f32 = (const float*)src; - - float ditherMin = 0; - float ditherMax = 0; - if (ditherMode != ma_dither_mode_none) { - ditherMin = 1.0f / -128; - ditherMax = 1.0f / 127; - } - - for (i = 0; i < count; i += 1) { - float x = src_f32[i]; - x = x + ma_dither_f32(ditherMode, ditherMin, ditherMax); - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - x = x + 1; /* -1..1 to 0..2 */ - x = x * 127.5f; /* 0..2 to 0..255 */ - - dst_u8[i] = (ma_uint8)x; - } -} - -static MA_INLINE void ma_pcm_f32_to_u8__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_u8__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_f32_to_u8__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_u8__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_f32_to_u8__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_u8__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_f32_to_u8(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_f32_to_u8__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_f32_to_u8__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_f32_to_u8__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_f32_to_u8__optimized(dst, src, count, ditherMode); - } -#endif -} - -#ifdef MA_USE_REFERENCE_CONVERSION_APIS -static MA_INLINE void ma_pcm_f32_to_s16__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint64 i; - - ma_int16* dst_s16 = (ma_int16*)dst; - const float* src_f32 = (const float*)src; - - float ditherMin = 0; - float ditherMax = 0; - if (ditherMode != ma_dither_mode_none) { - ditherMin = 1.0f / -32768; - ditherMax = 1.0f / 32767; - } - - for (i = 0; i < count; i += 1) { - float x = src_f32[i]; - x = x + ma_dither_f32(ditherMode, ditherMin, ditherMax); - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - -#if 0 - /* The accurate way. */ - x = x + 1; /* -1..1 to 0..2 */ - x = x * 32767.5f; /* 0..2 to 0..65535 */ - x = x - 32768.0f; /* 0...65535 to -32768..32767 */ -#else - /* The fast way. */ - x = x * 32767.0f; /* -1..1 to -32767..32767 */ -#endif - - dst_s16[i] = (ma_int16)x; - } -} -#else -static MA_INLINE void ma_pcm_f32_to_s16__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint64 i; - ma_uint64 i4; - ma_uint64 count4; - - ma_int16* dst_s16 = (ma_int16*)dst; - const float* src_f32 = (const float*)src; - - float ditherMin = 0; - float ditherMax = 0; - if (ditherMode != ma_dither_mode_none) { - ditherMin = 1.0f / -32768; - ditherMax = 1.0f / 32767; - } - - /* Unrolled. */ - i = 0; - count4 = count >> 2; - for (i4 = 0; i4 < count4; i4 += 1) { - float d0 = ma_dither_f32(ditherMode, ditherMin, ditherMax); - float d1 = ma_dither_f32(ditherMode, ditherMin, ditherMax); - float d2 = ma_dither_f32(ditherMode, ditherMin, ditherMax); - float d3 = ma_dither_f32(ditherMode, ditherMin, ditherMax); - - float x0 = src_f32[i+0]; - float x1 = src_f32[i+1]; - float x2 = src_f32[i+2]; - float x3 = src_f32[i+3]; - - x0 = x0 + d0; - x1 = x1 + d1; - x2 = x2 + d2; - x3 = x3 + d3; - - x0 = ((x0 < -1) ? -1 : ((x0 > 1) ? 1 : x0)); - x1 = ((x1 < -1) ? -1 : ((x1 > 1) ? 1 : x1)); - x2 = ((x2 < -1) ? -1 : ((x2 > 1) ? 1 : x2)); - x3 = ((x3 < -1) ? -1 : ((x3 > 1) ? 1 : x3)); - - x0 = x0 * 32767.0f; - x1 = x1 * 32767.0f; - x2 = x2 * 32767.0f; - x3 = x3 * 32767.0f; - - dst_s16[i+0] = (ma_int16)x0; - dst_s16[i+1] = (ma_int16)x1; - dst_s16[i+2] = (ma_int16)x2; - dst_s16[i+3] = (ma_int16)x3; - - i += 4; - } - - /* Leftover. */ - for (; i < count; i += 1) { - float x = src_f32[i]; - x = x + ma_dither_f32(ditherMode, ditherMin, ditherMax); - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - x = x * 32767.0f; /* -1..1 to -32767..32767 */ - - dst_s16[i] = (ma_int16)x; - } -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_f32_to_s16__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint64 i; - ma_uint64 i8; - ma_uint64 count8; - ma_int16* dst_s16; - const float* src_f32; - float ditherMin; - float ditherMax; - - /* Both the input and output buffers need to be aligned to 16 bytes. */ - if ((((ma_uintptr)dst & 15) != 0) || (((ma_uintptr)src & 15) != 0)) { - ma_pcm_f32_to_s16__optimized(dst, src, count, ditherMode); - return; - } - - dst_s16 = (ma_int16*)dst; - src_f32 = (const float*)src; - - ditherMin = 0; - ditherMax = 0; - if (ditherMode != ma_dither_mode_none) { - ditherMin = 1.0f / -32768; - ditherMax = 1.0f / 32767; - } - - i = 0; - - /* SSE2. SSE allows us to output 8 s16's at a time which means our loop is unrolled 8 times. */ - count8 = count >> 3; - for (i8 = 0; i8 < count8; i8 += 1) { - __m128 d0; - __m128 d1; - __m128 x0; - __m128 x1; - - if (ditherMode == ma_dither_mode_none) { - d0 = _mm_set1_ps(0); - d1 = _mm_set1_ps(0); - } else if (ditherMode == ma_dither_mode_rectangle) { - d0 = _mm_set_ps( - ma_dither_f32_rectangle(ditherMin, ditherMax), - ma_dither_f32_rectangle(ditherMin, ditherMax), - ma_dither_f32_rectangle(ditherMin, ditherMax), - ma_dither_f32_rectangle(ditherMin, ditherMax) - ); - d1 = _mm_set_ps( - ma_dither_f32_rectangle(ditherMin, ditherMax), - ma_dither_f32_rectangle(ditherMin, ditherMax), - ma_dither_f32_rectangle(ditherMin, ditherMax), - ma_dither_f32_rectangle(ditherMin, ditherMax) - ); - } else { - d0 = _mm_set_ps( - ma_dither_f32_triangle(ditherMin, ditherMax), - ma_dither_f32_triangle(ditherMin, ditherMax), - ma_dither_f32_triangle(ditherMin, ditherMax), - ma_dither_f32_triangle(ditherMin, ditherMax) - ); - d1 = _mm_set_ps( - ma_dither_f32_triangle(ditherMin, ditherMax), - ma_dither_f32_triangle(ditherMin, ditherMax), - ma_dither_f32_triangle(ditherMin, ditherMax), - ma_dither_f32_triangle(ditherMin, ditherMax) - ); - } - - x0 = *((__m128*)(src_f32 + i) + 0); - x1 = *((__m128*)(src_f32 + i) + 1); - - x0 = _mm_add_ps(x0, d0); - x1 = _mm_add_ps(x1, d1); - - x0 = _mm_mul_ps(x0, _mm_set1_ps(32767.0f)); - x1 = _mm_mul_ps(x1, _mm_set1_ps(32767.0f)); - - _mm_stream_si128(((__m128i*)(dst_s16 + i)), _mm_packs_epi32(_mm_cvttps_epi32(x0), _mm_cvttps_epi32(x1))); - - i += 8; - } - - - /* Leftover. */ - for (; i < count; i += 1) { - float x = src_f32[i]; - x = x + ma_dither_f32(ditherMode, ditherMin, ditherMax); - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - x = x * 32767.0f; /* -1..1 to -32767..32767 */ - - dst_s16[i] = (ma_int16)x; - } -} -#endif /* SSE2 */ - -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_f32_to_s16__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint64 i; - ma_uint64 i8; - ma_uint64 count8; - ma_int16* dst_s16; - const float* src_f32; - float ditherMin; - float ditherMax; - - if (!ma_has_neon()) { - ma_pcm_f32_to_s16__optimized(dst, src, count, ditherMode); - return; - } - - /* Both the input and output buffers need to be aligned to 16 bytes. */ - if ((((ma_uintptr)dst & 15) != 0) || (((ma_uintptr)src & 15) != 0)) { - ma_pcm_f32_to_s16__optimized(dst, src, count, ditherMode); - return; - } - - dst_s16 = (ma_int16*)dst; - src_f32 = (const float*)src; - - ditherMin = 0; - ditherMax = 0; - if (ditherMode != ma_dither_mode_none) { - ditherMin = 1.0f / -32768; - ditherMax = 1.0f / 32767; - } - - i = 0; - - /* NEON. NEON allows us to output 8 s16's at a time which means our loop is unrolled 8 times. */ - count8 = count >> 3; - for (i8 = 0; i8 < count8; i8 += 1) { - float32x4_t d0; - float32x4_t d1; - float32x4_t x0; - float32x4_t x1; - int32x4_t i0; - int32x4_t i1; - - if (ditherMode == ma_dither_mode_none) { - d0 = vmovq_n_f32(0); - d1 = vmovq_n_f32(0); - } else if (ditherMode == ma_dither_mode_rectangle) { - float d0v[4]; - d0v[0] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d0v[1] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d0v[2] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d0v[3] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d0 = vld1q_f32(d0v); - - float d1v[4]; - d1v[0] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d1v[1] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d1v[2] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d1v[3] = ma_dither_f32_rectangle(ditherMin, ditherMax); - d1 = vld1q_f32(d1v); - } else { - float d0v[4]; - d0v[0] = ma_dither_f32_triangle(ditherMin, ditherMax); - d0v[1] = ma_dither_f32_triangle(ditherMin, ditherMax); - d0v[2] = ma_dither_f32_triangle(ditherMin, ditherMax); - d0v[3] = ma_dither_f32_triangle(ditherMin, ditherMax); - d0 = vld1q_f32(d0v); - - float d1v[4]; - d1v[0] = ma_dither_f32_triangle(ditherMin, ditherMax); - d1v[1] = ma_dither_f32_triangle(ditherMin, ditherMax); - d1v[2] = ma_dither_f32_triangle(ditherMin, ditherMax); - d1v[3] = ma_dither_f32_triangle(ditherMin, ditherMax); - d1 = vld1q_f32(d1v); - } - - x0 = *((float32x4_t*)(src_f32 + i) + 0); - x1 = *((float32x4_t*)(src_f32 + i) + 1); - - x0 = vaddq_f32(x0, d0); - x1 = vaddq_f32(x1, d1); - - x0 = vmulq_n_f32(x0, 32767.0f); - x1 = vmulq_n_f32(x1, 32767.0f); - - i0 = vcvtq_s32_f32(x0); - i1 = vcvtq_s32_f32(x1); - *((int16x8_t*)(dst_s16 + i)) = vcombine_s16(vqmovn_s32(i0), vqmovn_s32(i1)); - - i += 8; - } - - - /* Leftover. */ - for (; i < count; i += 1) { - float x = src_f32[i]; - x = x + ma_dither_f32(ditherMode, ditherMin, ditherMax); - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - x = x * 32767.0f; /* -1..1 to -32767..32767 */ - - dst_s16[i] = (ma_int16)x; - } -} -#endif /* Neon */ -#endif /* MA_USE_REFERENCE_CONVERSION_APIS */ - -MA_API void ma_pcm_f32_to_s16(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_f32_to_s16__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_f32_to_s16__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_f32_to_s16__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_f32_to_s16__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_f32_to_s24__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_uint8* dst_s24 = (ma_uint8*)dst; - const float* src_f32 = (const float*)src; - - ma_uint64 i; - for (i = 0; i < count; i += 1) { - ma_int32 r; - float x = src_f32[i]; - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - -#if 0 - /* The accurate way. */ - x = x + 1; /* -1..1 to 0..2 */ - x = x * 8388607.5f; /* 0..2 to 0..16777215 */ - x = x - 8388608.0f; /* 0..16777215 to -8388608..8388607 */ -#else - /* The fast way. */ - x = x * 8388607.0f; /* -1..1 to -8388607..8388607 */ -#endif - - r = (ma_int32)x; - dst_s24[(i*3)+0] = (ma_uint8)((r & 0x0000FF) >> 0); - dst_s24[(i*3)+1] = (ma_uint8)((r & 0x00FF00) >> 8); - dst_s24[(i*3)+2] = (ma_uint8)((r & 0xFF0000) >> 16); - } - - (void)ditherMode; /* No dithering for f32 -> s24. */ -} - -static MA_INLINE void ma_pcm_f32_to_s24__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_s24__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_f32_to_s24__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_s24__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_f32_to_s24__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_s24__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_f32_to_s24(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_f32_to_s24__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_f32_to_s24__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_f32_to_s24__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_f32_to_s24__optimized(dst, src, count, ditherMode); - } -#endif -} - - -static MA_INLINE void ma_pcm_f32_to_s32__reference(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_int32* dst_s32 = (ma_int32*)dst; - const float* src_f32 = (const float*)src; - - ma_uint32 i; - for (i = 0; i < count; i += 1) { - double x = src_f32[i]; - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); /* clip */ - -#if 0 - /* The accurate way. */ - x = x + 1; /* -1..1 to 0..2 */ - x = x * 2147483647.5; /* 0..2 to 0..4294967295 */ - x = x - 2147483648.0; /* 0...4294967295 to -2147483648..2147483647 */ -#else - /* The fast way. */ - x = x * 2147483647.0; /* -1..1 to -2147483647..2147483647 */ -#endif - - dst_s32[i] = (ma_int32)x; - } - - (void)ditherMode; /* No dithering for f32 -> s32. */ -} - -static MA_INLINE void ma_pcm_f32_to_s32__optimized(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_s32__reference(dst, src, count, ditherMode); -} - -#if defined(MA_SUPPORT_SSE2) -static MA_INLINE void ma_pcm_f32_to_s32__sse2(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_s32__optimized(dst, src, count, ditherMode); -} -#endif -#if defined(MA_SUPPORT_NEON) -static MA_INLINE void ma_pcm_f32_to_s32__neon(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - ma_pcm_f32_to_s32__optimized(dst, src, count, ditherMode); -} -#endif - -MA_API void ma_pcm_f32_to_s32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_f32_to_s32__reference(dst, src, count, ditherMode); -#else - # if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_pcm_f32_to_s32__sse2(dst, src, count, ditherMode); - } else - #elif defined(MA_SUPPORT_NEON) - if (ma_has_neon()) { - ma_pcm_f32_to_s32__neon(dst, src, count, ditherMode); - } else - #endif - { - ma_pcm_f32_to_s32__optimized(dst, src, count, ditherMode); - } -#endif -} - - -MA_API void ma_pcm_f32_to_f32(void* dst, const void* src, ma_uint64 count, ma_dither_mode ditherMode) -{ - (void)ditherMode; - - ma_copy_memory_64(dst, src, count * sizeof(float)); -} - - -static void ma_pcm_interleave_f32__reference(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - float* dst_f32 = (float*)dst; - const float** src_f32 = (const float**)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_f32[iFrame*channels + iChannel] = src_f32[iChannel][iFrame]; - } - } -} - -static void ma_pcm_interleave_f32__optimized(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_interleave_f32__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_interleave_f32(void* dst, const void** src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_interleave_f32__reference(dst, src, frameCount, channels); -#else - ma_pcm_interleave_f32__optimized(dst, src, frameCount, channels); -#endif -} - - -static void ma_pcm_deinterleave_f32__reference(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - float** dst_f32 = (float**)dst; - const float* src_f32 = (const float*)src; - - ma_uint64 iFrame; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; iChannel += 1) { - dst_f32[iChannel][iFrame] = src_f32[iFrame*channels + iChannel]; - } - } -} - -static void ma_pcm_deinterleave_f32__optimized(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ - ma_pcm_deinterleave_f32__reference(dst, src, frameCount, channels); -} - -MA_API void ma_pcm_deinterleave_f32(void** dst, const void* src, ma_uint64 frameCount, ma_uint32 channels) -{ -#ifdef MA_USE_REFERENCE_CONVERSION_APIS - ma_pcm_deinterleave_f32__reference(dst, src, frameCount, channels); -#else - ma_pcm_deinterleave_f32__optimized(dst, src, frameCount, channels); -#endif -} - - -MA_API void ma_pcm_convert(void* pOut, ma_format formatOut, const void* pIn, ma_format formatIn, ma_uint64 sampleCount, ma_dither_mode ditherMode) -{ - if (formatOut == formatIn) { - ma_copy_memory_64(pOut, pIn, sampleCount * ma_get_bytes_per_sample(formatOut)); - return; - } - - switch (formatIn) - { - case ma_format_u8: - { - switch (formatOut) - { - case ma_format_s16: ma_pcm_u8_to_s16(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s24: ma_pcm_u8_to_s24(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s32: ma_pcm_u8_to_s32(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_f32: ma_pcm_u8_to_f32(pOut, pIn, sampleCount, ditherMode); return; - default: break; - } - } break; - - case ma_format_s16: - { - switch (formatOut) - { - case ma_format_u8: ma_pcm_s16_to_u8( pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s24: ma_pcm_s16_to_s24(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s32: ma_pcm_s16_to_s32(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_f32: ma_pcm_s16_to_f32(pOut, pIn, sampleCount, ditherMode); return; - default: break; - } - } break; - - case ma_format_s24: - { - switch (formatOut) - { - case ma_format_u8: ma_pcm_s24_to_u8( pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s16: ma_pcm_s24_to_s16(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s32: ma_pcm_s24_to_s32(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_f32: ma_pcm_s24_to_f32(pOut, pIn, sampleCount, ditherMode); return; - default: break; - } - } break; - - case ma_format_s32: - { - switch (formatOut) - { - case ma_format_u8: ma_pcm_s32_to_u8( pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s16: ma_pcm_s32_to_s16(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s24: ma_pcm_s32_to_s24(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_f32: ma_pcm_s32_to_f32(pOut, pIn, sampleCount, ditherMode); return; - default: break; - } - } break; - - case ma_format_f32: - { - switch (formatOut) - { - case ma_format_u8: ma_pcm_f32_to_u8( pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s16: ma_pcm_f32_to_s16(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s24: ma_pcm_f32_to_s24(pOut, pIn, sampleCount, ditherMode); return; - case ma_format_s32: ma_pcm_f32_to_s32(pOut, pIn, sampleCount, ditherMode); return; - default: break; - } - } break; - - default: break; - } -} - -MA_API void ma_convert_pcm_frames_format(void* pOut, ma_format formatOut, const void* pIn, ma_format formatIn, ma_uint64 frameCount, ma_uint32 channels, ma_dither_mode ditherMode) -{ - ma_pcm_convert(pOut, formatOut, pIn, formatIn, frameCount * channels, ditherMode); -} - -MA_API void ma_deinterleave_pcm_frames(ma_format format, ma_uint32 channels, ma_uint64 frameCount, const void* pInterleavedPCMFrames, void** ppDeinterleavedPCMFrames) -{ - if (pInterleavedPCMFrames == NULL || ppDeinterleavedPCMFrames == NULL) { - return; /* Invalid args. */ - } - - /* For efficiency we do this per format. */ - switch (format) { - case ma_format_s16: - { - const ma_int16* pSrcS16 = (const ma_int16*)pInterleavedPCMFrames; - ma_uint64 iPCMFrame; - for (iPCMFrame = 0; iPCMFrame < frameCount; ++iPCMFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - ma_int16* pDstS16 = (ma_int16*)ppDeinterleavedPCMFrames[iChannel]; - pDstS16[iPCMFrame] = pSrcS16[iPCMFrame*channels+iChannel]; - } - } - } break; - - case ma_format_f32: - { - const float* pSrcF32 = (const float*)pInterleavedPCMFrames; - ma_uint64 iPCMFrame; - for (iPCMFrame = 0; iPCMFrame < frameCount; ++iPCMFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - float* pDstF32 = (float*)ppDeinterleavedPCMFrames[iChannel]; - pDstF32[iPCMFrame] = pSrcF32[iPCMFrame*channels+iChannel]; - } - } - } break; - - default: - { - ma_uint32 sampleSizeInBytes = ma_get_bytes_per_sample(format); - ma_uint64 iPCMFrame; - for (iPCMFrame = 0; iPCMFrame < frameCount; ++iPCMFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - void* pDst = ma_offset_ptr(ppDeinterleavedPCMFrames[iChannel], iPCMFrame*sampleSizeInBytes); - const void* pSrc = ma_offset_ptr(pInterleavedPCMFrames, (iPCMFrame*channels+iChannel)*sampleSizeInBytes); - memcpy(pDst, pSrc, sampleSizeInBytes); - } - } - } break; - } -} - -MA_API void ma_interleave_pcm_frames(ma_format format, ma_uint32 channels, ma_uint64 frameCount, const void** ppDeinterleavedPCMFrames, void* pInterleavedPCMFrames) -{ - switch (format) - { - case ma_format_s16: - { - ma_int16* pDstS16 = (ma_int16*)pInterleavedPCMFrames; - ma_uint64 iPCMFrame; - for (iPCMFrame = 0; iPCMFrame < frameCount; ++iPCMFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - const ma_int16* pSrcS16 = (const ma_int16*)ppDeinterleavedPCMFrames[iChannel]; - pDstS16[iPCMFrame*channels+iChannel] = pSrcS16[iPCMFrame]; - } - } - } break; - - case ma_format_f32: - { - float* pDstF32 = (float*)pInterleavedPCMFrames; - ma_uint64 iPCMFrame; - for (iPCMFrame = 0; iPCMFrame < frameCount; ++iPCMFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - const float* pSrcF32 = (const float*)ppDeinterleavedPCMFrames[iChannel]; - pDstF32[iPCMFrame*channels+iChannel] = pSrcF32[iPCMFrame]; - } - } - } break; - - default: - { - ma_uint32 sampleSizeInBytes = ma_get_bytes_per_sample(format); - ma_uint64 iPCMFrame; - for (iPCMFrame = 0; iPCMFrame < frameCount; ++iPCMFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - void* pDst = ma_offset_ptr(pInterleavedPCMFrames, (iPCMFrame*channels+iChannel)*sampleSizeInBytes); - const void* pSrc = ma_offset_ptr(ppDeinterleavedPCMFrames[iChannel], iPCMFrame*sampleSizeInBytes); - memcpy(pDst, pSrc, sampleSizeInBytes); - } - } - } break; - } -} - - -/************************************************************************************************************************************************************** - -Biquad Filter - -**************************************************************************************************************************************************************/ -#ifndef MA_BIQUAD_FIXED_POINT_SHIFT -#define MA_BIQUAD_FIXED_POINT_SHIFT 14 -#endif - -static ma_int32 ma_biquad_float_to_fp(double x) -{ - return (ma_int32)(x * (1 << MA_BIQUAD_FIXED_POINT_SHIFT)); -} - -MA_API ma_biquad_config ma_biquad_config_init(ma_format format, ma_uint32 channels, double b0, double b1, double b2, double a0, double a1, double a2) -{ - ma_biquad_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.b0 = b0; - config.b1 = b1; - config.b2 = b2; - config.a0 = a0; - config.a1 = a1; - config.a2 = a2; - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t r1Offset; - size_t r2Offset; -} ma_biquad_heap_layout; - -static ma_result ma_biquad_get_heap_layout(const ma_biquad_config* pConfig, ma_biquad_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* R0 */ - pHeapLayout->r1Offset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(ma_biquad_coefficient) * pConfig->channels; - - /* R1 */ - pHeapLayout->r2Offset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(ma_biquad_coefficient) * pConfig->channels; - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_biquad_get_heap_size(const ma_biquad_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_biquad_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_biquad_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_biquad_init_preallocated(const ma_biquad_config* pConfig, void* pHeap, ma_biquad* pBQ) -{ - ma_result result; - ma_biquad_heap_layout heapLayout; - - if (pBQ == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pBQ); - - result = ma_biquad_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pBQ->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pBQ->pR1 = (ma_biquad_coefficient*)ma_offset_ptr(pHeap, heapLayout.r1Offset); - pBQ->pR2 = (ma_biquad_coefficient*)ma_offset_ptr(pHeap, heapLayout.r2Offset); - - return ma_biquad_reinit(pConfig, pBQ); -} - -MA_API ma_result ma_biquad_init(const ma_biquad_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_biquad* pBQ) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_biquad_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_biquad_init_preallocated(pConfig, pHeap, pBQ); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pBQ->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_biquad_uninit(ma_biquad* pBQ, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pBQ == NULL) { - return; - } - - if (pBQ->_ownsHeap) { - ma_free(pBQ->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_biquad_reinit(const ma_biquad_config* pConfig, ma_biquad* pBQ) -{ - if (pBQ == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->a0 == 0) { - return MA_INVALID_ARGS; /* Division by zero. */ - } - - /* Only supporting f32 and s16. */ - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - /* The format cannot be changed after initialization. */ - if (pBQ->format != ma_format_unknown && pBQ->format != pConfig->format) { - return MA_INVALID_OPERATION; - } - - /* The channel count cannot be changed after initialization. */ - if (pBQ->channels != 0 && pBQ->channels != pConfig->channels) { - return MA_INVALID_OPERATION; - } - - - pBQ->format = pConfig->format; - pBQ->channels = pConfig->channels; - - /* Normalize. */ - if (pConfig->format == ma_format_f32) { - pBQ->b0.f32 = (float)(pConfig->b0 / pConfig->a0); - pBQ->b1.f32 = (float)(pConfig->b1 / pConfig->a0); - pBQ->b2.f32 = (float)(pConfig->b2 / pConfig->a0); - pBQ->a1.f32 = (float)(pConfig->a1 / pConfig->a0); - pBQ->a2.f32 = (float)(pConfig->a2 / pConfig->a0); - } else { - pBQ->b0.s32 = ma_biquad_float_to_fp(pConfig->b0 / pConfig->a0); - pBQ->b1.s32 = ma_biquad_float_to_fp(pConfig->b1 / pConfig->a0); - pBQ->b2.s32 = ma_biquad_float_to_fp(pConfig->b2 / pConfig->a0); - pBQ->a1.s32 = ma_biquad_float_to_fp(pConfig->a1 / pConfig->a0); - pBQ->a2.s32 = ma_biquad_float_to_fp(pConfig->a2 / pConfig->a0); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_biquad_clear_cache(ma_biquad* pBQ) -{ - if (pBQ == NULL) { - return MA_INVALID_ARGS; - } - - if (pBQ->format == ma_format_f32) { - pBQ->pR1->f32 = 0; - pBQ->pR2->f32 = 0; - } else { - pBQ->pR1->s32 = 0; - pBQ->pR2->s32 = 0; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_biquad_process_pcm_frame_f32__direct_form_2_transposed(ma_biquad* pBQ, float* pY, const float* pX) -{ - ma_uint32 c; - const ma_uint32 channels = pBQ->channels; - const float b0 = pBQ->b0.f32; - const float b1 = pBQ->b1.f32; - const float b2 = pBQ->b2.f32; - const float a1 = pBQ->a1.f32; - const float a2 = pBQ->a2.f32; - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - float r1 = pBQ->pR1[c].f32; - float r2 = pBQ->pR2[c].f32; - float x = pX[c]; - float y; - - y = b0*x + r1; - r1 = b1*x - a1*y + r2; - r2 = b2*x - a2*y; - - pY[c] = y; - pBQ->pR1[c].f32 = r1; - pBQ->pR2[c].f32 = r2; - } -} - -static MA_INLINE void ma_biquad_process_pcm_frame_f32(ma_biquad* pBQ, float* pY, const float* pX) -{ - ma_biquad_process_pcm_frame_f32__direct_form_2_transposed(pBQ, pY, pX); -} - -static MA_INLINE void ma_biquad_process_pcm_frame_s16__direct_form_2_transposed(ma_biquad* pBQ, ma_int16* pY, const ma_int16* pX) -{ - ma_uint32 c; - const ma_uint32 channels = pBQ->channels; - const ma_int32 b0 = pBQ->b0.s32; - const ma_int32 b1 = pBQ->b1.s32; - const ma_int32 b2 = pBQ->b2.s32; - const ma_int32 a1 = pBQ->a1.s32; - const ma_int32 a2 = pBQ->a2.s32; - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - ma_int32 r1 = pBQ->pR1[c].s32; - ma_int32 r2 = pBQ->pR2[c].s32; - ma_int32 x = pX[c]; - ma_int32 y; - - y = (b0*x + r1) >> MA_BIQUAD_FIXED_POINT_SHIFT; - r1 = (b1*x - a1*y + r2); - r2 = (b2*x - a2*y); - - pY[c] = (ma_int16)ma_clamp(y, -32768, 32767); - pBQ->pR1[c].s32 = r1; - pBQ->pR2[c].s32 = r2; - } -} - -static MA_INLINE void ma_biquad_process_pcm_frame_s16(ma_biquad* pBQ, ma_int16* pY, const ma_int16* pX) -{ - ma_biquad_process_pcm_frame_s16__direct_form_2_transposed(pBQ, pY, pX); -} - -MA_API ma_result ma_biquad_process_pcm_frames(ma_biquad* pBQ, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_uint32 n; - - if (pBQ == NULL || pFramesOut == NULL || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - /* Note that the logic below needs to support in-place filtering. That is, it must support the case where pFramesOut and pFramesIn are the same. */ - - if (pBQ->format == ma_format_f32) { - /* */ float* pY = ( float*)pFramesOut; - const float* pX = (const float*)pFramesIn; - - for (n = 0; n < frameCount; n += 1) { - ma_biquad_process_pcm_frame_f32__direct_form_2_transposed(pBQ, pY, pX); - pY += pBQ->channels; - pX += pBQ->channels; - } - } else if (pBQ->format == ma_format_s16) { - /* */ ma_int16* pY = ( ma_int16*)pFramesOut; - const ma_int16* pX = (const ma_int16*)pFramesIn; - - for (n = 0; n < frameCount; n += 1) { - ma_biquad_process_pcm_frame_s16__direct_form_2_transposed(pBQ, pY, pX); - pY += pBQ->channels; - pX += pBQ->channels; - } - } else { - MA_ASSERT(MA_FALSE); - return MA_INVALID_ARGS; /* Format not supported. Should never hit this because it's checked in ma_biquad_init() and ma_biquad_reinit(). */ - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_biquad_get_latency(const ma_biquad* pBQ) -{ - if (pBQ == NULL) { - return 0; - } - - return 2; -} - - -/************************************************************************************************************************************************************** - -Low-Pass Filter - -**************************************************************************************************************************************************************/ -MA_API ma_lpf1_config ma_lpf1_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency) -{ - ma_lpf1_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.q = 0.5; - - return config; -} - -MA_API ma_lpf2_config ma_lpf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, double q) -{ - ma_lpf2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.q = q; - - /* Q cannot be 0 or else it'll result in a division by 0. In this case just default to 0.707107. */ - if (config.q == 0) { - config.q = 0.707107; - } - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t r1Offset; -} ma_lpf1_heap_layout; - -static ma_result ma_lpf1_get_heap_layout(const ma_lpf1_config* pConfig, ma_lpf1_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* R1 */ - pHeapLayout->r1Offset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(ma_biquad_coefficient) * pConfig->channels; - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_lpf1_get_heap_size(const ma_lpf1_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_lpf1_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_lpf1_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_lpf1_init_preallocated(const ma_lpf1_config* pConfig, void* pHeap, ma_lpf1* pLPF) -{ - ma_result result; - ma_lpf1_heap_layout heapLayout; - - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pLPF); - - result = ma_lpf1_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pLPF->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pLPF->pR1 = (ma_biquad_coefficient*)ma_offset_ptr(pHeap, heapLayout.r1Offset); - - return ma_lpf1_reinit(pConfig, pLPF); -} - -MA_API ma_result ma_lpf1_init(const ma_lpf1_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf1* pLPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_lpf1_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_lpf1_init_preallocated(pConfig, pHeap, pLPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pLPF->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_lpf1_uninit(ma_lpf1* pLPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pLPF == NULL) { - return; - } - - if (pLPF->_ownsHeap) { - ma_free(pLPF->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_lpf1_reinit(const ma_lpf1_config* pConfig, ma_lpf1* pLPF) -{ - double a; - - if (pLPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Only supporting f32 and s16. */ - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - /* The format cannot be changed after initialization. */ - if (pLPF->format != ma_format_unknown && pLPF->format != pConfig->format) { - return MA_INVALID_OPERATION; - } - - /* The channel count cannot be changed after initialization. */ - if (pLPF->channels != 0 && pLPF->channels != pConfig->channels) { - return MA_INVALID_OPERATION; - } - - pLPF->format = pConfig->format; - pLPF->channels = pConfig->channels; - - a = ma_expd(-2 * MA_PI_D * pConfig->cutoffFrequency / pConfig->sampleRate); - if (pConfig->format == ma_format_f32) { - pLPF->a.f32 = (float)a; - } else { - pLPF->a.s32 = ma_biquad_float_to_fp(a); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_lpf1_clear_cache(ma_lpf1* pLPF) -{ - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - if (pLPF->format == ma_format_f32) { - pLPF->a.f32 = 0; - } else { - pLPF->a.s32 = 0; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_lpf1_process_pcm_frame_f32(ma_lpf1* pLPF, float* pY, const float* pX) -{ - ma_uint32 c; - const ma_uint32 channels = pLPF->channels; - const float a = pLPF->a.f32; - const float b = 1 - a; - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - float r1 = pLPF->pR1[c].f32; - float x = pX[c]; - float y; - - y = b*x + a*r1; - - pY[c] = y; - pLPF->pR1[c].f32 = y; - } -} - -static MA_INLINE void ma_lpf1_process_pcm_frame_s16(ma_lpf1* pLPF, ma_int16* pY, const ma_int16* pX) -{ - ma_uint32 c; - const ma_uint32 channels = pLPF->channels; - const ma_int32 a = pLPF->a.s32; - const ma_int32 b = ((1 << MA_BIQUAD_FIXED_POINT_SHIFT) - a); - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - ma_int32 r1 = pLPF->pR1[c].s32; - ma_int32 x = pX[c]; - ma_int32 y; - - y = (b*x + a*r1) >> MA_BIQUAD_FIXED_POINT_SHIFT; - - pY[c] = (ma_int16)y; - pLPF->pR1[c].s32 = (ma_int32)y; - } -} - -MA_API ma_result ma_lpf1_process_pcm_frames(ma_lpf1* pLPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_uint32 n; - - if (pLPF == NULL || pFramesOut == NULL || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - /* Note that the logic below needs to support in-place filtering. That is, it must support the case where pFramesOut and pFramesIn are the same. */ - - if (pLPF->format == ma_format_f32) { - /* */ float* pY = ( float*)pFramesOut; - const float* pX = (const float*)pFramesIn; - - for (n = 0; n < frameCount; n += 1) { - ma_lpf1_process_pcm_frame_f32(pLPF, pY, pX); - pY += pLPF->channels; - pX += pLPF->channels; - } - } else if (pLPF->format == ma_format_s16) { - /* */ ma_int16* pY = ( ma_int16*)pFramesOut; - const ma_int16* pX = (const ma_int16*)pFramesIn; - - for (n = 0; n < frameCount; n += 1) { - ma_lpf1_process_pcm_frame_s16(pLPF, pY, pX); - pY += pLPF->channels; - pX += pLPF->channels; - } - } else { - MA_ASSERT(MA_FALSE); - return MA_INVALID_ARGS; /* Format not supported. Should never hit this because it's checked in ma_biquad_init() and ma_biquad_reinit(). */ - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_lpf1_get_latency(const ma_lpf1* pLPF) -{ - if (pLPF == NULL) { - return 0; - } - - return 1; -} - - -static MA_INLINE ma_biquad_config ma_lpf2__get_biquad_config(const ma_lpf2_config* pConfig) -{ - ma_biquad_config bqConfig; - double q; - double w; - double s; - double c; - double a; - - MA_ASSERT(pConfig != NULL); - - q = pConfig->q; - w = 2 * MA_PI_D * pConfig->cutoffFrequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - a = s / (2*q); - - bqConfig.b0 = (1 - c) / 2; - bqConfig.b1 = 1 - c; - bqConfig.b2 = (1 - c) / 2; - bqConfig.a0 = 1 + a; - bqConfig.a1 = -2 * c; - bqConfig.a2 = 1 - a; - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_lpf2_get_heap_size(const ma_lpf2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_lpf2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_lpf2_init_preallocated(const ma_lpf2_config* pConfig, void* pHeap, ma_lpf2* pLPF) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pLPF); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_lpf2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pLPF->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_lpf2_init(const ma_lpf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf2* pLPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_lpf2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_lpf2_init_preallocated(pConfig, pHeap, pLPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pLPF->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_lpf2_uninit(ma_lpf2* pLPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pLPF == NULL) { - return; - } - - ma_biquad_uninit(&pLPF->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_lpf2_reinit(const ma_lpf2_config* pConfig, ma_lpf2* pLPF) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pLPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_lpf2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pLPF->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_lpf2_clear_cache(ma_lpf2* pLPF) -{ - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - ma_biquad_clear_cache(&pLPF->bq); - - return MA_SUCCESS; -} - -static MA_INLINE void ma_lpf2_process_pcm_frame_s16(ma_lpf2* pLPF, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pLPF->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_lpf2_process_pcm_frame_f32(ma_lpf2* pLPF, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pLPF->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_lpf2_process_pcm_frames(ma_lpf2* pLPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pLPF->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_lpf2_get_latency(const ma_lpf2* pLPF) -{ - if (pLPF == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pLPF->bq); -} - - -MA_API ma_lpf_config ma_lpf_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order) -{ - ma_lpf_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.order = ma_min(order, MA_MAX_FILTER_ORDER); - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t lpf1Offset; - size_t lpf2Offset; /* Offset of the first second order filter. Subsequent filters will come straight after, and will each have the same heap size. */ -} ma_lpf_heap_layout; - -static void ma_lpf_calculate_sub_lpf_counts(ma_uint32 order, ma_uint32* pLPF1Count, ma_uint32* pLPF2Count) -{ - MA_ASSERT(pLPF1Count != NULL); - MA_ASSERT(pLPF2Count != NULL); - - *pLPF1Count = order % 2; - *pLPF2Count = order / 2; -} - -static ma_result ma_lpf_get_heap_layout(const ma_lpf_config* pConfig, ma_lpf_heap_layout* pHeapLayout) -{ - ma_result result; - ma_uint32 lpf1Count; - ma_uint32 lpf2Count; - ma_uint32 ilpf1; - ma_uint32 ilpf2; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - if (pConfig->order > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - ma_lpf_calculate_sub_lpf_counts(pConfig->order, &lpf1Count, &lpf2Count); - - pHeapLayout->sizeInBytes = 0; - - /* LPF 1 */ - pHeapLayout->lpf1Offset = pHeapLayout->sizeInBytes; - for (ilpf1 = 0; ilpf1 < lpf1Count; ilpf1 += 1) { - size_t lpf1HeapSizeInBytes; - ma_lpf1_config lpf1Config = ma_lpf1_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency); - - result = ma_lpf1_get_heap_size(&lpf1Config, &lpf1HeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += sizeof(ma_lpf1) + lpf1HeapSizeInBytes; - } - - /* LPF 2*/ - pHeapLayout->lpf2Offset = pHeapLayout->sizeInBytes; - for (ilpf2 = 0; ilpf2 < lpf2Count; ilpf2 += 1) { - size_t lpf2HeapSizeInBytes; - ma_lpf2_config lpf2Config = ma_lpf2_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency, 0.707107); /* <-- The "q" parameter does not matter for the purpose of calculating the heap size. */ - - result = ma_lpf2_get_heap_size(&lpf2Config, &lpf2HeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += sizeof(ma_lpf2) + lpf2HeapSizeInBytes; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -static ma_result ma_lpf_reinit__internal(const ma_lpf_config* pConfig, void* pHeap, ma_lpf* pLPF, ma_bool32 isNew) -{ - ma_result result; - ma_uint32 lpf1Count; - ma_uint32 lpf2Count; - ma_uint32 ilpf1; - ma_uint32 ilpf2; - ma_lpf_heap_layout heapLayout; /* Only used if isNew is true. */ - - if (pLPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Only supporting f32 and s16. */ - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - /* The format cannot be changed after initialization. */ - if (pLPF->format != ma_format_unknown && pLPF->format != pConfig->format) { - return MA_INVALID_OPERATION; - } - - /* The channel count cannot be changed after initialization. */ - if (pLPF->channels != 0 && pLPF->channels != pConfig->channels) { - return MA_INVALID_OPERATION; - } - - if (pConfig->order > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - ma_lpf_calculate_sub_lpf_counts(pConfig->order, &lpf1Count, &lpf2Count); - - /* The filter order can't change between reinits. */ - if (!isNew) { - if (pLPF->lpf1Count != lpf1Count || pLPF->lpf2Count != lpf2Count) { - return MA_INVALID_OPERATION; - } - } - - if (isNew) { - result = ma_lpf_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pLPF->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pLPF->pLPF1 = (ma_lpf1*)ma_offset_ptr(pHeap, heapLayout.lpf1Offset); - pLPF->pLPF2 = (ma_lpf2*)ma_offset_ptr(pHeap, heapLayout.lpf2Offset); - } else { - MA_ZERO_OBJECT(&heapLayout); /* To silence a compiler warning. */ - } - - for (ilpf1 = 0; ilpf1 < lpf1Count; ilpf1 += 1) { - ma_lpf1_config lpf1Config = ma_lpf1_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency); - - if (isNew) { - size_t lpf1HeapSizeInBytes; - - result = ma_lpf1_get_heap_size(&lpf1Config, &lpf1HeapSizeInBytes); - if (result == MA_SUCCESS) { - result = ma_lpf1_init_preallocated(&lpf1Config, ma_offset_ptr(pHeap, heapLayout.lpf1Offset + (sizeof(ma_lpf1) * lpf1Count) + (ilpf1 * lpf1HeapSizeInBytes)), &pLPF->pLPF1[ilpf1]); - } - } else { - result = ma_lpf1_reinit(&lpf1Config, &pLPF->pLPF1[ilpf1]); - } - - if (result != MA_SUCCESS) { - ma_uint32 jlpf1; - - for (jlpf1 = 0; jlpf1 < ilpf1; jlpf1 += 1) { - ma_lpf1_uninit(&pLPF->pLPF1[jlpf1], NULL); /* No need for allocation callbacks here since we used a preallocated heap allocation. */ - } - - return result; - } - } - - for (ilpf2 = 0; ilpf2 < lpf2Count; ilpf2 += 1) { - ma_lpf2_config lpf2Config; - double q; - double a; - - /* Tempting to use 0.707107, but won't result in a Butterworth filter if the order is > 2. */ - if (lpf1Count == 1) { - a = (1 + ilpf2*1) * (MA_PI_D/(pConfig->order*1)); /* Odd order. */ - } else { - a = (1 + ilpf2*2) * (MA_PI_D/(pConfig->order*2)); /* Even order. */ - } - q = 1 / (2*ma_cosd(a)); - - lpf2Config = ma_lpf2_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency, q); - - if (isNew) { - size_t lpf2HeapSizeInBytes; - - result = ma_lpf2_get_heap_size(&lpf2Config, &lpf2HeapSizeInBytes); - if (result == MA_SUCCESS) { - result = ma_lpf2_init_preallocated(&lpf2Config, ma_offset_ptr(pHeap, heapLayout.lpf2Offset + (sizeof(ma_lpf2) * lpf2Count) + (ilpf2 * lpf2HeapSizeInBytes)), &pLPF->pLPF2[ilpf2]); - } - } else { - result = ma_lpf2_reinit(&lpf2Config, &pLPF->pLPF2[ilpf2]); - } - - if (result != MA_SUCCESS) { - ma_uint32 jlpf1; - ma_uint32 jlpf2; - - for (jlpf1 = 0; jlpf1 < lpf1Count; jlpf1 += 1) { - ma_lpf1_uninit(&pLPF->pLPF1[jlpf1], NULL); /* No need for allocation callbacks here since we used a preallocated heap allocation. */ - } - - for (jlpf2 = 0; jlpf2 < ilpf2; jlpf2 += 1) { - ma_lpf2_uninit(&pLPF->pLPF2[jlpf2], NULL); /* No need for allocation callbacks here since we used a preallocated heap allocation. */ - } - - return result; - } - } - - pLPF->lpf1Count = lpf1Count; - pLPF->lpf2Count = lpf2Count; - pLPF->format = pConfig->format; - pLPF->channels = pConfig->channels; - pLPF->sampleRate = pConfig->sampleRate; - - return MA_SUCCESS; -} - -MA_API ma_result ma_lpf_get_heap_size(const ma_lpf_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_lpf_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_lpf_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return result; -} - -MA_API ma_result ma_lpf_init_preallocated(const ma_lpf_config* pConfig, void* pHeap, ma_lpf* pLPF) -{ - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pLPF); - - return ma_lpf_reinit__internal(pConfig, pHeap, pLPF, /*isNew*/MA_TRUE); -} - -MA_API ma_result ma_lpf_init(const ma_lpf_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf* pLPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_lpf_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_lpf_init_preallocated(pConfig, pHeap, pLPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pLPF->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_lpf_uninit(ma_lpf* pLPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_uint32 ilpf1; - ma_uint32 ilpf2; - - if (pLPF == NULL) { - return; - } - - for (ilpf1 = 0; ilpf1 < pLPF->lpf1Count; ilpf1 += 1) { - ma_lpf1_uninit(&pLPF->pLPF1[ilpf1], pAllocationCallbacks); - } - - for (ilpf2 = 0; ilpf2 < pLPF->lpf2Count; ilpf2 += 1) { - ma_lpf2_uninit(&pLPF->pLPF2[ilpf2], pAllocationCallbacks); - } - - if (pLPF->_ownsHeap) { - ma_free(pLPF->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_lpf_reinit(const ma_lpf_config* pConfig, ma_lpf* pLPF) -{ - return ma_lpf_reinit__internal(pConfig, NULL, pLPF, /*isNew*/MA_FALSE); -} - -MA_API ma_result ma_lpf_clear_cache(ma_lpf* pLPF) -{ - ma_uint32 ilpf1; - ma_uint32 ilpf2; - - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - for (ilpf1 = 0; ilpf1 < pLPF->lpf1Count; ilpf1 += 1) { - ma_lpf1_clear_cache(&pLPF->pLPF1[ilpf1]); - } - - for (ilpf2 = 0; ilpf2 < pLPF->lpf2Count; ilpf2 += 1) { - ma_lpf2_clear_cache(&pLPF->pLPF2[ilpf2]); - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_lpf_process_pcm_frame_f32(ma_lpf* pLPF, float* pY, const void* pX) -{ - ma_uint32 ilpf1; - ma_uint32 ilpf2; - - MA_ASSERT(pLPF->format == ma_format_f32); - - MA_MOVE_MEMORY(pY, pX, ma_get_bytes_per_frame(pLPF->format, pLPF->channels)); - - for (ilpf1 = 0; ilpf1 < pLPF->lpf1Count; ilpf1 += 1) { - ma_lpf1_process_pcm_frame_f32(&pLPF->pLPF1[ilpf1], pY, pY); - } - - for (ilpf2 = 0; ilpf2 < pLPF->lpf2Count; ilpf2 += 1) { - ma_lpf2_process_pcm_frame_f32(&pLPF->pLPF2[ilpf2], pY, pY); - } -} - -static MA_INLINE void ma_lpf_process_pcm_frame_s16(ma_lpf* pLPF, ma_int16* pY, const ma_int16* pX) -{ - ma_uint32 ilpf1; - ma_uint32 ilpf2; - - MA_ASSERT(pLPF->format == ma_format_s16); - - MA_MOVE_MEMORY(pY, pX, ma_get_bytes_per_frame(pLPF->format, pLPF->channels)); - - for (ilpf1 = 0; ilpf1 < pLPF->lpf1Count; ilpf1 += 1) { - ma_lpf1_process_pcm_frame_s16(&pLPF->pLPF1[ilpf1], pY, pY); - } - - for (ilpf2 = 0; ilpf2 < pLPF->lpf2Count; ilpf2 += 1) { - ma_lpf2_process_pcm_frame_s16(&pLPF->pLPF2[ilpf2], pY, pY); - } -} - -MA_API ma_result ma_lpf_process_pcm_frames(ma_lpf* pLPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_result result; - ma_uint32 ilpf1; - ma_uint32 ilpf2; - - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - /* Faster path for in-place. */ - if (pFramesOut == pFramesIn) { - for (ilpf1 = 0; ilpf1 < pLPF->lpf1Count; ilpf1 += 1) { - result = ma_lpf1_process_pcm_frames(&pLPF->pLPF1[ilpf1], pFramesOut, pFramesOut, frameCount); - if (result != MA_SUCCESS) { - return result; - } - } - - for (ilpf2 = 0; ilpf2 < pLPF->lpf2Count; ilpf2 += 1) { - result = ma_lpf2_process_pcm_frames(&pLPF->pLPF2[ilpf2], pFramesOut, pFramesOut, frameCount); - if (result != MA_SUCCESS) { - return result; - } - } - } - - /* Slightly slower path for copying. */ - if (pFramesOut != pFramesIn) { - ma_uint32 iFrame; - - /* */ if (pLPF->format == ma_format_f32) { - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_lpf_process_pcm_frame_f32(pLPF, pFramesOutF32, pFramesInF32); - pFramesOutF32 += pLPF->channels; - pFramesInF32 += pLPF->channels; - } - } else if (pLPF->format == ma_format_s16) { - /* */ ma_int16* pFramesOutS16 = ( ma_int16*)pFramesOut; - const ma_int16* pFramesInS16 = (const ma_int16*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_lpf_process_pcm_frame_s16(pLPF, pFramesOutS16, pFramesInS16); - pFramesOutS16 += pLPF->channels; - pFramesInS16 += pLPF->channels; - } - } else { - MA_ASSERT(MA_FALSE); - return MA_INVALID_OPERATION; /* Should never hit this. */ - } - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_lpf_get_latency(const ma_lpf* pLPF) -{ - if (pLPF == NULL) { - return 0; - } - - return pLPF->lpf2Count*2 + pLPF->lpf1Count; -} - - -/************************************************************************************************************************************************************** - -High-Pass Filtering - -**************************************************************************************************************************************************************/ -MA_API ma_hpf1_config ma_hpf1_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency) -{ - ma_hpf1_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - - return config; -} - -MA_API ma_hpf2_config ma_hpf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, double q) -{ - ma_hpf2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.q = q; - - /* Q cannot be 0 or else it'll result in a division by 0. In this case just default to 0.707107. */ - if (config.q == 0) { - config.q = 0.707107; - } - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t r1Offset; -} ma_hpf1_heap_layout; - -static ma_result ma_hpf1_get_heap_layout(const ma_hpf1_config* pConfig, ma_hpf1_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* R1 */ - pHeapLayout->r1Offset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(ma_biquad_coefficient) * pConfig->channels; - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_hpf1_get_heap_size(const ma_hpf1_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_hpf1_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_hpf1_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_hpf1_init_preallocated(const ma_hpf1_config* pConfig, void* pHeap, ma_hpf1* pLPF) -{ - ma_result result; - ma_hpf1_heap_layout heapLayout; - - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pLPF); - - result = ma_hpf1_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pLPF->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pLPF->pR1 = (ma_biquad_coefficient*)ma_offset_ptr(pHeap, heapLayout.r1Offset); - - return ma_hpf1_reinit(pConfig, pLPF); -} - -MA_API ma_result ma_hpf1_init(const ma_hpf1_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf1* pLPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_hpf1_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_hpf1_init_preallocated(pConfig, pHeap, pLPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pLPF->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_hpf1_uninit(ma_hpf1* pHPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pHPF == NULL) { - return; - } - - if (pHPF->_ownsHeap) { - ma_free(pHPF->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_hpf1_reinit(const ma_hpf1_config* pConfig, ma_hpf1* pHPF) -{ - double a; - - if (pHPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Only supporting f32 and s16. */ - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - /* The format cannot be changed after initialization. */ - if (pHPF->format != ma_format_unknown && pHPF->format != pConfig->format) { - return MA_INVALID_OPERATION; - } - - /* The channel count cannot be changed after initialization. */ - if (pHPF->channels != 0 && pHPF->channels != pConfig->channels) { - return MA_INVALID_OPERATION; - } - - pHPF->format = pConfig->format; - pHPF->channels = pConfig->channels; - - a = ma_expd(-2 * MA_PI_D * pConfig->cutoffFrequency / pConfig->sampleRate); - if (pConfig->format == ma_format_f32) { - pHPF->a.f32 = (float)a; - } else { - pHPF->a.s32 = ma_biquad_float_to_fp(a); - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_hpf1_process_pcm_frame_f32(ma_hpf1* pHPF, float* pY, const float* pX) -{ - ma_uint32 c; - const ma_uint32 channels = pHPF->channels; - const float a = 1 - pHPF->a.f32; - const float b = 1 - a; - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - float r1 = pHPF->pR1[c].f32; - float x = pX[c]; - float y; - - y = b*x - a*r1; - - pY[c] = y; - pHPF->pR1[c].f32 = y; - } -} - -static MA_INLINE void ma_hpf1_process_pcm_frame_s16(ma_hpf1* pHPF, ma_int16* pY, const ma_int16* pX) -{ - ma_uint32 c; - const ma_uint32 channels = pHPF->channels; - const ma_int32 a = ((1 << MA_BIQUAD_FIXED_POINT_SHIFT) - pHPF->a.s32); - const ma_int32 b = ((1 << MA_BIQUAD_FIXED_POINT_SHIFT) - a); - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - ma_int32 r1 = pHPF->pR1[c].s32; - ma_int32 x = pX[c]; - ma_int32 y; - - y = (b*x - a*r1) >> MA_BIQUAD_FIXED_POINT_SHIFT; - - pY[c] = (ma_int16)y; - pHPF->pR1[c].s32 = (ma_int32)y; - } -} - -MA_API ma_result ma_hpf1_process_pcm_frames(ma_hpf1* pHPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_uint32 n; - - if (pHPF == NULL || pFramesOut == NULL || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - /* Note that the logic below needs to support in-place filtering. That is, it must support the case where pFramesOut and pFramesIn are the same. */ - - if (pHPF->format == ma_format_f32) { - /* */ float* pY = ( float*)pFramesOut; - const float* pX = (const float*)pFramesIn; - - for (n = 0; n < frameCount; n += 1) { - ma_hpf1_process_pcm_frame_f32(pHPF, pY, pX); - pY += pHPF->channels; - pX += pHPF->channels; - } - } else if (pHPF->format == ma_format_s16) { - /* */ ma_int16* pY = ( ma_int16*)pFramesOut; - const ma_int16* pX = (const ma_int16*)pFramesIn; - - for (n = 0; n < frameCount; n += 1) { - ma_hpf1_process_pcm_frame_s16(pHPF, pY, pX); - pY += pHPF->channels; - pX += pHPF->channels; - } - } else { - MA_ASSERT(MA_FALSE); - return MA_INVALID_ARGS; /* Format not supported. Should never hit this because it's checked in ma_biquad_init() and ma_biquad_reinit(). */ - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_hpf1_get_latency(const ma_hpf1* pHPF) -{ - if (pHPF == NULL) { - return 0; - } - - return 1; -} - - -static MA_INLINE ma_biquad_config ma_hpf2__get_biquad_config(const ma_hpf2_config* pConfig) -{ - ma_biquad_config bqConfig; - double q; - double w; - double s; - double c; - double a; - - MA_ASSERT(pConfig != NULL); - - q = pConfig->q; - w = 2 * MA_PI_D * pConfig->cutoffFrequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - a = s / (2*q); - - bqConfig.b0 = (1 + c) / 2; - bqConfig.b1 = -(1 + c); - bqConfig.b2 = (1 + c) / 2; - bqConfig.a0 = 1 + a; - bqConfig.a1 = -2 * c; - bqConfig.a2 = 1 - a; - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_hpf2_get_heap_size(const ma_hpf2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_hpf2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_hpf2_init_preallocated(const ma_hpf2_config* pConfig, void* pHeap, ma_hpf2* pHPF) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pHPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pHPF); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_hpf2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pHPF->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_hpf2_init(const ma_hpf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf2* pHPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_hpf2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_hpf2_init_preallocated(pConfig, pHeap, pHPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pHPF->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_hpf2_uninit(ma_hpf2* pHPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pHPF == NULL) { - return; - } - - ma_biquad_uninit(&pHPF->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_hpf2_reinit(const ma_hpf2_config* pConfig, ma_hpf2* pHPF) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pHPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_hpf2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pHPF->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_hpf2_process_pcm_frame_s16(ma_hpf2* pHPF, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pHPF->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_hpf2_process_pcm_frame_f32(ma_hpf2* pHPF, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pHPF->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_hpf2_process_pcm_frames(ma_hpf2* pHPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pHPF == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pHPF->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_hpf2_get_latency(const ma_hpf2* pHPF) -{ - if (pHPF == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pHPF->bq); -} - - -MA_API ma_hpf_config ma_hpf_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order) -{ - ma_hpf_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.order = ma_min(order, MA_MAX_FILTER_ORDER); - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t hpf1Offset; - size_t hpf2Offset; /* Offset of the first second order filter. Subsequent filters will come straight after, and will each have the same heap size. */ -} ma_hpf_heap_layout; - -static void ma_hpf_calculate_sub_hpf_counts(ma_uint32 order, ma_uint32* pHPF1Count, ma_uint32* pHPF2Count) -{ - MA_ASSERT(pHPF1Count != NULL); - MA_ASSERT(pHPF2Count != NULL); - - *pHPF1Count = order % 2; - *pHPF2Count = order / 2; -} - -static ma_result ma_hpf_get_heap_layout(const ma_hpf_config* pConfig, ma_hpf_heap_layout* pHeapLayout) -{ - ma_result result; - ma_uint32 hpf1Count; - ma_uint32 hpf2Count; - ma_uint32 ihpf1; - ma_uint32 ihpf2; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - if (pConfig->order > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - ma_hpf_calculate_sub_hpf_counts(pConfig->order, &hpf1Count, &hpf2Count); - - pHeapLayout->sizeInBytes = 0; - - /* HPF 1 */ - pHeapLayout->hpf1Offset = pHeapLayout->sizeInBytes; - for (ihpf1 = 0; ihpf1 < hpf1Count; ihpf1 += 1) { - size_t hpf1HeapSizeInBytes; - ma_hpf1_config hpf1Config = ma_hpf1_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency); - - result = ma_hpf1_get_heap_size(&hpf1Config, &hpf1HeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += sizeof(ma_hpf1) + hpf1HeapSizeInBytes; - } - - /* HPF 2*/ - pHeapLayout->hpf2Offset = pHeapLayout->sizeInBytes; - for (ihpf2 = 0; ihpf2 < hpf2Count; ihpf2 += 1) { - size_t hpf2HeapSizeInBytes; - ma_hpf2_config hpf2Config = ma_hpf2_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency, 0.707107); /* <-- The "q" parameter does not matter for the purpose of calculating the heap size. */ - - result = ma_hpf2_get_heap_size(&hpf2Config, &hpf2HeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += sizeof(ma_hpf2) + hpf2HeapSizeInBytes; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -static ma_result ma_hpf_reinit__internal(const ma_hpf_config* pConfig, void* pHeap, ma_hpf* pHPF, ma_bool32 isNew) -{ - ma_result result; - ma_uint32 hpf1Count; - ma_uint32 hpf2Count; - ma_uint32 ihpf1; - ma_uint32 ihpf2; - ma_hpf_heap_layout heapLayout; /* Only used if isNew is true. */ - - if (pHPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Only supporting f32 and s16. */ - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - /* The format cannot be changed after initialization. */ - if (pHPF->format != ma_format_unknown && pHPF->format != pConfig->format) { - return MA_INVALID_OPERATION; - } - - /* The channel count cannot be changed after initialization. */ - if (pHPF->channels != 0 && pHPF->channels != pConfig->channels) { - return MA_INVALID_OPERATION; - } - - if (pConfig->order > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - ma_hpf_calculate_sub_hpf_counts(pConfig->order, &hpf1Count, &hpf2Count); - - /* The filter order can't change between reinits. */ - if (!isNew) { - if (pHPF->hpf1Count != hpf1Count || pHPF->hpf2Count != hpf2Count) { - return MA_INVALID_OPERATION; - } - } - - if (isNew) { - result = ma_hpf_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pHPF->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pHPF->pHPF1 = (ma_hpf1*)ma_offset_ptr(pHeap, heapLayout.hpf1Offset); - pHPF->pHPF2 = (ma_hpf2*)ma_offset_ptr(pHeap, heapLayout.hpf2Offset); - } else { - MA_ZERO_OBJECT(&heapLayout); /* To silence a compiler warning. */ - } - - for (ihpf1 = 0; ihpf1 < hpf1Count; ihpf1 += 1) { - ma_hpf1_config hpf1Config = ma_hpf1_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency); - - if (isNew) { - size_t hpf1HeapSizeInBytes; - - result = ma_hpf1_get_heap_size(&hpf1Config, &hpf1HeapSizeInBytes); - if (result == MA_SUCCESS) { - result = ma_hpf1_init_preallocated(&hpf1Config, ma_offset_ptr(pHeap, heapLayout.hpf1Offset + (sizeof(ma_hpf1) * hpf1Count) + (ihpf1 * hpf1HeapSizeInBytes)), &pHPF->pHPF1[ihpf1]); - } - } else { - result = ma_hpf1_reinit(&hpf1Config, &pHPF->pHPF1[ihpf1]); - } - - if (result != MA_SUCCESS) { - ma_uint32 jhpf1; - - for (jhpf1 = 0; jhpf1 < ihpf1; jhpf1 += 1) { - ma_hpf1_uninit(&pHPF->pHPF1[jhpf1], NULL); /* No need for allocation callbacks here since we used a preallocated heap allocation. */ - } - - return result; - } - } - - for (ihpf2 = 0; ihpf2 < hpf2Count; ihpf2 += 1) { - ma_hpf2_config hpf2Config; - double q; - double a; - - /* Tempting to use 0.707107, but won't result in a Butterworth filter if the order is > 2. */ - if (hpf1Count == 1) { - a = (1 + ihpf2*1) * (MA_PI_D/(pConfig->order*1)); /* Odd order. */ - } else { - a = (1 + ihpf2*2) * (MA_PI_D/(pConfig->order*2)); /* Even order. */ - } - q = 1 / (2*ma_cosd(a)); - - hpf2Config = ma_hpf2_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency, q); - - if (isNew) { - size_t hpf2HeapSizeInBytes; - - result = ma_hpf2_get_heap_size(&hpf2Config, &hpf2HeapSizeInBytes); - if (result == MA_SUCCESS) { - result = ma_hpf2_init_preallocated(&hpf2Config, ma_offset_ptr(pHeap, heapLayout.hpf2Offset + (sizeof(ma_hpf2) * hpf2Count) + (ihpf2 * hpf2HeapSizeInBytes)), &pHPF->pHPF2[ihpf2]); - } - } else { - result = ma_hpf2_reinit(&hpf2Config, &pHPF->pHPF2[ihpf2]); - } - - if (result != MA_SUCCESS) { - ma_uint32 jhpf1; - ma_uint32 jhpf2; - - for (jhpf1 = 0; jhpf1 < hpf1Count; jhpf1 += 1) { - ma_hpf1_uninit(&pHPF->pHPF1[jhpf1], NULL); /* No need for allocation callbacks here since we used a preallocated heap allocation. */ - } - - for (jhpf2 = 0; jhpf2 < ihpf2; jhpf2 += 1) { - ma_hpf2_uninit(&pHPF->pHPF2[jhpf2], NULL); /* No need for allocation callbacks here since we used a preallocated heap allocation. */ - } - - return result; - } - } - - pHPF->hpf1Count = hpf1Count; - pHPF->hpf2Count = hpf2Count; - pHPF->format = pConfig->format; - pHPF->channels = pConfig->channels; - pHPF->sampleRate = pConfig->sampleRate; - - return MA_SUCCESS; -} - -MA_API ma_result ma_hpf_get_heap_size(const ma_hpf_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_hpf_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_hpf_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return result; -} - -MA_API ma_result ma_hpf_init_preallocated(const ma_hpf_config* pConfig, void* pHeap, ma_hpf* pLPF) -{ - if (pLPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pLPF); - - return ma_hpf_reinit__internal(pConfig, pHeap, pLPF, /*isNew*/MA_TRUE); -} - -MA_API ma_result ma_hpf_init(const ma_hpf_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf* pHPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_hpf_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_hpf_init_preallocated(pConfig, pHeap, pHPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pHPF->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_hpf_uninit(ma_hpf* pHPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_uint32 ihpf1; - ma_uint32 ihpf2; - - if (pHPF == NULL) { - return; - } - - for (ihpf1 = 0; ihpf1 < pHPF->hpf1Count; ihpf1 += 1) { - ma_hpf1_uninit(&pHPF->pHPF1[ihpf1], pAllocationCallbacks); - } - - for (ihpf2 = 0; ihpf2 < pHPF->hpf2Count; ihpf2 += 1) { - ma_hpf2_uninit(&pHPF->pHPF2[ihpf2], pAllocationCallbacks); - } - - if (pHPF->_ownsHeap) { - ma_free(pHPF->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_hpf_reinit(const ma_hpf_config* pConfig, ma_hpf* pHPF) -{ - return ma_hpf_reinit__internal(pConfig, NULL, pHPF, /*isNew*/MA_FALSE); -} - -MA_API ma_result ma_hpf_process_pcm_frames(ma_hpf* pHPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_result result; - ma_uint32 ihpf1; - ma_uint32 ihpf2; - - if (pHPF == NULL) { - return MA_INVALID_ARGS; - } - - /* Faster path for in-place. */ - if (pFramesOut == pFramesIn) { - for (ihpf1 = 0; ihpf1 < pHPF->hpf1Count; ihpf1 += 1) { - result = ma_hpf1_process_pcm_frames(&pHPF->pHPF1[ihpf1], pFramesOut, pFramesOut, frameCount); - if (result != MA_SUCCESS) { - return result; - } - } - - for (ihpf2 = 0; ihpf2 < pHPF->hpf2Count; ihpf2 += 1) { - result = ma_hpf2_process_pcm_frames(&pHPF->pHPF2[ihpf2], pFramesOut, pFramesOut, frameCount); - if (result != MA_SUCCESS) { - return result; - } - } - } - - /* Slightly slower path for copying. */ - if (pFramesOut != pFramesIn) { - ma_uint32 iFrame; - - /* */ if (pHPF->format == ma_format_f32) { - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - MA_COPY_MEMORY(pFramesOutF32, pFramesInF32, ma_get_bytes_per_frame(pHPF->format, pHPF->channels)); - - for (ihpf1 = 0; ihpf1 < pHPF->hpf1Count; ihpf1 += 1) { - ma_hpf1_process_pcm_frame_f32(&pHPF->pHPF1[ihpf1], pFramesOutF32, pFramesOutF32); - } - - for (ihpf2 = 0; ihpf2 < pHPF->hpf2Count; ihpf2 += 1) { - ma_hpf2_process_pcm_frame_f32(&pHPF->pHPF2[ihpf2], pFramesOutF32, pFramesOutF32); - } - - pFramesOutF32 += pHPF->channels; - pFramesInF32 += pHPF->channels; - } - } else if (pHPF->format == ma_format_s16) { - /* */ ma_int16* pFramesOutS16 = ( ma_int16*)pFramesOut; - const ma_int16* pFramesInS16 = (const ma_int16*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - MA_COPY_MEMORY(pFramesOutS16, pFramesInS16, ma_get_bytes_per_frame(pHPF->format, pHPF->channels)); - - for (ihpf1 = 0; ihpf1 < pHPF->hpf1Count; ihpf1 += 1) { - ma_hpf1_process_pcm_frame_s16(&pHPF->pHPF1[ihpf1], pFramesOutS16, pFramesOutS16); - } - - for (ihpf2 = 0; ihpf2 < pHPF->hpf2Count; ihpf2 += 1) { - ma_hpf2_process_pcm_frame_s16(&pHPF->pHPF2[ihpf2], pFramesOutS16, pFramesOutS16); - } - - pFramesOutS16 += pHPF->channels; - pFramesInS16 += pHPF->channels; - } - } else { - MA_ASSERT(MA_FALSE); - return MA_INVALID_OPERATION; /* Should never hit this. */ - } - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_hpf_get_latency(const ma_hpf* pHPF) -{ - if (pHPF == NULL) { - return 0; - } - - return pHPF->hpf2Count*2 + pHPF->hpf1Count; -} - - -/************************************************************************************************************************************************************** - -Band-Pass Filtering - -**************************************************************************************************************************************************************/ -MA_API ma_bpf2_config ma_bpf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, double q) -{ - ma_bpf2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.q = q; - - /* Q cannot be 0 or else it'll result in a division by 0. In this case just default to 0.707107. */ - if (config.q == 0) { - config.q = 0.707107; - } - - return config; -} - - -static MA_INLINE ma_biquad_config ma_bpf2__get_biquad_config(const ma_bpf2_config* pConfig) -{ - ma_biquad_config bqConfig; - double q; - double w; - double s; - double c; - double a; - - MA_ASSERT(pConfig != NULL); - - q = pConfig->q; - w = 2 * MA_PI_D * pConfig->cutoffFrequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - a = s / (2*q); - - bqConfig.b0 = q * a; - bqConfig.b1 = 0; - bqConfig.b2 = -q * a; - bqConfig.a0 = 1 + a; - bqConfig.a1 = -2 * c; - bqConfig.a2 = 1 - a; - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_bpf2_get_heap_size(const ma_bpf2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_bpf2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_bpf2_init_preallocated(const ma_bpf2_config* pConfig, void* pHeap, ma_bpf2* pBPF) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pBPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pBPF); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_bpf2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pBPF->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_bpf2_init(const ma_bpf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_bpf2* pBPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_bpf2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_bpf2_init_preallocated(pConfig, pHeap, pBPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pBPF->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_bpf2_uninit(ma_bpf2* pBPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pBPF == NULL) { - return; - } - - ma_biquad_uninit(&pBPF->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_bpf2_reinit(const ma_bpf2_config* pConfig, ma_bpf2* pBPF) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pBPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_bpf2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pBPF->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_bpf2_process_pcm_frame_s16(ma_bpf2* pBPF, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pBPF->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_bpf2_process_pcm_frame_f32(ma_bpf2* pBPF, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pBPF->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_bpf2_process_pcm_frames(ma_bpf2* pBPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pBPF == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pBPF->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_bpf2_get_latency(const ma_bpf2* pBPF) -{ - if (pBPF == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pBPF->bq); -} - - -MA_API ma_bpf_config ma_bpf_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order) -{ - ma_bpf_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.cutoffFrequency = cutoffFrequency; - config.order = ma_min(order, MA_MAX_FILTER_ORDER); - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t bpf2Offset; -} ma_bpf_heap_layout; - -static ma_result ma_bpf_get_heap_layout(const ma_bpf_config* pConfig, ma_bpf_heap_layout* pHeapLayout) -{ - ma_result result; - ma_uint32 bpf2Count; - ma_uint32 ibpf2; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->order > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - /* We must have an even number of order. */ - if ((pConfig->order & 0x1) != 0) { - return MA_INVALID_ARGS; - } - - bpf2Count = pConfig->channels / 2; - - pHeapLayout->sizeInBytes = 0; - - /* BPF 2 */ - pHeapLayout->bpf2Offset = pHeapLayout->sizeInBytes; - for (ibpf2 = 0; ibpf2 < bpf2Count; ibpf2 += 1) { - size_t bpf2HeapSizeInBytes; - ma_bpf2_config bpf2Config = ma_bpf2_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency, 0.707107); /* <-- The "q" parameter does not matter for the purpose of calculating the heap size. */ - - result = ma_bpf2_get_heap_size(&bpf2Config, &bpf2HeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += sizeof(ma_bpf2) + bpf2HeapSizeInBytes; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -static ma_result ma_bpf_reinit__internal(const ma_bpf_config* pConfig, void* pHeap, ma_bpf* pBPF, ma_bool32 isNew) -{ - ma_result result; - ma_uint32 bpf2Count; - ma_uint32 ibpf2; - ma_bpf_heap_layout heapLayout; /* Only used if isNew is true. */ - - if (pBPF == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Only supporting f32 and s16. */ - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - /* The format cannot be changed after initialization. */ - if (pBPF->format != ma_format_unknown && pBPF->format != pConfig->format) { - return MA_INVALID_OPERATION; - } - - /* The channel count cannot be changed after initialization. */ - if (pBPF->channels != 0 && pBPF->channels != pConfig->channels) { - return MA_INVALID_OPERATION; - } - - if (pConfig->order > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - /* We must have an even number of order. */ - if ((pConfig->order & 0x1) != 0) { - return MA_INVALID_ARGS; - } - - bpf2Count = pConfig->order / 2; - - /* The filter order can't change between reinits. */ - if (!isNew) { - if (pBPF->bpf2Count != bpf2Count) { - return MA_INVALID_OPERATION; - } - } - - if (isNew) { - result = ma_bpf_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pBPF->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pBPF->pBPF2 = (ma_bpf2*)ma_offset_ptr(pHeap, heapLayout.bpf2Offset); - } else { - MA_ZERO_OBJECT(&heapLayout); - } - - for (ibpf2 = 0; ibpf2 < bpf2Count; ibpf2 += 1) { - ma_bpf2_config bpf2Config; - double q; - - /* TODO: Calculate Q to make this a proper Butterworth filter. */ - q = 0.707107; - - bpf2Config = ma_bpf2_config_init(pConfig->format, pConfig->channels, pConfig->sampleRate, pConfig->cutoffFrequency, q); - - if (isNew) { - size_t bpf2HeapSizeInBytes; - - result = ma_bpf2_get_heap_size(&bpf2Config, &bpf2HeapSizeInBytes); - if (result == MA_SUCCESS) { - result = ma_bpf2_init_preallocated(&bpf2Config, ma_offset_ptr(pHeap, heapLayout.bpf2Offset + (sizeof(ma_bpf2) * bpf2Count) + (ibpf2 * bpf2HeapSizeInBytes)), &pBPF->pBPF2[ibpf2]); - } - } else { - result = ma_bpf2_reinit(&bpf2Config, &pBPF->pBPF2[ibpf2]); - } - - if (result != MA_SUCCESS) { - return result; - } - } - - pBPF->bpf2Count = bpf2Count; - pBPF->format = pConfig->format; - pBPF->channels = pConfig->channels; - - return MA_SUCCESS; -} - - -MA_API ma_result ma_bpf_get_heap_size(const ma_bpf_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_bpf_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_bpf_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_bpf_init_preallocated(const ma_bpf_config* pConfig, void* pHeap, ma_bpf* pBPF) -{ - if (pBPF == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pBPF); - - return ma_bpf_reinit__internal(pConfig, pHeap, pBPF, /*isNew*/MA_TRUE); -} - -MA_API ma_result ma_bpf_init(const ma_bpf_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_bpf* pBPF) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_bpf_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_bpf_init_preallocated(pConfig, pHeap, pBPF); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pBPF->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_bpf_uninit(ma_bpf* pBPF, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_uint32 ibpf2; - - if (pBPF == NULL) { - return; - } - - for (ibpf2 = 0; ibpf2 < pBPF->bpf2Count; ibpf2 += 1) { - ma_bpf2_uninit(&pBPF->pBPF2[ibpf2], pAllocationCallbacks); - } - - if (pBPF->_ownsHeap) { - ma_free(pBPF->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_bpf_reinit(const ma_bpf_config* pConfig, ma_bpf* pBPF) -{ - return ma_bpf_reinit__internal(pConfig, NULL, pBPF, /*isNew*/MA_FALSE); -} - -MA_API ma_result ma_bpf_process_pcm_frames(ma_bpf* pBPF, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_result result; - ma_uint32 ibpf2; - - if (pBPF == NULL) { - return MA_INVALID_ARGS; - } - - /* Faster path for in-place. */ - if (pFramesOut == pFramesIn) { - for (ibpf2 = 0; ibpf2 < pBPF->bpf2Count; ibpf2 += 1) { - result = ma_bpf2_process_pcm_frames(&pBPF->pBPF2[ibpf2], pFramesOut, pFramesOut, frameCount); - if (result != MA_SUCCESS) { - return result; - } - } - } - - /* Slightly slower path for copying. */ - if (pFramesOut != pFramesIn) { - ma_uint32 iFrame; - - /* */ if (pBPF->format == ma_format_f32) { - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - MA_COPY_MEMORY(pFramesOutF32, pFramesInF32, ma_get_bytes_per_frame(pBPF->format, pBPF->channels)); - - for (ibpf2 = 0; ibpf2 < pBPF->bpf2Count; ibpf2 += 1) { - ma_bpf2_process_pcm_frame_f32(&pBPF->pBPF2[ibpf2], pFramesOutF32, pFramesOutF32); - } - - pFramesOutF32 += pBPF->channels; - pFramesInF32 += pBPF->channels; - } - } else if (pBPF->format == ma_format_s16) { - /* */ ma_int16* pFramesOutS16 = ( ma_int16*)pFramesOut; - const ma_int16* pFramesInS16 = (const ma_int16*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - MA_COPY_MEMORY(pFramesOutS16, pFramesInS16, ma_get_bytes_per_frame(pBPF->format, pBPF->channels)); - - for (ibpf2 = 0; ibpf2 < pBPF->bpf2Count; ibpf2 += 1) { - ma_bpf2_process_pcm_frame_s16(&pBPF->pBPF2[ibpf2], pFramesOutS16, pFramesOutS16); - } - - pFramesOutS16 += pBPF->channels; - pFramesInS16 += pBPF->channels; - } - } else { - MA_ASSERT(MA_FALSE); - return MA_INVALID_OPERATION; /* Should never hit this. */ - } - } - - return MA_SUCCESS; -} - -MA_API ma_uint32 ma_bpf_get_latency(const ma_bpf* pBPF) -{ - if (pBPF == NULL) { - return 0; - } - - return pBPF->bpf2Count*2; -} - - -/************************************************************************************************************************************************************** - -Notching Filter - -**************************************************************************************************************************************************************/ -MA_API ma_notch2_config ma_notch2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double q, double frequency) -{ - ma_notch2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.q = q; - config.frequency = frequency; - - if (config.q == 0) { - config.q = 0.707107; - } - - return config; -} - - -static MA_INLINE ma_biquad_config ma_notch2__get_biquad_config(const ma_notch2_config* pConfig) -{ - ma_biquad_config bqConfig; - double q; - double w; - double s; - double c; - double a; - - MA_ASSERT(pConfig != NULL); - - q = pConfig->q; - w = 2 * MA_PI_D * pConfig->frequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - a = s / (2*q); - - bqConfig.b0 = 1; - bqConfig.b1 = -2 * c; - bqConfig.b2 = 1; - bqConfig.a0 = 1 + a; - bqConfig.a1 = -2 * c; - bqConfig.a2 = 1 - a; - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_notch2_get_heap_size(const ma_notch2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_notch2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_notch2_init_preallocated(const ma_notch2_config* pConfig, void* pHeap, ma_notch2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFilter); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_notch2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_notch2_init(const ma_notch2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_notch2* pFilter) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_notch2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_notch2_init_preallocated(pConfig, pHeap, pFilter); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pFilter->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_notch2_uninit(ma_notch2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pFilter == NULL) { - return; - } - - ma_biquad_uninit(&pFilter->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_notch2_reinit(const ma_notch2_config* pConfig, ma_notch2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_notch2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_notch2_process_pcm_frame_s16(ma_notch2* pFilter, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pFilter->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_notch2_process_pcm_frame_f32(ma_notch2* pFilter, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pFilter->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_notch2_process_pcm_frames(ma_notch2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pFilter->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_notch2_get_latency(const ma_notch2* pFilter) -{ - if (pFilter == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pFilter->bq); -} - - - -/************************************************************************************************************************************************************** - -Peaking EQ Filter - -**************************************************************************************************************************************************************/ -MA_API ma_peak2_config ma_peak2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency) -{ - ma_peak2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.gainDB = gainDB; - config.q = q; - config.frequency = frequency; - - if (config.q == 0) { - config.q = 0.707107; - } - - return config; -} - - -static MA_INLINE ma_biquad_config ma_peak2__get_biquad_config(const ma_peak2_config* pConfig) -{ - ma_biquad_config bqConfig; - double q; - double w; - double s; - double c; - double a; - double A; - - MA_ASSERT(pConfig != NULL); - - q = pConfig->q; - w = 2 * MA_PI_D * pConfig->frequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - a = s / (2*q); - A = ma_powd(10, (pConfig->gainDB / 40)); - - bqConfig.b0 = 1 + (a * A); - bqConfig.b1 = -2 * c; - bqConfig.b2 = 1 - (a * A); - bqConfig.a0 = 1 + (a / A); - bqConfig.a1 = -2 * c; - bqConfig.a2 = 1 - (a / A); - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_peak2_get_heap_size(const ma_peak2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_peak2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_peak2_init_preallocated(const ma_peak2_config* pConfig, void* pHeap, ma_peak2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFilter); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_peak2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_peak2_init(const ma_peak2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_peak2* pFilter) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_peak2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_peak2_init_preallocated(pConfig, pHeap, pFilter); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pFilter->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_peak2_uninit(ma_peak2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pFilter == NULL) { - return; - } - - ma_biquad_uninit(&pFilter->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_peak2_reinit(const ma_peak2_config* pConfig, ma_peak2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_peak2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_peak2_process_pcm_frame_s16(ma_peak2* pFilter, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pFilter->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_peak2_process_pcm_frame_f32(ma_peak2* pFilter, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pFilter->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_peak2_process_pcm_frames(ma_peak2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pFilter->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_peak2_get_latency(const ma_peak2* pFilter) -{ - if (pFilter == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pFilter->bq); -} - - -/************************************************************************************************************************************************************** - -Low Shelf Filter - -**************************************************************************************************************************************************************/ -MA_API ma_loshelf2_config ma_loshelf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double shelfSlope, double frequency) -{ - ma_loshelf2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.gainDB = gainDB; - config.shelfSlope = shelfSlope; - config.frequency = frequency; - - return config; -} - - -static MA_INLINE ma_biquad_config ma_loshelf2__get_biquad_config(const ma_loshelf2_config* pConfig) -{ - ma_biquad_config bqConfig; - double w; - double s; - double c; - double A; - double S; - double a; - double sqrtA; - - MA_ASSERT(pConfig != NULL); - - w = 2 * MA_PI_D * pConfig->frequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - A = ma_powd(10, (pConfig->gainDB / 40)); - S = pConfig->shelfSlope; - a = s/2 * ma_sqrtd((A + 1/A) * (1/S - 1) + 2); - sqrtA = 2*ma_sqrtd(A)*a; - - bqConfig.b0 = A * ((A + 1) - (A - 1)*c + sqrtA); - bqConfig.b1 = 2 * A * ((A - 1) - (A + 1)*c); - bqConfig.b2 = A * ((A + 1) - (A - 1)*c - sqrtA); - bqConfig.a0 = (A + 1) + (A - 1)*c + sqrtA; - bqConfig.a1 = -2 * ((A - 1) + (A + 1)*c); - bqConfig.a2 = (A + 1) + (A - 1)*c - sqrtA; - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_loshelf2_get_heap_size(const ma_loshelf2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_loshelf2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_loshelf2_init_preallocated(const ma_loshelf2_config* pConfig, void* pHeap, ma_loshelf2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFilter); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_loshelf2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_loshelf2_init(const ma_loshelf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_loshelf2* pFilter) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_loshelf2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_loshelf2_init_preallocated(pConfig, pHeap, pFilter); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pFilter->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_loshelf2_uninit(ma_loshelf2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pFilter == NULL) { - return; - } - - ma_biquad_uninit(&pFilter->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_loshelf2_reinit(const ma_loshelf2_config* pConfig, ma_loshelf2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_loshelf2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_loshelf2_process_pcm_frame_s16(ma_loshelf2* pFilter, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pFilter->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_loshelf2_process_pcm_frame_f32(ma_loshelf2* pFilter, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pFilter->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_loshelf2_process_pcm_frames(ma_loshelf2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pFilter->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_loshelf2_get_latency(const ma_loshelf2* pFilter) -{ - if (pFilter == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pFilter->bq); -} - - -/************************************************************************************************************************************************************** - -High Shelf Filter - -**************************************************************************************************************************************************************/ -MA_API ma_hishelf2_config ma_hishelf2_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double shelfSlope, double frequency) -{ - ma_hishelf2_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.gainDB = gainDB; - config.shelfSlope = shelfSlope; - config.frequency = frequency; - - return config; -} - - -static MA_INLINE ma_biquad_config ma_hishelf2__get_biquad_config(const ma_hishelf2_config* pConfig) -{ - ma_biquad_config bqConfig; - double w; - double s; - double c; - double A; - double S; - double a; - double sqrtA; - - MA_ASSERT(pConfig != NULL); - - w = 2 * MA_PI_D * pConfig->frequency / pConfig->sampleRate; - s = ma_sind(w); - c = ma_cosd(w); - A = ma_powd(10, (pConfig->gainDB / 40)); - S = pConfig->shelfSlope; - a = s/2 * ma_sqrtd((A + 1/A) * (1/S - 1) + 2); - sqrtA = 2*ma_sqrtd(A)*a; - - bqConfig.b0 = A * ((A + 1) + (A - 1)*c + sqrtA); - bqConfig.b1 = -2 * A * ((A - 1) + (A + 1)*c); - bqConfig.b2 = A * ((A + 1) + (A - 1)*c - sqrtA); - bqConfig.a0 = (A + 1) - (A - 1)*c + sqrtA; - bqConfig.a1 = 2 * ((A - 1) - (A + 1)*c); - bqConfig.a2 = (A + 1) - (A - 1)*c - sqrtA; - - bqConfig.format = pConfig->format; - bqConfig.channels = pConfig->channels; - - return bqConfig; -} - -MA_API ma_result ma_hishelf2_get_heap_size(const ma_hishelf2_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_biquad_config bqConfig; - bqConfig = ma_hishelf2__get_biquad_config(pConfig); - - return ma_biquad_get_heap_size(&bqConfig, pHeapSizeInBytes); -} - -MA_API ma_result ma_hishelf2_init_preallocated(const ma_hishelf2_config* pConfig, void* pHeap, ma_hishelf2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFilter); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_hishelf2__get_biquad_config(pConfig); - result = ma_biquad_init_preallocated(&bqConfig, pHeap, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_hishelf2_init(const ma_hishelf2_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hishelf2* pFilter) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_hishelf2_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_hishelf2_init_preallocated(pConfig, pHeap, pFilter); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pFilter->bq._ownsHeap = MA_TRUE; /* <-- This will cause the biquad to take ownership of the heap and free it when it's uninitialized. */ - return MA_SUCCESS; -} - -MA_API void ma_hishelf2_uninit(ma_hishelf2* pFilter, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pFilter == NULL) { - return; - } - - ma_biquad_uninit(&pFilter->bq, pAllocationCallbacks); /* <-- This will free the heap allocation. */ -} - -MA_API ma_result ma_hishelf2_reinit(const ma_hishelf2_config* pConfig, ma_hishelf2* pFilter) -{ - ma_result result; - ma_biquad_config bqConfig; - - if (pFilter == NULL || pConfig == NULL) { - return MA_INVALID_ARGS; - } - - bqConfig = ma_hishelf2__get_biquad_config(pConfig); - result = ma_biquad_reinit(&bqConfig, &pFilter->bq); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -static MA_INLINE void ma_hishelf2_process_pcm_frame_s16(ma_hishelf2* pFilter, ma_int16* pFrameOut, const ma_int16* pFrameIn) -{ - ma_biquad_process_pcm_frame_s16(&pFilter->bq, pFrameOut, pFrameIn); -} - -static MA_INLINE void ma_hishelf2_process_pcm_frame_f32(ma_hishelf2* pFilter, float* pFrameOut, const float* pFrameIn) -{ - ma_biquad_process_pcm_frame_f32(&pFilter->bq, pFrameOut, pFrameIn); -} - -MA_API ma_result ma_hishelf2_process_pcm_frames(ma_hishelf2* pFilter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pFilter == NULL) { - return MA_INVALID_ARGS; - } - - return ma_biquad_process_pcm_frames(&pFilter->bq, pFramesOut, pFramesIn, frameCount); -} - -MA_API ma_uint32 ma_hishelf2_get_latency(const ma_hishelf2* pFilter) -{ - if (pFilter == NULL) { - return 0; - } - - return ma_biquad_get_latency(&pFilter->bq); -} - - - -/* -Delay -*/ -MA_API ma_delay_config ma_delay_config_init(ma_uint32 channels, ma_uint32 sampleRate, ma_uint32 delayInFrames, float decay) -{ - ma_delay_config config; - - MA_ZERO_OBJECT(&config); - config.channels = channels; - config.sampleRate = sampleRate; - config.delayInFrames = delayInFrames; - config.delayStart = (decay == 0) ? MA_TRUE : MA_FALSE; /* Delay the start if it looks like we're not configuring an echo. */ - config.wet = 1; - config.dry = 1; - config.decay = decay; - - return config; -} - - -MA_API ma_result ma_delay_init(const ma_delay_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_delay* pDelay) -{ - if (pDelay == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDelay); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->decay < 0 || pConfig->decay > 1) { - return MA_INVALID_ARGS; - } - - pDelay->config = *pConfig; - pDelay->bufferSizeInFrames = pConfig->delayInFrames; - pDelay->cursor = 0; - - pDelay->pBuffer = (float*)ma_malloc((size_t)(pDelay->bufferSizeInFrames * ma_get_bytes_per_frame(ma_format_f32, pConfig->channels)), pAllocationCallbacks); - if (pDelay->pBuffer == NULL) { - return MA_OUT_OF_MEMORY; - } - - ma_silence_pcm_frames(pDelay->pBuffer, pDelay->bufferSizeInFrames, ma_format_f32, pConfig->channels); - - return MA_SUCCESS; -} - -MA_API void ma_delay_uninit(ma_delay* pDelay, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pDelay == NULL) { - return; - } - - ma_free(pDelay->pBuffer, pAllocationCallbacks); -} - -MA_API ma_result ma_delay_process_pcm_frames(ma_delay* pDelay, void* pFramesOut, const void* pFramesIn, ma_uint32 frameCount) -{ - ma_uint32 iFrame; - ma_uint32 iChannel; - float* pFramesOutF32 = (float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - if (pDelay == NULL || pFramesOut == NULL || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < pDelay->config.channels; iChannel += 1) { - ma_uint32 iBuffer = (pDelay->cursor * pDelay->config.channels) + iChannel; - - if (pDelay->config.delayStart) { - /* Delayed start. */ - - /* Read */ - pFramesOutF32[iChannel] = pDelay->pBuffer[iBuffer] * pDelay->config.wet; - - /* Feedback */ - pDelay->pBuffer[iBuffer] = (pDelay->pBuffer[iBuffer] * pDelay->config.decay) + (pFramesInF32[iChannel] * pDelay->config.dry); - } else { - /* Immediate start */ - - /* Feedback */ - pDelay->pBuffer[iBuffer] = (pDelay->pBuffer[iBuffer] * pDelay->config.decay) + (pFramesInF32[iChannel] * pDelay->config.dry); - - /* Read */ - pFramesOutF32[iChannel] = pDelay->pBuffer[iBuffer] * pDelay->config.wet; - } - } - - pDelay->cursor = (pDelay->cursor + 1) % pDelay->bufferSizeInFrames; - - pFramesOutF32 += pDelay->config.channels; - pFramesInF32 += pDelay->config.channels; - } - - return MA_SUCCESS; -} - -MA_API void ma_delay_set_wet(ma_delay* pDelay, float value) -{ - if (pDelay == NULL) { - return; - } - - pDelay->config.wet = value; -} - -MA_API float ma_delay_get_wet(const ma_delay* pDelay) -{ - if (pDelay == NULL) { - return 0; - } - - return pDelay->config.wet; -} - -MA_API void ma_delay_set_dry(ma_delay* pDelay, float value) -{ - if (pDelay == NULL) { - return; - } - - pDelay->config.dry = value; -} - -MA_API float ma_delay_get_dry(const ma_delay* pDelay) -{ - if (pDelay == NULL) { - return 0; - } - - return pDelay->config.dry; -} - -MA_API void ma_delay_set_decay(ma_delay* pDelay, float value) -{ - if (pDelay == NULL) { - return; - } - - pDelay->config.decay = value; -} - -MA_API float ma_delay_get_decay(const ma_delay* pDelay) -{ - if (pDelay == NULL) { - return 0; - } - - return pDelay->config.decay; -} - - -MA_API ma_gainer_config ma_gainer_config_init(ma_uint32 channels, ma_uint32 smoothTimeInFrames) -{ - ma_gainer_config config; - - MA_ZERO_OBJECT(&config); - config.channels = channels; - config.smoothTimeInFrames = smoothTimeInFrames; - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t oldGainsOffset; - size_t newGainsOffset; -} ma_gainer_heap_layout; - -static ma_result ma_gainer_get_heap_layout(const ma_gainer_config* pConfig, ma_gainer_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Old gains. */ - pHeapLayout->oldGainsOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(float) * pConfig->channels; - - /* New gains. */ - pHeapLayout->newGainsOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(float) * pConfig->channels; - - /* Alignment. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - - -MA_API ma_result ma_gainer_get_heap_size(const ma_gainer_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_gainer_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_gainer_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - - -MA_API ma_result ma_gainer_init_preallocated(const ma_gainer_config* pConfig, void* pHeap, ma_gainer* pGainer) -{ - ma_result result; - ma_gainer_heap_layout heapLayout; - ma_uint32 iChannel; - - if (pGainer == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pGainer); - - if (pConfig == NULL || pHeap == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_gainer_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pGainer->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pGainer->pOldGains = (float*)ma_offset_ptr(pHeap, heapLayout.oldGainsOffset); - pGainer->pNewGains = (float*)ma_offset_ptr(pHeap, heapLayout.newGainsOffset); - pGainer->masterVolume = 1; - - pGainer->config = *pConfig; - pGainer->t = (ma_uint32)-1; /* No interpolation by default. */ - - for (iChannel = 0; iChannel < pConfig->channels; iChannel += 1) { - pGainer->pOldGains[iChannel] = 1; - pGainer->pNewGains[iChannel] = 1; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_gainer_init(const ma_gainer_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_gainer* pGainer) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_gainer_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the size of the heap allocation. */ - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_gainer_init_preallocated(pConfig, pHeap, pGainer); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pGainer->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_gainer_uninit(ma_gainer* pGainer, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pGainer == NULL) { - return; - } - - if (pGainer->_ownsHeap) { - ma_free(pGainer->_pHeap, pAllocationCallbacks); - } -} - -static float ma_gainer_calculate_current_gain(const ma_gainer* pGainer, ma_uint32 channel) -{ - float a = (float)pGainer->t / pGainer->config.smoothTimeInFrames; - return ma_mix_f32_fast(pGainer->pOldGains[channel], pGainer->pNewGains[channel], a); -} - -static /*__attribute__((noinline))*/ ma_result ma_gainer_process_pcm_frames_internal(ma_gainer * pGainer, void* MA_RESTRICT pFramesOut, const void* MA_RESTRICT pFramesIn, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint32 iChannel; - ma_uint64 interpolatedFrameCount; - - MA_ASSERT(pGainer != NULL); - - /* - We don't necessarily need to apply a linear interpolation for the entire frameCount frames. When - linear interpolation is not needed we can do a simple volume adjustment which will be more - efficient than a lerp with an alpha value of 1. - - To do this, all we need to do is determine how many frames need to have a lerp applied. Then we - just process that number of frames with linear interpolation. After that we run on an optimized - path which just applies the new gains without a lerp. - */ - if (pGainer->t >= pGainer->config.smoothTimeInFrames) { - interpolatedFrameCount = 0; - } else { - interpolatedFrameCount = pGainer->t - pGainer->config.smoothTimeInFrames; - if (interpolatedFrameCount > frameCount) { - interpolatedFrameCount = frameCount; - } - } - - /* - Start off with our interpolated frames. When we do this, we'll adjust frameCount and our pointers - so that the fast path can work naturally without consideration of the interpolated path. - */ - if (interpolatedFrameCount > 0) { - /* We can allow the input and output buffers to be null in which case we'll just update the internal timer. */ - if (pFramesOut != NULL && pFramesIn != NULL) { - /* - All we're really doing here is moving the old gains towards the new gains. We don't want to - be modifying the gains inside the ma_gainer object because that will break things. Instead - we can make a copy here on the stack. For extreme channel counts we can fall back to a slower - implementation which just uses a standard lerp. - */ - float* pFramesOutF32 = (float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - float a = (float)pGainer->t / pGainer->config.smoothTimeInFrames; - float d = 1.0f / pGainer->config.smoothTimeInFrames; - - if (pGainer->config.channels <= 32) { - float pRunningGain[32]; - float pRunningGainDelta[32]; /* Could this be heap-allocated as part of the ma_gainer object? */ - - /* Initialize the running gain. */ - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - float t = (pGainer->pOldGains[iChannel] - pGainer->pNewGains[iChannel]) * pGainer->masterVolume; - pRunningGainDelta[iChannel] = t * d; - pRunningGain[iChannel] = (pGainer->pOldGains[iChannel] * pGainer->masterVolume) + (t * a); - } - - iFrame = 0; - - /* Optimized paths for common channel counts. This is mostly just experimenting with some SIMD ideas. It's not necessarily final. */ - if (pGainer->config.channels == 2) { - #if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - ma_uint64 unrolledLoopCount = interpolatedFrameCount >> 1; - - /* Expand some arrays so we can have a clean SIMD loop below. */ - __m128 runningGainDelta0 = _mm_set_ps(pRunningGainDelta[1], pRunningGainDelta[0], pRunningGainDelta[1], pRunningGainDelta[0]); - __m128 runningGain0 = _mm_set_ps(pRunningGain[1] + pRunningGainDelta[1], pRunningGain[0] + pRunningGainDelta[0], pRunningGain[1], pRunningGain[0]); - - for (; iFrame < unrolledLoopCount; iFrame += 1) { - _mm_storeu_ps(&pFramesOutF32[iFrame*4 + 0], _mm_mul_ps(_mm_loadu_ps(&pFramesInF32[iFrame*4 + 0]), runningGain0)); - runningGain0 = _mm_add_ps(runningGain0, runningGainDelta0); - } - - iFrame = unrolledLoopCount << 1; - } else - #endif - { - /* - Two different scalar implementations here. Clang (and I assume GCC) will vectorize - both of these, but the bottom version results in a nicer vectorization with less - instructions emitted. The problem, however, is that the bottom version runs slower - when compiled with MSVC. The top version will be partially vectorized by MSVC. - */ - #if defined(_MSC_VER) && !defined(__clang__) - ma_uint64 unrolledLoopCount = interpolatedFrameCount >> 1; - - /* Expand some arrays so we can have a clean 4x SIMD operation in the loop. */ - pRunningGainDelta[2] = pRunningGainDelta[0]; - pRunningGainDelta[3] = pRunningGainDelta[1]; - pRunningGain[2] = pRunningGain[0] + pRunningGainDelta[0]; - pRunningGain[3] = pRunningGain[1] + pRunningGainDelta[1]; - - for (; iFrame < unrolledLoopCount; iFrame += 1) { - pFramesOutF32[iFrame*4 + 0] = pFramesInF32[iFrame*4 + 0] * pRunningGain[0]; - pFramesOutF32[iFrame*4 + 1] = pFramesInF32[iFrame*4 + 1] * pRunningGain[1]; - pFramesOutF32[iFrame*4 + 2] = pFramesInF32[iFrame*4 + 2] * pRunningGain[2]; - pFramesOutF32[iFrame*4 + 3] = pFramesInF32[iFrame*4 + 3] * pRunningGain[3]; - - /* Move the running gain forward towards the new gain. */ - pRunningGain[0] += pRunningGainDelta[0]; - pRunningGain[1] += pRunningGainDelta[1]; - pRunningGain[2] += pRunningGainDelta[2]; - pRunningGain[3] += pRunningGainDelta[3]; - } - - iFrame = unrolledLoopCount << 1; - #else - for (; iFrame < interpolatedFrameCount; iFrame += 1) { - for (iChannel = 0; iChannel < 2; iChannel += 1) { - pFramesOutF32[iFrame*2 + iChannel] = pFramesInF32[iFrame*2 + iChannel] * pRunningGain[iChannel]; - } - - for (iChannel = 0; iChannel < 2; iChannel += 1) { - pRunningGain[iChannel] += pRunningGainDelta[iChannel]; - } - } - #endif - } - } else if (pGainer->config.channels == 6) { - #if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - /* - For 6 channels things are a bit more complicated because 6 isn't cleanly divisible by 4. We need to do 2 frames - at a time, meaning we'll be doing 12 samples in a group. Like the stereo case we'll need to expand some arrays - so we can do clean 4x SIMD operations. - */ - ma_uint64 unrolledLoopCount = interpolatedFrameCount >> 1; - - /* Expand some arrays so we can have a clean SIMD loop below. */ - __m128 runningGainDelta0 = _mm_set_ps(pRunningGainDelta[3], pRunningGainDelta[2], pRunningGainDelta[1], pRunningGainDelta[0]); - __m128 runningGainDelta1 = _mm_set_ps(pRunningGainDelta[1], pRunningGainDelta[0], pRunningGainDelta[5], pRunningGainDelta[4]); - __m128 runningGainDelta2 = _mm_set_ps(pRunningGainDelta[5], pRunningGainDelta[4], pRunningGainDelta[3], pRunningGainDelta[2]); - - __m128 runningGain0 = _mm_set_ps(pRunningGain[3], pRunningGain[2], pRunningGain[1], pRunningGain[0]); - __m128 runningGain1 = _mm_set_ps(pRunningGain[1] + pRunningGainDelta[1], pRunningGain[0] + pRunningGainDelta[0], pRunningGain[5], pRunningGain[4]); - __m128 runningGain2 = _mm_set_ps(pRunningGain[5] + pRunningGainDelta[5], pRunningGain[4] + pRunningGainDelta[4], pRunningGain[3] + pRunningGainDelta[3], pRunningGain[2] + pRunningGainDelta[2]); - - for (; iFrame < unrolledLoopCount; iFrame += 1) { - _mm_storeu_ps(&pFramesOutF32[iFrame*12 + 0], _mm_mul_ps(_mm_loadu_ps(&pFramesInF32[iFrame*12 + 0]), runningGain0)); - _mm_storeu_ps(&pFramesOutF32[iFrame*12 + 4], _mm_mul_ps(_mm_loadu_ps(&pFramesInF32[iFrame*12 + 4]), runningGain1)); - _mm_storeu_ps(&pFramesOutF32[iFrame*12 + 8], _mm_mul_ps(_mm_loadu_ps(&pFramesInF32[iFrame*12 + 8]), runningGain2)); - - runningGain0 = _mm_add_ps(runningGain0, runningGainDelta0); - runningGain1 = _mm_add_ps(runningGain1, runningGainDelta1); - runningGain2 = _mm_add_ps(runningGain2, runningGainDelta2); - } - - iFrame = unrolledLoopCount << 1; - } else - #endif - { - for (; iFrame < interpolatedFrameCount; iFrame += 1) { - for (iChannel = 0; iChannel < 6; iChannel += 1) { - pFramesOutF32[iFrame*6 + iChannel] = pFramesInF32[iFrame*6 + iChannel] * pRunningGain[iChannel]; - } - - /* Move the running gain forward towards the new gain. */ - for (iChannel = 0; iChannel < 6; iChannel += 1) { - pRunningGain[iChannel] += pRunningGainDelta[iChannel]; - } - } - } - } else if (pGainer->config.channels == 8) { - /* For 8 channels we can just go over frame by frame and do all eight channels as 2 separate 4x SIMD operations. */ - #if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - __m128 runningGainDelta0 = _mm_loadu_ps(&pRunningGainDelta[0]); - __m128 runningGainDelta1 = _mm_loadu_ps(&pRunningGainDelta[4]); - __m128 runningGain0 = _mm_loadu_ps(&pRunningGain[0]); - __m128 runningGain1 = _mm_loadu_ps(&pRunningGain[4]); - - for (; iFrame < interpolatedFrameCount; iFrame += 1) { - _mm_storeu_ps(&pFramesOutF32[iFrame*8 + 0], _mm_mul_ps(_mm_loadu_ps(&pFramesInF32[iFrame*8 + 0]), runningGain0)); - _mm_storeu_ps(&pFramesOutF32[iFrame*8 + 4], _mm_mul_ps(_mm_loadu_ps(&pFramesInF32[iFrame*8 + 4]), runningGain1)); - - runningGain0 = _mm_add_ps(runningGain0, runningGainDelta0); - runningGain1 = _mm_add_ps(runningGain1, runningGainDelta1); - } - } else - #endif - { - /* This is crafted so that it auto-vectorizes when compiled with Clang. */ - for (; iFrame < interpolatedFrameCount; iFrame += 1) { - for (iChannel = 0; iChannel < 8; iChannel += 1) { - pFramesOutF32[iFrame*8 + iChannel] = pFramesInF32[iFrame*8 + iChannel] * pRunningGain[iChannel]; - } - - /* Move the running gain forward towards the new gain. */ - for (iChannel = 0; iChannel < 8; iChannel += 1) { - pRunningGain[iChannel] += pRunningGainDelta[iChannel]; - } - } - } - } - - for (; iFrame < interpolatedFrameCount; iFrame += 1) { - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pGainer->config.channels + iChannel] = pFramesInF32[iFrame*pGainer->config.channels + iChannel] * pRunningGain[iChannel]; - pRunningGain[iChannel] += pRunningGainDelta[iChannel]; - } - } - } else { - /* Slower path for extreme channel counts where we can't fit enough on the stack. We could also move this to the heap as part of the ma_gainer object which might even be better since it'll only be updated when the gains actually change. */ - for (iFrame = 0; iFrame < interpolatedFrameCount; iFrame += 1) { - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pGainer->config.channels + iChannel] = pFramesInF32[iFrame*pGainer->config.channels + iChannel] * ma_mix_f32_fast(pGainer->pOldGains[iChannel], pGainer->pNewGains[iChannel], a) * pGainer->masterVolume; - } - - a += d; - } - } - } - - /* Make sure the timer is updated. */ - pGainer->t = (ma_uint32)ma_min(pGainer->t + interpolatedFrameCount, pGainer->config.smoothTimeInFrames); - - /* Adjust our arguments so the next part can work normally. */ - frameCount -= interpolatedFrameCount; - pFramesOut = ma_offset_ptr(pFramesOut, interpolatedFrameCount * sizeof(float)); - pFramesIn = ma_offset_ptr(pFramesIn, interpolatedFrameCount * sizeof(float)); - } - - /* All we need to do here is apply the new gains using an optimized path. */ - if (pFramesOut != NULL && pFramesIn != NULL) { - if (pGainer->config.channels <= 32) { - float gains[32]; - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - gains[iChannel] = pGainer->pNewGains[iChannel] * pGainer->masterVolume; - } - - ma_copy_and_apply_volume_factor_per_channel_f32((float*)pFramesOut, (const float*)pFramesIn, frameCount, pGainer->config.channels, gains); - } else { - /* Slow path. Too many channels to fit on the stack. Need to apply a master volume as a separate path. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - ((float*)pFramesOut)[iFrame*pGainer->config.channels + iChannel] = ((const float*)pFramesIn)[iFrame*pGainer->config.channels + iChannel] * pGainer->pNewGains[iChannel] * pGainer->masterVolume; - } - } - } - } - - /* Now that some frames have been processed we need to make sure future changes to the gain are interpolated. */ - if (pGainer->t == (ma_uint32)-1) { - pGainer->t = (ma_uint32)ma_min(pGainer->config.smoothTimeInFrames, frameCount); - } - -#if 0 - if (pGainer->t >= pGainer->config.smoothTimeInFrames) { - /* Fast path. No gain calculation required. */ - ma_copy_and_apply_volume_factor_per_channel_f32(pFramesOutF32, pFramesInF32, frameCount, pGainer->config.channels, pGainer->pNewGains); - ma_apply_volume_factor_f32(pFramesOutF32, frameCount * pGainer->config.channels, pGainer->masterVolume); - - /* Now that some frames have been processed we need to make sure future changes to the gain are interpolated. */ - if (pGainer->t == (ma_uint32)-1) { - pGainer->t = pGainer->config.smoothTimeInFrames; - } - } else { - /* Slow path. Need to interpolate the gain for each channel individually. */ - - /* We can allow the input and output buffers to be null in which case we'll just update the internal timer. */ - if (pFramesOut != NULL && pFramesIn != NULL) { - float a = (float)pGainer->t / pGainer->config.smoothTimeInFrames; - float d = 1.0f / pGainer->config.smoothTimeInFrames; - ma_uint32 channelCount = pGainer->config.channels; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channelCount; iChannel += 1) { - pFramesOutF32[iChannel] = pFramesInF32[iChannel] * ma_mix_f32_fast(pGainer->pOldGains[iChannel], pGainer->pNewGains[iChannel], a) * pGainer->masterVolume; - } - - pFramesOutF32 += channelCount; - pFramesInF32 += channelCount; - - a += d; - if (a > 1) { - a = 1; - } - } - } - - pGainer->t = (ma_uint32)ma_min(pGainer->t + frameCount, pGainer->config.smoothTimeInFrames); - - #if 0 /* Reference implementation. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - /* We can allow the input and output buffers to be null in which case we'll just update the internal timer. */ - if (pFramesOut != NULL && pFramesIn != NULL) { - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - pFramesOutF32[iFrame * pGainer->config.channels + iChannel] = pFramesInF32[iFrame * pGainer->config.channels + iChannel] * ma_gainer_calculate_current_gain(pGainer, iChannel) * pGainer->masterVolume; - } - } - - /* Move interpolation time forward, but don't go beyond our smoothing time. */ - pGainer->t = ma_min(pGainer->t + 1, pGainer->config.smoothTimeInFrames); - } - #endif - } -#endif - - return MA_SUCCESS; -} - -MA_API ma_result ma_gainer_process_pcm_frames(ma_gainer* pGainer, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pGainer == NULL) { - return MA_INVALID_ARGS; - } - - /* - ma_gainer_process_pcm_frames_internal() marks pFramesOut and pFramesIn with MA_RESTRICT which - helps with auto-vectorization. - */ - return ma_gainer_process_pcm_frames_internal(pGainer, pFramesOut, pFramesIn, frameCount); -} - -static void ma_gainer_set_gain_by_index(ma_gainer* pGainer, float newGain, ma_uint32 iChannel) -{ - pGainer->pOldGains[iChannel] = ma_gainer_calculate_current_gain(pGainer, iChannel); - pGainer->pNewGains[iChannel] = newGain; -} - -static void ma_gainer_reset_smoothing_time(ma_gainer* pGainer) -{ - if (pGainer->t == (ma_uint32)-1) { - pGainer->t = pGainer->config.smoothTimeInFrames; /* No smoothing required for initial gains setting. */ - } else { - pGainer->t = 0; - } -} - -MA_API ma_result ma_gainer_set_gain(ma_gainer* pGainer, float newGain) -{ - ma_uint32 iChannel; - - if (pGainer == NULL) { - return MA_INVALID_ARGS; - } - - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - ma_gainer_set_gain_by_index(pGainer, newGain, iChannel); - } - - /* The smoothing time needs to be reset to ensure we always interpolate by the configured smoothing time, but only if it's not the first setting. */ - ma_gainer_reset_smoothing_time(pGainer); - - return MA_SUCCESS; -} - -MA_API ma_result ma_gainer_set_gains(ma_gainer* pGainer, float* pNewGains) -{ - ma_uint32 iChannel; - - if (pGainer == NULL || pNewGains == NULL) { - return MA_INVALID_ARGS; - } - - for (iChannel = 0; iChannel < pGainer->config.channels; iChannel += 1) { - ma_gainer_set_gain_by_index(pGainer, pNewGains[iChannel], iChannel); - } - - /* The smoothing time needs to be reset to ensure we always interpolate by the configured smoothing time, but only if it's not the first setting. */ - ma_gainer_reset_smoothing_time(pGainer); - - return MA_SUCCESS; -} - -MA_API ma_result ma_gainer_set_master_volume(ma_gainer* pGainer, float volume) -{ - if (pGainer == NULL) { - return MA_INVALID_ARGS; - } - - pGainer->masterVolume = volume; - - return MA_SUCCESS; -} - -MA_API ma_result ma_gainer_get_master_volume(const ma_gainer* pGainer, float* pVolume) -{ - if (pGainer == NULL || pVolume == NULL) { - return MA_INVALID_ARGS; - } - - *pVolume = pGainer->masterVolume; - - return MA_SUCCESS; -} - - -MA_API ma_panner_config ma_panner_config_init(ma_format format, ma_uint32 channels) -{ - ma_panner_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.mode = ma_pan_mode_balance; /* Set to balancing mode by default because it's consistent with other audio engines and most likely what the caller is expecting. */ - config.pan = 0; - - return config; -} - - -MA_API ma_result ma_panner_init(const ma_panner_config* pConfig, ma_panner* pPanner) -{ - if (pPanner == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pPanner); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - pPanner->format = pConfig->format; - pPanner->channels = pConfig->channels; - pPanner->mode = pConfig->mode; - pPanner->pan = pConfig->pan; - - return MA_SUCCESS; -} - -static void ma_stereo_balance_pcm_frames_f32(float* pFramesOut, const float* pFramesIn, ma_uint64 frameCount, float pan) -{ - ma_uint64 iFrame; - - if (pan > 0) { - float factor = 1.0f - pan; - if (pFramesOut == pFramesIn) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - pFramesOut[iFrame*2 + 0] = pFramesIn[iFrame*2 + 0] * factor; - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - pFramesOut[iFrame*2 + 0] = pFramesIn[iFrame*2 + 0] * factor; - pFramesOut[iFrame*2 + 1] = pFramesIn[iFrame*2 + 1]; - } - } - } else { - float factor = 1.0f + pan; - if (pFramesOut == pFramesIn) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - pFramesOut[iFrame*2 + 1] = pFramesIn[iFrame*2 + 1] * factor; - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - pFramesOut[iFrame*2 + 0] = pFramesIn[iFrame*2 + 0]; - pFramesOut[iFrame*2 + 1] = pFramesIn[iFrame*2 + 1] * factor; - } - } - } -} - -static void ma_stereo_balance_pcm_frames(void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount, ma_format format, float pan) -{ - if (pan == 0) { - /* Fast path. No panning required. */ - if (pFramesOut == pFramesIn) { - /* No-op */ - } else { - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, format, 2); - } - - return; - } - - switch (format) { - case ma_format_f32: ma_stereo_balance_pcm_frames_f32((float*)pFramesOut, (float*)pFramesIn, frameCount, pan); break; - - /* Unknown format. Just copy. */ - default: - { - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, format, 2); - } break; - } -} - - -static void ma_stereo_pan_pcm_frames_f32(float* pFramesOut, const float* pFramesIn, ma_uint64 frameCount, float pan) -{ - ma_uint64 iFrame; - - if (pan > 0) { - float factorL0 = 1.0f - pan; - float factorL1 = 0.0f + pan; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float sample0 = (pFramesIn[iFrame*2 + 0] * factorL0); - float sample1 = (pFramesIn[iFrame*2 + 0] * factorL1) + pFramesIn[iFrame*2 + 1]; - - pFramesOut[iFrame*2 + 0] = sample0; - pFramesOut[iFrame*2 + 1] = sample1; - } - } else { - float factorR0 = 0.0f - pan; - float factorR1 = 1.0f + pan; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float sample0 = pFramesIn[iFrame*2 + 0] + (pFramesIn[iFrame*2 + 1] * factorR0); - float sample1 = (pFramesIn[iFrame*2 + 1] * factorR1); - - pFramesOut[iFrame*2 + 0] = sample0; - pFramesOut[iFrame*2 + 1] = sample1; - } - } -} - -static void ma_stereo_pan_pcm_frames(void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount, ma_format format, float pan) -{ - if (pan == 0) { - /* Fast path. No panning required. */ - if (pFramesOut == pFramesIn) { - /* No-op */ - } else { - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, format, 2); - } - - return; - } - - switch (format) { - case ma_format_f32: ma_stereo_pan_pcm_frames_f32((float*)pFramesOut, (float*)pFramesIn, frameCount, pan); break; - - /* Unknown format. Just copy. */ - default: - { - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, format, 2); - } break; - } -} - -MA_API ma_result ma_panner_process_pcm_frames(ma_panner* pPanner, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pPanner == NULL || pFramesOut == NULL || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - if (pPanner->channels == 2) { - /* Stereo case. For now assume channel 0 is left and channel right is 1, but should probably add support for a channel map. */ - if (pPanner->mode == ma_pan_mode_balance) { - ma_stereo_balance_pcm_frames(pFramesOut, pFramesIn, frameCount, pPanner->format, pPanner->pan); - } else { - ma_stereo_pan_pcm_frames(pFramesOut, pFramesIn, frameCount, pPanner->format, pPanner->pan); - } - } else { - if (pPanner->channels == 1) { - /* Panning has no effect on mono streams. */ - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, pPanner->format, pPanner->channels); - } else { - /* For now we're not going to support non-stereo set ups. Not sure how I want to handle this case just yet. */ - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, pPanner->format, pPanner->channels); - } - } - - return MA_SUCCESS; -} - -MA_API void ma_panner_set_mode(ma_panner* pPanner, ma_pan_mode mode) -{ - if (pPanner == NULL) { - return; - } - - pPanner->mode = mode; -} - -MA_API ma_pan_mode ma_panner_get_mode(const ma_panner* pPanner) -{ - if (pPanner == NULL) { - return ma_pan_mode_balance; - } - - return pPanner->mode; -} - -MA_API void ma_panner_set_pan(ma_panner* pPanner, float pan) -{ - if (pPanner == NULL) { - return; - } - - pPanner->pan = ma_clamp(pan, -1.0f, 1.0f); -} - -MA_API float ma_panner_get_pan(const ma_panner* pPanner) -{ - if (pPanner == NULL) { - return 0; - } - - return pPanner->pan; -} - - - - -MA_API ma_fader_config ma_fader_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate) -{ - ma_fader_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - - return config; -} - - -MA_API ma_result ma_fader_init(const ma_fader_config* pConfig, ma_fader* pFader) -{ - if (pFader == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFader); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* Only f32 is supported for now. */ - if (pConfig->format != ma_format_f32) { - return MA_INVALID_ARGS; - } - - pFader->config = *pConfig; - pFader->volumeBeg = 1; - pFader->volumeEnd = 1; - pFader->lengthInFrames = 0; - pFader->cursorInFrames = 0; - - return MA_SUCCESS; -} - -MA_API ma_result ma_fader_process_pcm_frames(ma_fader* pFader, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pFader == NULL) { - return MA_INVALID_ARGS; - } - - /* - For now we need to clamp frameCount so that the cursor never overflows 32-bits. This is required for - the conversion to a float which we use for the linear interpolation. This might be changed later. - */ - if (frameCount + pFader->cursorInFrames > UINT_MAX) { - frameCount = UINT_MAX - pFader->cursorInFrames; - } - - /* Optimized path if volumeBeg and volumeEnd are equal. */ - if (pFader->volumeBeg == pFader->volumeEnd) { - if (pFader->volumeBeg == 1) { - /* Straight copy. */ - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, pFader->config.format, pFader->config.channels); - } else { - /* Copy with volume. */ - ma_copy_and_apply_volume_and_clip_pcm_frames(pFramesOut, pFramesIn, frameCount, pFader->config.format, pFader->config.channels, pFader->volumeEnd); - } - } else { - /* Slower path. Volumes are different, so may need to do an interpolation. */ - if (pFader->cursorInFrames >= pFader->lengthInFrames) { - /* Fast path. We've gone past the end of the fade period so just apply the end volume to all samples. */ - ma_copy_and_apply_volume_and_clip_pcm_frames(pFramesOut, pFramesIn, frameCount, pFader->config.format, pFader->config.channels, pFader->volumeEnd); - } else { - /* Slow path. This is where we do the actual fading. */ - ma_uint64 iFrame; - ma_uint32 iChannel; - - /* For now we only support f32. Support for other formats will be added later. */ - if (pFader->config.format == ma_format_f32) { - const float* pFramesInF32 = (const float*)pFramesIn; - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float a = (ma_uint32)ma_min(pFader->cursorInFrames + iFrame, pFader->lengthInFrames) / (float)((ma_uint32)pFader->lengthInFrames); /* Safe cast due to the frameCount clamp at the top of this function. */ - float volume = ma_mix_f32_fast(pFader->volumeBeg, pFader->volumeEnd, a); - - for (iChannel = 0; iChannel < pFader->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pFader->config.channels + iChannel] = pFramesInF32[iFrame*pFader->config.channels + iChannel] * volume; - } - } - } else { - return MA_NOT_IMPLEMENTED; - } - } - } - - pFader->cursorInFrames += frameCount; - - return MA_SUCCESS; -} - -MA_API void ma_fader_get_data_format(const ma_fader* pFader, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate) -{ - if (pFader == NULL) { - return; - } - - if (pFormat != NULL) { - *pFormat = pFader->config.format; - } - - if (pChannels != NULL) { - *pChannels = pFader->config.channels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pFader->config.sampleRate; - } -} - -MA_API void ma_fader_set_fade(ma_fader* pFader, float volumeBeg, float volumeEnd, ma_uint64 lengthInFrames) -{ - if (pFader == NULL) { - return; - } - - /* If the volume is negative, use current volume. */ - if (volumeBeg < 0) { - volumeBeg = ma_fader_get_current_volume(pFader); - } - - /* - The length needs to be clamped to 32-bits due to how we convert it to a float for linear - interpolation reasons. I might change this requirement later, but for now it's not important. - */ - if (lengthInFrames > UINT_MAX) { - lengthInFrames = UINT_MAX; - } - - pFader->volumeBeg = volumeBeg; - pFader->volumeEnd = volumeEnd; - pFader->lengthInFrames = lengthInFrames; - pFader->cursorInFrames = 0; /* Reset cursor. */ -} - -MA_API float ma_fader_get_current_volume(const ma_fader* pFader) -{ - if (pFader == NULL) { - return 0.0f; - } - - /* The current volume depends on the position of the cursor. */ - if (pFader->cursorInFrames == 0) { - return pFader->volumeBeg; - } else if (pFader->cursorInFrames >= pFader->lengthInFrames) { - return pFader->volumeEnd; - } else { - /* The cursor is somewhere inside the fading period. We can figure this out with a simple linear interpoluation between volumeBeg and volumeEnd based on our cursor position. */ - return ma_mix_f32_fast(pFader->volumeBeg, pFader->volumeEnd, (ma_uint32)pFader->cursorInFrames / (float)((ma_uint32)pFader->lengthInFrames)); /* Safe cast to uint32 because we clamp it in ma_fader_process_pcm_frames(). */ - } -} - - - - - -MA_API ma_vec3f ma_vec3f_init_3f(float x, float y, float z) -{ - ma_vec3f v; - - v.x = x; - v.y = y; - v.z = z; - - return v; -} - -MA_API ma_vec3f ma_vec3f_sub(ma_vec3f a, ma_vec3f b) -{ - return ma_vec3f_init_3f( - a.x - b.x, - a.y - b.y, - a.z - b.z - ); -} - -MA_API ma_vec3f ma_vec3f_neg(ma_vec3f a) -{ - return ma_vec3f_init_3f( - -a.x, - -a.y, - -a.z - ); -} - -MA_API float ma_vec3f_dot(ma_vec3f a, ma_vec3f b) -{ - return a.x*b.x + a.y*b.y + a.z*b.z; -} - -MA_API float ma_vec3f_len2(ma_vec3f v) -{ - return ma_vec3f_dot(v, v); -} - -MA_API float ma_vec3f_len(ma_vec3f v) -{ - return (float)ma_sqrtd(ma_vec3f_len2(v)); -} - - - -MA_API float ma_vec3f_dist(ma_vec3f a, ma_vec3f b) -{ - return ma_vec3f_len(ma_vec3f_sub(a, b)); -} - -MA_API ma_vec3f ma_vec3f_normalize(ma_vec3f v) -{ - float invLen; - float len2 = ma_vec3f_len2(v); - if (len2 == 0) { - return ma_vec3f_init_3f(0, 0, 0); - } - - invLen = ma_rsqrtf(len2); - v.x *= invLen; - v.y *= invLen; - v.z *= invLen; - - return v; -} - -MA_API ma_vec3f ma_vec3f_cross(ma_vec3f a, ma_vec3f b) -{ - return ma_vec3f_init_3f( - a.y*b.z - a.z*b.y, - a.z*b.x - a.x*b.z, - a.x*b.y - a.y*b.x - ); -} - - -MA_API void ma_atomic_vec3f_init(ma_atomic_vec3f* v, ma_vec3f value) -{ - v->v = value; - v->lock = 0; /* Important this is initialized to 0. */ -} - -MA_API void ma_atomic_vec3f_set(ma_atomic_vec3f* v, ma_vec3f value) -{ - ma_spinlock_lock(&v->lock); - { - v->v = value; - } - ma_spinlock_unlock(&v->lock); -} - -MA_API ma_vec3f ma_atomic_vec3f_get(ma_atomic_vec3f* v) -{ - ma_vec3f r; - - ma_spinlock_lock(&v->lock); - { - r = v->v; - } - ma_spinlock_unlock(&v->lock); - - return r; -} - - - -static void ma_channel_map_apply_f32(float* pFramesOut, const ma_channel* pChannelMapOut, ma_uint32 channelsOut, const float* pFramesIn, const ma_channel* pChannelMapIn, ma_uint32 channelsIn, ma_uint64 frameCount, ma_channel_mix_mode mode, ma_mono_expansion_mode monoExpansionMode); -static ma_bool32 ma_is_spatial_channel_position(ma_channel channelPosition); - - -#ifndef MA_DEFAULT_SPEED_OF_SOUND -#define MA_DEFAULT_SPEED_OF_SOUND 343.3f -#endif - -/* -These vectors represent the direction that speakers are facing from the center point. They're used -for panning in the spatializer. Must be normalized. -*/ -static ma_vec3f g_maChannelDirections[MA_CHANNEL_POSITION_COUNT] = { - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_NONE */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_MONO */ - {-0.7071f, 0.0f, -0.7071f }, /* MA_CHANNEL_FRONT_LEFT */ - {+0.7071f, 0.0f, -0.7071f }, /* MA_CHANNEL_FRONT_RIGHT */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_FRONT_CENTER */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_LFE */ - {-0.7071f, 0.0f, +0.7071f }, /* MA_CHANNEL_BACK_LEFT */ - {+0.7071f, 0.0f, +0.7071f }, /* MA_CHANNEL_BACK_RIGHT */ - {-0.3162f, 0.0f, -0.9487f }, /* MA_CHANNEL_FRONT_LEFT_CENTER */ - {+0.3162f, 0.0f, -0.9487f }, /* MA_CHANNEL_FRONT_RIGHT_CENTER */ - { 0.0f, 0.0f, +1.0f }, /* MA_CHANNEL_BACK_CENTER */ - {-1.0f, 0.0f, 0.0f }, /* MA_CHANNEL_SIDE_LEFT */ - {+1.0f, 0.0f, 0.0f }, /* MA_CHANNEL_SIDE_RIGHT */ - { 0.0f, +1.0f, 0.0f }, /* MA_CHANNEL_TOP_CENTER */ - {-0.5774f, +0.5774f, -0.5774f }, /* MA_CHANNEL_TOP_FRONT_LEFT */ - { 0.0f, +0.7071f, -0.7071f }, /* MA_CHANNEL_TOP_FRONT_CENTER */ - {+0.5774f, +0.5774f, -0.5774f }, /* MA_CHANNEL_TOP_FRONT_RIGHT */ - {-0.5774f, +0.5774f, +0.5774f }, /* MA_CHANNEL_TOP_BACK_LEFT */ - { 0.0f, +0.7071f, +0.7071f }, /* MA_CHANNEL_TOP_BACK_CENTER */ - {+0.5774f, +0.5774f, +0.5774f }, /* MA_CHANNEL_TOP_BACK_RIGHT */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_0 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_1 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_2 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_3 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_4 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_5 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_6 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_7 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_8 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_9 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_10 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_11 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_12 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_13 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_14 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_15 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_16 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_17 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_18 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_19 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_20 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_21 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_22 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_23 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_24 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_25 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_26 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_27 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_28 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_29 */ - { 0.0f, 0.0f, -1.0f }, /* MA_CHANNEL_AUX_30 */ - { 0.0f, 0.0f, -1.0f } /* MA_CHANNEL_AUX_31 */ -}; - -static ma_vec3f ma_get_channel_direction(ma_channel channel) -{ - if (channel >= MA_CHANNEL_POSITION_COUNT) { - return ma_vec3f_init_3f(0, 0, -1); - } else { - return g_maChannelDirections[channel]; - } -} - - - -static float ma_attenuation_inverse(float distance, float minDistance, float maxDistance, float rolloff) -{ - if (minDistance >= maxDistance) { - return 1; /* To avoid division by zero. Do not attenuate. */ - } - - return minDistance / (minDistance + rolloff * (ma_clamp(distance, minDistance, maxDistance) - minDistance)); -} - -static float ma_attenuation_linear(float distance, float minDistance, float maxDistance, float rolloff) -{ - if (minDistance >= maxDistance) { - return 1; /* To avoid division by zero. Do not attenuate. */ - } - - return 1 - rolloff * (ma_clamp(distance, minDistance, maxDistance) - minDistance) / (maxDistance - minDistance); -} - -static float ma_attenuation_exponential(float distance, float minDistance, float maxDistance, float rolloff) -{ - if (minDistance >= maxDistance) { - return 1; /* To avoid division by zero. Do not attenuate. */ - } - - return (float)ma_powd(ma_clamp(distance, minDistance, maxDistance) / minDistance, -rolloff); -} - - -/* -Dopper Effect calculation taken from the OpenAL spec, with two main differences: - - 1) The source to listener vector will have already been calcualted at an earlier step so we can - just use that directly. We need only the position of the source relative to the origin. - - 2) We don't scale by a frequency because we actually just want the ratio which we'll plug straight - into the resampler directly. -*/ -static float ma_doppler_pitch(ma_vec3f relativePosition, ma_vec3f sourceVelocity, ma_vec3f listenVelocity, float speedOfSound, float dopplerFactor) -{ - float len; - float vls; - float vss; - - len = ma_vec3f_len(relativePosition); - - /* - There's a case where the position of the source will be right on top of the listener in which - case the length will be 0 and we'll end up with a division by zero. We can just return a ratio - of 1.0 in this case. This is not considered in the OpenAL spec, but is necessary. - */ - if (len == 0) { - return 1.0; - } - - vls = ma_vec3f_dot(relativePosition, listenVelocity) / len; - vss = ma_vec3f_dot(relativePosition, sourceVelocity) / len; - - vls = ma_min(vls, speedOfSound / dopplerFactor); - vss = ma_min(vss, speedOfSound / dopplerFactor); - - return (speedOfSound - dopplerFactor*vls) / (speedOfSound - dopplerFactor*vss); -} - - -static void ma_get_default_channel_map_for_spatializer(ma_channel* pChannelMap, size_t channelMapCap, ma_uint32 channelCount) -{ - /* - Special case for stereo. Want to default the left and right speakers to side left and side - right so that they're facing directly down the X axis rather than slightly forward. Not - doing this will result in sounds being quieter when behind the listener. This might - actually be good for some scenerios, but I don't think it's an appropriate default because - it can be a bit unexpected. - */ - if (channelCount == 2) { - pChannelMap[0] = MA_CHANNEL_SIDE_LEFT; - pChannelMap[1] = MA_CHANNEL_SIDE_RIGHT; - } else { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, channelCount); - } -} - - -MA_API ma_spatializer_listener_config ma_spatializer_listener_config_init(ma_uint32 channelsOut) -{ - ma_spatializer_listener_config config; - - MA_ZERO_OBJECT(&config); - config.channelsOut = channelsOut; - config.pChannelMapOut = NULL; - config.handedness = ma_handedness_right; - config.worldUp = ma_vec3f_init_3f(0, 1, 0); - config.coneInnerAngleInRadians = 6.283185f; /* 360 degrees. */ - config.coneOuterAngleInRadians = 6.283185f; /* 360 degrees. */ - config.coneOuterGain = 0; - config.speedOfSound = 343.3f; /* Same as OpenAL. Used for doppler effect. */ - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t channelMapOutOffset; -} ma_spatializer_listener_heap_layout; - -static ma_result ma_spatializer_listener_get_heap_layout(const ma_spatializer_listener_config* pConfig, ma_spatializer_listener_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channelsOut == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Channel map. We always need this, even for passthroughs. */ - pHeapLayout->channelMapOutOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(sizeof(*pConfig->pChannelMapOut) * pConfig->channelsOut); - - return MA_SUCCESS; -} - - -MA_API ma_result ma_spatializer_listener_get_heap_size(const ma_spatializer_listener_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_spatializer_listener_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_spatializer_listener_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_spatializer_listener_init_preallocated(const ma_spatializer_listener_config* pConfig, void* pHeap, ma_spatializer_listener* pListener) -{ - ma_result result; - ma_spatializer_listener_heap_layout heapLayout; - - if (pListener == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pListener); - - result = ma_spatializer_listener_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pListener->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pListener->config = *pConfig; - ma_atomic_vec3f_init(&pListener->position, ma_vec3f_init_3f(0, 0, 0)); - ma_atomic_vec3f_init(&pListener->direction, ma_vec3f_init_3f(0, 0, -1)); - ma_atomic_vec3f_init(&pListener->velocity, ma_vec3f_init_3f(0, 0, 0)); - pListener->isEnabled = MA_TRUE; - - /* Swap the forward direction if we're left handed (it was initialized based on right handed). */ - if (pListener->config.handedness == ma_handedness_left) { - ma_vec3f negDir = ma_vec3f_neg(ma_spatializer_listener_get_direction(pListener)); - ma_spatializer_listener_set_direction(pListener, negDir.x, negDir.y, negDir.z); - } - - - /* We must always have a valid channel map. */ - pListener->config.pChannelMapOut = (ma_channel*)ma_offset_ptr(pHeap, heapLayout.channelMapOutOffset); - - /* Use a slightly different default channel map for stereo. */ - if (pConfig->pChannelMapOut == NULL) { - ma_get_default_channel_map_for_spatializer(pListener->config.pChannelMapOut, pConfig->channelsOut, pConfig->channelsOut); - } else { - ma_channel_map_copy_or_default(pListener->config.pChannelMapOut, pConfig->channelsOut, pConfig->pChannelMapOut, pConfig->channelsOut); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_spatializer_listener_init(const ma_spatializer_listener_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_spatializer_listener* pListener) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_spatializer_listener_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_spatializer_listener_init_preallocated(pConfig, pHeap, pListener); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pListener->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_spatializer_listener_uninit(ma_spatializer_listener* pListener, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pListener == NULL) { - return; - } - - if (pListener->_ownsHeap) { - ma_free(pListener->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_channel* ma_spatializer_listener_get_channel_map(ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return NULL; - } - - return pListener->config.pChannelMapOut; -} - -MA_API void ma_spatializer_listener_set_cone(ma_spatializer_listener* pListener, float innerAngleInRadians, float outerAngleInRadians, float outerGain) -{ - if (pListener == NULL) { - return; - } - - pListener->config.coneInnerAngleInRadians = innerAngleInRadians; - pListener->config.coneOuterAngleInRadians = outerAngleInRadians; - pListener->config.coneOuterGain = outerGain; -} - -MA_API void ma_spatializer_listener_get_cone(const ma_spatializer_listener* pListener, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain) -{ - if (pListener == NULL) { - return; - } - - if (pInnerAngleInRadians != NULL) { - *pInnerAngleInRadians = pListener->config.coneInnerAngleInRadians; - } - - if (pOuterAngleInRadians != NULL) { - *pOuterAngleInRadians = pListener->config.coneOuterAngleInRadians; - } - - if (pOuterGain != NULL) { - *pOuterGain = pListener->config.coneOuterGain; - } -} - -MA_API void ma_spatializer_listener_set_position(ma_spatializer_listener* pListener, float x, float y, float z) -{ - if (pListener == NULL) { - return; - } - - ma_atomic_vec3f_set(&pListener->position, ma_vec3f_init_3f(x, y, z)); -} - -MA_API ma_vec3f ma_spatializer_listener_get_position(const ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_atomic_vec3f_get((ma_atomic_vec3f*)&pListener->position); /* Naughty const-cast. It's just for atomically loading the vec3 which should be safe. */ -} - -MA_API void ma_spatializer_listener_set_direction(ma_spatializer_listener* pListener, float x, float y, float z) -{ - if (pListener == NULL) { - return; - } - - ma_atomic_vec3f_set(&pListener->direction, ma_vec3f_init_3f(x, y, z)); -} - -MA_API ma_vec3f ma_spatializer_listener_get_direction(const ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return ma_vec3f_init_3f(0, 0, -1); - } - - return ma_atomic_vec3f_get((ma_atomic_vec3f*)&pListener->direction); /* Naughty const-cast. It's just for atomically loading the vec3 which should be safe. */ -} - -MA_API void ma_spatializer_listener_set_velocity(ma_spatializer_listener* pListener, float x, float y, float z) -{ - if (pListener == NULL) { - return; - } - - ma_atomic_vec3f_set(&pListener->velocity, ma_vec3f_init_3f(x, y, z)); -} - -MA_API ma_vec3f ma_spatializer_listener_get_velocity(const ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_atomic_vec3f_get((ma_atomic_vec3f*)&pListener->velocity); /* Naughty const-cast. It's just for atomically loading the vec3 which should be safe. */ -} - -MA_API void ma_spatializer_listener_set_speed_of_sound(ma_spatializer_listener* pListener, float speedOfSound) -{ - if (pListener == NULL) { - return; - } - - pListener->config.speedOfSound = speedOfSound; -} - -MA_API float ma_spatializer_listener_get_speed_of_sound(const ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return 0; - } - - return pListener->config.speedOfSound; -} - -MA_API void ma_spatializer_listener_set_world_up(ma_spatializer_listener* pListener, float x, float y, float z) -{ - if (pListener == NULL) { - return; - } - - pListener->config.worldUp = ma_vec3f_init_3f(x, y, z); -} - -MA_API ma_vec3f ma_spatializer_listener_get_world_up(const ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return ma_vec3f_init_3f(0, 1, 0); - } - - return pListener->config.worldUp; -} - -MA_API void ma_spatializer_listener_set_enabled(ma_spatializer_listener* pListener, ma_bool32 isEnabled) -{ - if (pListener == NULL) { - return; - } - - pListener->isEnabled = isEnabled; -} - -MA_API ma_bool32 ma_spatializer_listener_is_enabled(const ma_spatializer_listener* pListener) -{ - if (pListener == NULL) { - return MA_FALSE; - } - - return pListener->isEnabled; -} - - - - -MA_API ma_spatializer_config ma_spatializer_config_init(ma_uint32 channelsIn, ma_uint32 channelsOut) -{ - ma_spatializer_config config; - - MA_ZERO_OBJECT(&config); - config.channelsIn = channelsIn; - config.channelsOut = channelsOut; - config.pChannelMapIn = NULL; - config.attenuationModel = ma_attenuation_model_inverse; - config.positioning = ma_positioning_absolute; - config.handedness = ma_handedness_right; - config.minGain = 0; - config.maxGain = 1; - config.minDistance = 1; - config.maxDistance = MA_FLT_MAX; - config.rolloff = 1; - config.coneInnerAngleInRadians = 6.283185f; /* 360 degrees. */ - config.coneOuterAngleInRadians = 6.283185f; /* 360 degress. */ - config.coneOuterGain = 0.0f; - config.dopplerFactor = 1; - config.directionalAttenuationFactor = 1; - config.minSpatializationChannelGain = 0.2f; - config.gainSmoothTimeInFrames = 360; /* 7.5ms @ 48K. */ - - return config; -} - - -static ma_gainer_config ma_spatializer_gainer_config_init(const ma_spatializer_config* pConfig) -{ - MA_ASSERT(pConfig != NULL); - return ma_gainer_config_init(pConfig->channelsOut, pConfig->gainSmoothTimeInFrames); -} - -static ma_result ma_spatializer_validate_config(const ma_spatializer_config* pConfig) -{ - MA_ASSERT(pConfig != NULL); - - if (pConfig->channelsIn == 0 || pConfig->channelsOut == 0) { - return MA_INVALID_ARGS; - } - - return MA_SUCCESS; -} - -typedef struct -{ - size_t sizeInBytes; - size_t channelMapInOffset; - size_t newChannelGainsOffset; - size_t gainerOffset; -} ma_spatializer_heap_layout; - -static ma_result ma_spatializer_get_heap_layout(const ma_spatializer_config* pConfig, ma_spatializer_heap_layout* pHeapLayout) -{ - ma_result result; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_spatializer_validate_config(pConfig); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes = 0; - - /* Channel map. */ - pHeapLayout->channelMapInOffset = MA_SIZE_MAX; /* <-- MA_SIZE_MAX indicates no allocation necessary. */ - if (pConfig->pChannelMapIn != NULL) { - pHeapLayout->channelMapInOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(sizeof(*pConfig->pChannelMapIn) * pConfig->channelsIn); - } - - /* New channel gains for output. */ - pHeapLayout->newChannelGainsOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(sizeof(float) * pConfig->channelsOut); - - /* Gainer. */ - { - size_t gainerHeapSizeInBytes; - ma_gainer_config gainerConfig; - - gainerConfig = ma_spatializer_gainer_config_init(pConfig); - - result = ma_gainer_get_heap_size(&gainerConfig, &gainerHeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->gainerOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(gainerHeapSizeInBytes); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_spatializer_get_heap_size(const ma_spatializer_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_spatializer_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; /* Safety. */ - - result = ma_spatializer_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - - -MA_API ma_result ma_spatializer_init_preallocated(const ma_spatializer_config* pConfig, void* pHeap, ma_spatializer* pSpatializer) -{ - ma_result result; - ma_spatializer_heap_layout heapLayout; - ma_gainer_config gainerConfig; - - if (pSpatializer == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pSpatializer); - - if (pConfig == NULL || pHeap == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_spatializer_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pSpatializer->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pSpatializer->channelsIn = pConfig->channelsIn; - pSpatializer->channelsOut = pConfig->channelsOut; - pSpatializer->attenuationModel = pConfig->attenuationModel; - pSpatializer->positioning = pConfig->positioning; - pSpatializer->handedness = pConfig->handedness; - pSpatializer->minGain = pConfig->minGain; - pSpatializer->maxGain = pConfig->maxGain; - pSpatializer->minDistance = pConfig->minDistance; - pSpatializer->maxDistance = pConfig->maxDistance; - pSpatializer->rolloff = pConfig->rolloff; - pSpatializer->coneInnerAngleInRadians = pConfig->coneInnerAngleInRadians; - pSpatializer->coneOuterAngleInRadians = pConfig->coneOuterAngleInRadians; - pSpatializer->coneOuterGain = pConfig->coneOuterGain; - pSpatializer->dopplerFactor = pConfig->dopplerFactor; - pSpatializer->minSpatializationChannelGain = pConfig->minSpatializationChannelGain; - pSpatializer->directionalAttenuationFactor = pConfig->directionalAttenuationFactor; - pSpatializer->gainSmoothTimeInFrames = pConfig->gainSmoothTimeInFrames; - ma_atomic_vec3f_init(&pSpatializer->position, ma_vec3f_init_3f(0, 0, 0)); - ma_atomic_vec3f_init(&pSpatializer->direction, ma_vec3f_init_3f(0, 0, -1)); - ma_atomic_vec3f_init(&pSpatializer->velocity, ma_vec3f_init_3f(0, 0, 0)); - pSpatializer->dopplerPitch = 1; - - /* Swap the forward direction if we're left handed (it was initialized based on right handed). */ - if (pSpatializer->handedness == ma_handedness_left) { - ma_vec3f negDir = ma_vec3f_neg(ma_spatializer_get_direction(pSpatializer)); - ma_spatializer_set_direction(pSpatializer, negDir.x, negDir.y, negDir.z); - } - - /* Channel map. This will be on the heap. */ - if (pConfig->pChannelMapIn != NULL) { - pSpatializer->pChannelMapIn = (ma_channel*)ma_offset_ptr(pHeap, heapLayout.channelMapInOffset); - ma_channel_map_copy_or_default(pSpatializer->pChannelMapIn, pSpatializer->channelsIn, pConfig->pChannelMapIn, pSpatializer->channelsIn); - } - - /* New channel gains for output channels. */ - pSpatializer->pNewChannelGainsOut = (float*)ma_offset_ptr(pHeap, heapLayout.newChannelGainsOffset); - - /* Gainer. */ - gainerConfig = ma_spatializer_gainer_config_init(pConfig); - - result = ma_gainer_init_preallocated(&gainerConfig, ma_offset_ptr(pHeap, heapLayout.gainerOffset), &pSpatializer->gainer); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the gainer. */ - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_spatializer_init(const ma_spatializer_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_spatializer* pSpatializer) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - /* We'll need a heap allocation to retrieve the size. */ - result = ma_spatializer_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_spatializer_init_preallocated(pConfig, pHeap, pSpatializer); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pSpatializer->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_spatializer_uninit(ma_spatializer* pSpatializer, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pSpatializer == NULL) { - return; - } - - ma_gainer_uninit(&pSpatializer->gainer, pAllocationCallbacks); - - if (pSpatializer->_ownsHeap) { - ma_free(pSpatializer->_pHeap, pAllocationCallbacks); - } -} - -static float ma_calculate_angular_gain(ma_vec3f dirA, ma_vec3f dirB, float coneInnerAngleInRadians, float coneOuterAngleInRadians, float coneOuterGain) -{ - /* - Angular attenuation. - - Unlike distance gain, the math for this is not specified by the OpenAL spec so we'll just go ahead and figure - this out for ourselves at the expense of possibly being inconsistent with other implementations. - - To do cone attenuation, I'm just using the same math that we'd use to implement a basic spotlight in OpenGL. We - just need to get the direction from the source to the listener and then do a dot product against that and the - direction of the spotlight. Then we just compare that dot product against the cosine of the inner and outer - angles. If the dot product is greater than the the outer angle, we just use coneOuterGain. If it's less than - the inner angle, we just use a gain of 1. Otherwise we linearly interpolate between 1 and coneOuterGain. - */ - if (coneInnerAngleInRadians < 6.283185f) { - float angularGain = 1; - float cutoffInner = (float)ma_cosd(coneInnerAngleInRadians*0.5f); - float cutoffOuter = (float)ma_cosd(coneOuterAngleInRadians*0.5f); - float d; - - d = ma_vec3f_dot(dirA, dirB); - - if (d > cutoffInner) { - /* It's inside the inner angle. */ - angularGain = 1; - } else { - /* It's outside the inner angle. */ - if (d > cutoffOuter) { - /* It's between the inner and outer angle. We need to linearly interpolate between 1 and coneOuterGain. */ - angularGain = ma_mix_f32(coneOuterGain, 1, (d - cutoffOuter) / (cutoffInner - cutoffOuter)); - } else { - /* It's outside the outer angle. */ - angularGain = coneOuterGain; - } - } - - /*printf("d = %f; cutoffInner = %f; cutoffOuter = %f; angularGain = %f\n", d, cutoffInner, cutoffOuter, angularGain);*/ - return angularGain; - } else { - /* Inner angle is 360 degrees so no need to do any attenuation. */ - return 1; - } -} - -MA_API ma_result ma_spatializer_process_pcm_frames(ma_spatializer* pSpatializer, ma_spatializer_listener* pListener, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_channel* pChannelMapIn = pSpatializer->pChannelMapIn; - ma_channel* pChannelMapOut = pListener->config.pChannelMapOut; - - if (pSpatializer == NULL) { - return MA_INVALID_ARGS; - } - - /* If we're not spatializing we need to run an optimized path. */ - if (c89atomic_load_i32(&pSpatializer->attenuationModel) == ma_attenuation_model_none) { - if (ma_spatializer_listener_is_enabled(pListener)) { - /* No attenuation is required, but we'll need to do some channel conversion. */ - if (pSpatializer->channelsIn == pSpatializer->channelsOut) { - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, ma_format_f32, pSpatializer->channelsIn); - } else { - ma_channel_map_apply_f32((float*)pFramesOut, pChannelMapOut, pSpatializer->channelsOut, (const float*)pFramesIn, pChannelMapIn, pSpatializer->channelsIn, frameCount, ma_channel_mix_mode_rectangular, ma_mono_expansion_mode_default); /* Safe casts to float* because f32 is the only supported format. */ - } - } else { - /* The listener is disabled. Output silence. */ - ma_silence_pcm_frames(pFramesOut, frameCount, ma_format_f32, pSpatializer->channelsOut); - } - - /* - We're not doing attenuation so don't bother with doppler for now. I'm not sure if this is - the correct thinking so might need to review this later. - */ - pSpatializer->dopplerPitch = 1; - } else { - /* - Let's first determine which listener the sound is closest to. Need to keep in mind that we - might not have a world or any listeners, in which case we just spatializer based on the - listener being positioned at the origin (0, 0, 0). - */ - ma_vec3f relativePosNormalized; - ma_vec3f relativePos; /* The position relative to the listener. */ - ma_vec3f relativeDir; /* The direction of the sound, relative to the listener. */ - ma_vec3f listenerVel; /* The volocity of the listener. For doppler pitch calculation. */ - float speedOfSound; - float distance = 0; - float gain = 1; - ma_uint32 iChannel; - const ma_uint32 channelsOut = pSpatializer->channelsOut; - const ma_uint32 channelsIn = pSpatializer->channelsIn; - float minDistance = ma_spatializer_get_min_distance(pSpatializer); - float maxDistance = ma_spatializer_get_max_distance(pSpatializer); - float rolloff = ma_spatializer_get_rolloff(pSpatializer); - float dopplerFactor = ma_spatializer_get_doppler_factor(pSpatializer); - - /* - We'll need the listener velocity for doppler pitch calculations. The speed of sound is - defined by the listener, so we'll grab that here too. - */ - if (pListener != NULL) { - listenerVel = ma_spatializer_listener_get_velocity(pListener); - speedOfSound = pListener->config.speedOfSound; - } else { - listenerVel = ma_vec3f_init_3f(0, 0, 0); - speedOfSound = MA_DEFAULT_SPEED_OF_SOUND; - } - - if (pListener == NULL || ma_spatializer_get_positioning(pSpatializer) == ma_positioning_relative) { - /* There's no listener or we're using relative positioning. */ - relativePos = ma_spatializer_get_position(pSpatializer); - relativeDir = ma_spatializer_get_direction(pSpatializer); - } else { - /* - We've found a listener and we're using absolute positioning. We need to transform the - sound's position and direction so that it's relative to listener. Later on we'll use - this for determining the factors to apply to each channel to apply the panning effect. - */ - ma_spatializer_get_relative_position_and_direction(pSpatializer, pListener, &relativePos, &relativeDir); - } - - distance = ma_vec3f_len(relativePos); - - /* We've gathered the data, so now we can apply some spatialization. */ - switch (ma_spatializer_get_attenuation_model(pSpatializer)) { - case ma_attenuation_model_inverse: - { - gain = ma_attenuation_inverse(distance, minDistance, maxDistance, rolloff); - } break; - case ma_attenuation_model_linear: - { - gain = ma_attenuation_linear(distance, minDistance, maxDistance, rolloff); - } break; - case ma_attenuation_model_exponential: - { - gain = ma_attenuation_exponential(distance, minDistance, maxDistance, rolloff); - } break; - case ma_attenuation_model_none: - default: - { - gain = 1; - } break; - } - - /* Normalize the position. */ - if (distance > 0.001f) { - float distanceInv = 1/distance; - relativePosNormalized = relativePos; - relativePosNormalized.x *= distanceInv; - relativePosNormalized.y *= distanceInv; - relativePosNormalized.z *= distanceInv; - } else { - distance = 0; - relativePosNormalized = ma_vec3f_init_3f(0, 0, 0); - } - - /* - Angular attenuation. - - Unlike distance gain, the math for this is not specified by the OpenAL spec so we'll just go ahead and figure - this out for ourselves at the expense of possibly being inconsistent with other implementations. - - To do cone attenuation, I'm just using the same math that we'd use to implement a basic spotlight in OpenGL. We - just need to get the direction from the source to the listener and then do a dot product against that and the - direction of the spotlight. Then we just compare that dot product against the cosine of the inner and outer - angles. If the dot product is greater than the the outer angle, we just use coneOuterGain. If it's less than - the inner angle, we just use a gain of 1. Otherwise we linearly interpolate between 1 and coneOuterGain. - */ - if (distance > 0) { - /* Source anglular gain. */ - float spatializerConeInnerAngle; - float spatializerConeOuterAngle; - float spatializerConeOuterGain; - ma_spatializer_get_cone(pSpatializer, &spatializerConeInnerAngle, &spatializerConeOuterAngle, &spatializerConeOuterGain); - - gain *= ma_calculate_angular_gain(relativeDir, ma_vec3f_neg(relativePosNormalized), spatializerConeInnerAngle, spatializerConeOuterAngle, spatializerConeOuterGain); - - /* - We're supporting angular gain on the listener as well for those who want to reduce the volume of sounds that - are positioned behind the listener. On default settings, this will have no effect. - */ - if (pListener != NULL && pListener->config.coneInnerAngleInRadians < 6.283185f) { - ma_vec3f listenerDirection; - float listenerInnerAngle; - float listenerOuterAngle; - float listenerOuterGain; - - if (pListener->config.handedness == ma_handedness_right) { - listenerDirection = ma_vec3f_init_3f(0, 0, -1); - } else { - listenerDirection = ma_vec3f_init_3f(0, 0, +1); - } - - listenerInnerAngle = pListener->config.coneInnerAngleInRadians; - listenerOuterAngle = pListener->config.coneOuterAngleInRadians; - listenerOuterGain = pListener->config.coneOuterGain; - - gain *= ma_calculate_angular_gain(listenerDirection, relativePosNormalized, listenerInnerAngle, listenerOuterAngle, listenerOuterGain); - } - } else { - /* The sound is right on top of the listener. Don't do any angular attenuation. */ - } - - - /* Clamp the gain. */ - gain = ma_clamp(gain, ma_spatializer_get_min_gain(pSpatializer), ma_spatializer_get_max_gain(pSpatializer)); - - /* - Panning. This is where we'll apply the gain and convert to the output channel count. We have an optimized path for - when we're converting to a mono stream. In that case we don't really need to do any panning - we just apply the - gain to the final output. - */ - /*printf("distance=%f; gain=%f\n", distance, gain);*/ - - /* We must have a valid channel map here to ensure we spatialize properly. */ - MA_ASSERT(pChannelMapOut != NULL); - - /* - We're not converting to mono so we'll want to apply some panning. This is where the feeling of something being - to the left, right, infront or behind the listener is calculated. I'm just using a basic model here. Note that - the code below is not based on any specific algorithm. I'm just implementing this off the top of my head and - seeing how it goes. There might be better ways to do this. - - To determine the direction of the sound relative to a speaker I'm using dot products. Each speaker is given a - direction. For example, the left channel in a stereo system will be -1 on the X axis and the right channel will - be +1 on the X axis. A dot product is performed against the direction vector of the channel and the normalized - position of the sound. - */ - for (iChannel = 0; iChannel < channelsOut; iChannel += 1) { - pSpatializer->pNewChannelGainsOut[iChannel] = gain; - } - - /* - Convert to our output channel count. If the listener is disabled we just output silence here. We cannot ignore - the whole section of code here because we need to update some internal spatialization state. - */ - if (ma_spatializer_listener_is_enabled(pListener)) { - ma_channel_map_apply_f32((float*)pFramesOut, pChannelMapOut, channelsOut, (const float*)pFramesIn, pChannelMapIn, channelsIn, frameCount, ma_channel_mix_mode_rectangular, ma_mono_expansion_mode_default); - } else { - ma_silence_pcm_frames(pFramesOut, frameCount, ma_format_f32, pSpatializer->channelsOut); - } - - /* - Calculate our per-channel gains. We do this based on the normalized relative position of the sound and it's - relation to the direction of the channel. - */ - if (distance > 0) { - ma_vec3f unitPos = relativePos; - float distanceInv = 1/distance; - unitPos.x *= distanceInv; - unitPos.y *= distanceInv; - unitPos.z *= distanceInv; - - for (iChannel = 0; iChannel < channelsOut; iChannel += 1) { - ma_channel channelOut; - float d; - float dMin; - - channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannel); - if (ma_is_spatial_channel_position(channelOut)) { - d = ma_mix_f32_fast(1, ma_vec3f_dot(unitPos, ma_get_channel_direction(channelOut)), ma_spatializer_get_directional_attenuation_factor(pSpatializer)); - } else { - d = 1; /* It's not a spatial channel so there's no real notion of direction. */ - } - - /* - In my testing, if the panning effect is too aggressive it makes spatialization feel uncomfortable. - The "dMin" variable below is used to control the aggressiveness of the panning effect. When set to - 0, panning will be most extreme and any sounds that are positioned on the opposite side of the - speaker will be completely silent from that speaker. Not only does this feel uncomfortable, it - doesn't even remotely represent the real world at all because sounds that come from your right side - are still clearly audible from your left side. Setting "dMin" to 1 will result in no panning at - all, which is also not ideal. By setting it to something greater than 0, the spatialization effect - becomes much less dramatic and a lot more bearable. - - Summary: 0 = more extreme panning; 1 = no panning. - */ - dMin = pSpatializer->minSpatializationChannelGain; - - /* - At this point, "d" will be positive if the sound is on the same side as the channel and negative if - it's on the opposite side. It will be in the range of -1..1. There's two ways I can think of to - calculate a panning value. The first is to simply convert it to 0..1, however this has a problem - which I'm not entirely happy with. Considering a stereo system, when a sound is positioned right - in front of the listener it'll result in each speaker getting a gain of 0.5. I don't know if I like - the idea of having a scaling factor of 0.5 being applied to a sound when it's sitting right in front - of the listener. I would intuitively expect that to be played at full volume, or close to it. - - The second idea I think of is to only apply a reduction in gain when the sound is on the opposite - side of the speaker. That is, reduce the gain only when the dot product is negative. The problem - with this is that there will not be any attenuation as the sound sweeps around the 180 degrees - where the dot product is positive. The idea with this option is that you leave the gain at 1 when - the sound is being played on the same side as the speaker and then you just reduce the volume when - the sound is on the other side. - - The summarize, I think the first option should give a better sense of spatialization, but the second - option is better for preserving the sound's power. - - UPDATE: In my testing, I find the first option to sound better. You can feel the sense of space a - bit better, but you can also hear the reduction in volume when it's right in front. - */ - #if 1 - { - /* - Scale the dot product from -1..1 to 0..1. Will result in a sound directly in front losing power - by being played at 0.5 gain. - */ - d = (d + 1) * 0.5f; /* -1..1 to 0..1 */ - d = ma_max(d, dMin); - pSpatializer->pNewChannelGainsOut[iChannel] *= d; - } - #else - { - /* - Only reduce the volume of the sound if it's on the opposite side. This path keeps the volume more - consistent, but comes at the expense of a worse sense of space and positioning. - */ - if (d < 0) { - d += 1; /* Move into the positive range. */ - d = ma_max(d, dMin); - channelGainsOut[iChannel] *= d; - } - } - #endif - } - } else { - /* Assume the sound is right on top of us. Don't do any panning. */ - } - - /* Now we need to apply the volume to each channel. This needs to run through the gainer to ensure we get a smooth volume transition. */ - ma_gainer_set_gains(&pSpatializer->gainer, pSpatializer->pNewChannelGainsOut); - ma_gainer_process_pcm_frames(&pSpatializer->gainer, pFramesOut, pFramesOut, frameCount); - - /* - Before leaving we'll want to update our doppler pitch so that the caller can apply some - pitch shifting if they desire. Note that we need to negate the relative position here - because the doppler calculation needs to be source-to-listener, but ours is listener-to- - source. - */ - if (dopplerFactor > 0) { - pSpatializer->dopplerPitch = ma_doppler_pitch(ma_vec3f_sub(ma_spatializer_listener_get_position(pListener), ma_spatializer_get_position(pSpatializer)), ma_spatializer_get_velocity(pSpatializer), listenerVel, speedOfSound, dopplerFactor); - } else { - pSpatializer->dopplerPitch = 1; - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_spatializer_set_master_volume(ma_spatializer* pSpatializer, float volume) -{ - if (pSpatializer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_gainer_set_master_volume(&pSpatializer->gainer, volume); -} - -MA_API ma_result ma_spatializer_get_master_volume(const ma_spatializer* pSpatializer, float* pVolume) -{ - if (pSpatializer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_gainer_get_master_volume(&pSpatializer->gainer, pVolume); -} - -MA_API ma_uint32 ma_spatializer_get_input_channels(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return pSpatializer->channelsIn; -} - -MA_API ma_uint32 ma_spatializer_get_output_channels(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return pSpatializer->channelsOut; -} - -MA_API void ma_spatializer_set_attenuation_model(ma_spatializer* pSpatializer, ma_attenuation_model attenuationModel) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_i32(&pSpatializer->attenuationModel, attenuationModel); -} - -MA_API ma_attenuation_model ma_spatializer_get_attenuation_model(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return ma_attenuation_model_none; - } - - return (ma_attenuation_model)c89atomic_load_i32(&pSpatializer->attenuationModel); -} - -MA_API void ma_spatializer_set_positioning(ma_spatializer* pSpatializer, ma_positioning positioning) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_i32(&pSpatializer->positioning, positioning); -} - -MA_API ma_positioning ma_spatializer_get_positioning(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return ma_positioning_absolute; - } - - return (ma_positioning)c89atomic_load_i32(&pSpatializer->positioning); -} - -MA_API void ma_spatializer_set_rolloff(ma_spatializer* pSpatializer, float rolloff) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->rolloff, rolloff); -} - -MA_API float ma_spatializer_get_rolloff(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return c89atomic_load_f32(&pSpatializer->rolloff); -} - -MA_API void ma_spatializer_set_min_gain(ma_spatializer* pSpatializer, float minGain) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->minGain, minGain); -} - -MA_API float ma_spatializer_get_min_gain(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return c89atomic_load_f32(&pSpatializer->minGain); -} - -MA_API void ma_spatializer_set_max_gain(ma_spatializer* pSpatializer, float maxGain) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->maxGain, maxGain); -} - -MA_API float ma_spatializer_get_max_gain(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return c89atomic_load_f32(&pSpatializer->maxGain); -} - -MA_API void ma_spatializer_set_min_distance(ma_spatializer* pSpatializer, float minDistance) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->minDistance, minDistance); -} - -MA_API float ma_spatializer_get_min_distance(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return c89atomic_load_f32(&pSpatializer->minDistance); -} - -MA_API void ma_spatializer_set_max_distance(ma_spatializer* pSpatializer, float maxDistance) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->maxDistance, maxDistance); -} - -MA_API float ma_spatializer_get_max_distance(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 0; - } - - return c89atomic_load_f32(&pSpatializer->maxDistance); -} - -MA_API void ma_spatializer_set_cone(ma_spatializer* pSpatializer, float innerAngleInRadians, float outerAngleInRadians, float outerGain) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->coneInnerAngleInRadians, innerAngleInRadians); - c89atomic_exchange_f32(&pSpatializer->coneOuterAngleInRadians, outerAngleInRadians); - c89atomic_exchange_f32(&pSpatializer->coneOuterGain, outerGain); -} - -MA_API void ma_spatializer_get_cone(const ma_spatializer* pSpatializer, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain) -{ - if (pSpatializer == NULL) { - return; - } - - if (pInnerAngleInRadians != NULL) { - *pInnerAngleInRadians = c89atomic_load_f32(&pSpatializer->coneInnerAngleInRadians); - } - - if (pOuterAngleInRadians != NULL) { - *pOuterAngleInRadians = c89atomic_load_f32(&pSpatializer->coneOuterAngleInRadians); - } - - if (pOuterGain != NULL) { - *pOuterGain = c89atomic_load_f32(&pSpatializer->coneOuterGain); - } -} - -MA_API void ma_spatializer_set_doppler_factor(ma_spatializer* pSpatializer, float dopplerFactor) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->dopplerFactor, dopplerFactor); -} - -MA_API float ma_spatializer_get_doppler_factor(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 1; - } - - return c89atomic_load_f32(&pSpatializer->dopplerFactor); -} - -MA_API void ma_spatializer_set_directional_attenuation_factor(ma_spatializer* pSpatializer, float directionalAttenuationFactor) -{ - if (pSpatializer == NULL) { - return; - } - - c89atomic_exchange_f32(&pSpatializer->directionalAttenuationFactor, directionalAttenuationFactor); -} - -MA_API float ma_spatializer_get_directional_attenuation_factor(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return 1; - } - - return c89atomic_load_f32(&pSpatializer->directionalAttenuationFactor); -} - -MA_API void ma_spatializer_set_position(ma_spatializer* pSpatializer, float x, float y, float z) -{ - if (pSpatializer == NULL) { - return; - } - - ma_atomic_vec3f_set(&pSpatializer->position, ma_vec3f_init_3f(x, y, z)); -} - -MA_API ma_vec3f ma_spatializer_get_position(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_atomic_vec3f_get((ma_atomic_vec3f*)&pSpatializer->position); /* Naughty const-cast. It's just for atomically loading the vec3 which should be safe. */ -} - -MA_API void ma_spatializer_set_direction(ma_spatializer* pSpatializer, float x, float y, float z) -{ - if (pSpatializer == NULL) { - return; - } - - ma_atomic_vec3f_set(&pSpatializer->direction, ma_vec3f_init_3f(x, y, z)); -} - -MA_API ma_vec3f ma_spatializer_get_direction(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return ma_vec3f_init_3f(0, 0, -1); - } - - return ma_atomic_vec3f_get((ma_atomic_vec3f*)&pSpatializer->direction); /* Naughty const-cast. It's just for atomically loading the vec3 which should be safe. */ -} - -MA_API void ma_spatializer_set_velocity(ma_spatializer* pSpatializer, float x, float y, float z) -{ - if (pSpatializer == NULL) { - return; - } - - ma_atomic_vec3f_set(&pSpatializer->velocity, ma_vec3f_init_3f(x, y, z)); -} - -MA_API ma_vec3f ma_spatializer_get_velocity(const ma_spatializer* pSpatializer) -{ - if (pSpatializer == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_atomic_vec3f_get((ma_atomic_vec3f*)&pSpatializer->velocity); /* Naughty const-cast. It's just for atomically loading the vec3 which should be safe. */ -} - -MA_API void ma_spatializer_get_relative_position_and_direction(const ma_spatializer* pSpatializer, const ma_spatializer_listener* pListener, ma_vec3f* pRelativePos, ma_vec3f* pRelativeDir) -{ - if (pRelativePos != NULL) { - pRelativePos->x = 0; - pRelativePos->y = 0; - pRelativePos->z = 0; - } - - if (pRelativeDir != NULL) { - pRelativeDir->x = 0; - pRelativeDir->y = 0; - pRelativeDir->z = -1; - } - - if (pSpatializer == NULL) { - return; - } - - if (pListener == NULL || ma_spatializer_get_positioning(pSpatializer) == ma_positioning_relative) { - /* There's no listener or we're using relative positioning. */ - if (pRelativePos != NULL) { - *pRelativePos = ma_spatializer_get_position(pSpatializer); - } - if (pRelativeDir != NULL) { - *pRelativeDir = ma_spatializer_get_direction(pSpatializer); - } - } else { - ma_vec3f spatializerPosition; - ma_vec3f spatializerDirection; - ma_vec3f listenerPosition; - ma_vec3f listenerDirection; - ma_vec3f v; - ma_vec3f axisX; - ma_vec3f axisY; - ma_vec3f axisZ; - float m[4][4]; - - spatializerPosition = ma_spatializer_get_position(pSpatializer); - spatializerDirection = ma_spatializer_get_direction(pSpatializer); - listenerPosition = ma_spatializer_listener_get_position(pListener); - listenerDirection = ma_spatializer_listener_get_direction(pListener); - - /* - We need to calcualte the right vector from our forward and up vectors. This is done with - a cross product. - */ - axisZ = ma_vec3f_normalize(listenerDirection); /* Normalization required here because we can't trust the caller. */ - axisX = ma_vec3f_normalize(ma_vec3f_cross(axisZ, pListener->config.worldUp)); /* Normalization required here because the world up vector may not be perpendicular with the forward vector. */ - - /* - The calculation of axisX above can result in a zero-length vector if the listener is - looking straight up on the Y axis. We'll need to fall back to a +X in this case so that - the calculations below don't fall apart. This is where a quaternion based listener and - sound orientation would come in handy. - */ - if (ma_vec3f_len2(axisX) == 0) { - axisX = ma_vec3f_init_3f(1, 0, 0); - } - - axisY = ma_vec3f_cross(axisX, axisZ); /* No normalization is required here because axisX and axisZ are unit length and perpendicular. */ - - /* - We need to swap the X axis if we're left handed because otherwise the cross product above - will have resulted in it pointing in the wrong direction (right handed was assumed in the - cross products above). - */ - if (pListener->config.handedness == ma_handedness_left) { - axisX = ma_vec3f_neg(axisX); - } - - /* Lookat. */ - m[0][0] = axisX.x; m[1][0] = axisX.y; m[2][0] = axisX.z; m[3][0] = -ma_vec3f_dot(axisX, listenerPosition); - m[0][1] = axisY.x; m[1][1] = axisY.y; m[2][1] = axisY.z; m[3][1] = -ma_vec3f_dot(axisY, listenerPosition); - m[0][2] = -axisZ.x; m[1][2] = -axisZ.y; m[2][2] = -axisZ.z; m[3][2] = -ma_vec3f_dot(ma_vec3f_neg(axisZ), listenerPosition); - m[0][3] = 0; m[1][3] = 0; m[2][3] = 0; m[3][3] = 1; - - /* - Multiply the lookat matrix by the spatializer position to transform it to listener - space. This allows calculations to work based on the sound being relative to the - origin which makes things simpler. - */ - if (pRelativePos != NULL) { - v = spatializerPosition; - pRelativePos->x = m[0][0] * v.x + m[1][0] * v.y + m[2][0] * v.z + m[3][0] * 1; - pRelativePos->y = m[0][1] * v.x + m[1][1] * v.y + m[2][1] * v.z + m[3][1] * 1; - pRelativePos->z = m[0][2] * v.x + m[1][2] * v.y + m[2][2] * v.z + m[3][2] * 1; - } - - /* - The direction of the sound needs to also be transformed so that it's relative to the - rotation of the listener. - */ - if (pRelativeDir != NULL) { - v = spatializerDirection; - pRelativeDir->x = m[0][0] * v.x + m[1][0] * v.y + m[2][0] * v.z; - pRelativeDir->y = m[0][1] * v.x + m[1][1] * v.y + m[2][1] * v.z; - pRelativeDir->z = m[0][2] * v.x + m[1][2] * v.y + m[2][2] * v.z; - } - } -} - - - - -/************************************************************************************************************************************************************** - -Resampling - -**************************************************************************************************************************************************************/ -MA_API ma_linear_resampler_config ma_linear_resampler_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut) -{ - ma_linear_resampler_config config; - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRateIn = sampleRateIn; - config.sampleRateOut = sampleRateOut; - config.lpfOrder = ma_min(MA_DEFAULT_RESAMPLER_LPF_ORDER, MA_MAX_FILTER_ORDER); - config.lpfNyquistFactor = 1; - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t x0Offset; - size_t x1Offset; - size_t lpfOffset; -} ma_linear_resampler_heap_layout; - - -static void ma_linear_resampler_adjust_timer_for_new_rate(ma_linear_resampler* pResampler, ma_uint32 oldSampleRateOut, ma_uint32 newSampleRateOut) -{ - /* - So what's happening here? Basically we need to adjust the fractional component of the time advance based on the new rate. The old time advance will - be based on the old sample rate, but we are needing to adjust it to that it's based on the new sample rate. - */ - ma_uint32 oldRateTimeWhole = pResampler->inTimeFrac / oldSampleRateOut; /* <-- This should almost never be anything other than 0, but leaving it here to make this more general and robust just in case. */ - ma_uint32 oldRateTimeFract = pResampler->inTimeFrac % oldSampleRateOut; - - pResampler->inTimeFrac = - (oldRateTimeWhole * newSampleRateOut) + - ((oldRateTimeFract * newSampleRateOut) / oldSampleRateOut); - - /* Make sure the fractional part is less than the output sample rate. */ - pResampler->inTimeInt += pResampler->inTimeFrac / pResampler->config.sampleRateOut; - pResampler->inTimeFrac = pResampler->inTimeFrac % pResampler->config.sampleRateOut; -} - -static ma_result ma_linear_resampler_set_rate_internal(ma_linear_resampler* pResampler, void* pHeap, ma_linear_resampler_heap_layout* pHeapLayout, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut, ma_bool32 isResamplerAlreadyInitialized) -{ - ma_result result; - ma_uint32 gcf; - ma_uint32 lpfSampleRate; - double lpfCutoffFrequency; - ma_lpf_config lpfConfig; - ma_uint32 oldSampleRateOut; /* Required for adjusting time advance down the bottom. */ - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (sampleRateIn == 0 || sampleRateOut == 0) { - return MA_INVALID_ARGS; - } - - oldSampleRateOut = pResampler->config.sampleRateOut; - - pResampler->config.sampleRateIn = sampleRateIn; - pResampler->config.sampleRateOut = sampleRateOut; - - /* Simplify the sample rate. */ - gcf = ma_gcf_u32(pResampler->config.sampleRateIn, pResampler->config.sampleRateOut); - pResampler->config.sampleRateIn /= gcf; - pResampler->config.sampleRateOut /= gcf; - - /* Always initialize the low-pass filter, even when the order is 0. */ - if (pResampler->config.lpfOrder > MA_MAX_FILTER_ORDER) { - return MA_INVALID_ARGS; - } - - lpfSampleRate = (ma_uint32)(ma_max(pResampler->config.sampleRateIn, pResampler->config.sampleRateOut)); - lpfCutoffFrequency = ( double)(ma_min(pResampler->config.sampleRateIn, pResampler->config.sampleRateOut) * 0.5 * pResampler->config.lpfNyquistFactor); - - lpfConfig = ma_lpf_config_init(pResampler->config.format, pResampler->config.channels, lpfSampleRate, lpfCutoffFrequency, pResampler->config.lpfOrder); - - /* - If the resampler is alreay initialized we don't want to do a fresh initialization of the low-pass filter because it will result in the cached frames - getting cleared. Instead we re-initialize the filter which will maintain any cached frames. - */ - if (isResamplerAlreadyInitialized) { - result = ma_lpf_reinit(&lpfConfig, &pResampler->lpf); - } else { - result = ma_lpf_init_preallocated(&lpfConfig, ma_offset_ptr(pHeap, pHeapLayout->lpfOffset), &pResampler->lpf); - } - - if (result != MA_SUCCESS) { - return result; - } - - - pResampler->inAdvanceInt = pResampler->config.sampleRateIn / pResampler->config.sampleRateOut; - pResampler->inAdvanceFrac = pResampler->config.sampleRateIn % pResampler->config.sampleRateOut; - - /* Our timer was based on the old rate. We need to adjust it so that it's based on the new rate. */ - ma_linear_resampler_adjust_timer_for_new_rate(pResampler, oldSampleRateOut, pResampler->config.sampleRateOut); - - return MA_SUCCESS; -} - -static ma_result ma_linear_resampler_get_heap_layout(const ma_linear_resampler_config* pConfig, ma_linear_resampler_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->format != ma_format_f32 && pConfig->format != ma_format_s16) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* x0 */ - pHeapLayout->x0Offset = pHeapLayout->sizeInBytes; - if (pConfig->format == ma_format_f32) { - pHeapLayout->sizeInBytes += sizeof(float) * pConfig->channels; - } else { - pHeapLayout->sizeInBytes += sizeof(ma_int16) * pConfig->channels; - } - - /* x1 */ - pHeapLayout->x1Offset = pHeapLayout->sizeInBytes; - if (pConfig->format == ma_format_f32) { - pHeapLayout->sizeInBytes += sizeof(float) * pConfig->channels; - } else { - pHeapLayout->sizeInBytes += sizeof(ma_int16) * pConfig->channels; - } - - /* LPF */ - pHeapLayout->lpfOffset = ma_align_64(pHeapLayout->sizeInBytes); - { - ma_result result; - size_t lpfHeapSizeInBytes; - ma_lpf_config lpfConfig = ma_lpf_config_init(pConfig->format, pConfig->channels, 1, 1, pConfig->lpfOrder); /* Sample rate and cutoff frequency do not matter. */ - - result = ma_lpf_get_heap_size(&lpfConfig, &lpfHeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += lpfHeapSizeInBytes; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_linear_resampler_get_heap_size(const ma_linear_resampler_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_linear_resampler_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_linear_resampler_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_linear_resampler_init_preallocated(const ma_linear_resampler_config* pConfig, void* pHeap, ma_linear_resampler* pResampler) -{ - ma_result result; - ma_linear_resampler_heap_layout heapLayout; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pResampler); - - result = ma_linear_resampler_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pResampler->config = *pConfig; - - pResampler->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - if (pConfig->format == ma_format_f32) { - pResampler->x0.f32 = (float*)ma_offset_ptr(pHeap, heapLayout.x0Offset); - pResampler->x1.f32 = (float*)ma_offset_ptr(pHeap, heapLayout.x1Offset); - } else { - pResampler->x0.s16 = (ma_int16*)ma_offset_ptr(pHeap, heapLayout.x0Offset); - pResampler->x1.s16 = (ma_int16*)ma_offset_ptr(pHeap, heapLayout.x1Offset); - } - - /* Setting the rate will set up the filter and time advances for us. */ - result = ma_linear_resampler_set_rate_internal(pResampler, pHeap, &heapLayout, pConfig->sampleRateIn, pConfig->sampleRateOut, /* isResamplerAlreadyInitialized = */ MA_FALSE); - if (result != MA_SUCCESS) { - return result; - } - - pResampler->inTimeInt = 1; /* Set this to one to force an input sample to always be loaded for the first output frame. */ - pResampler->inTimeFrac = 0; - - return MA_SUCCESS; -} - -MA_API ma_result ma_linear_resampler_init(const ma_linear_resampler_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_linear_resampler* pResampler) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_linear_resampler_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_linear_resampler_init_preallocated(pConfig, pHeap, pResampler); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pResampler->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_linear_resampler_uninit(ma_linear_resampler* pResampler, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pResampler == NULL) { - return; - } - - ma_lpf_uninit(&pResampler->lpf, pAllocationCallbacks); - - if (pResampler->_ownsHeap) { - ma_free(pResampler->_pHeap, pAllocationCallbacks); - } -} - -static MA_INLINE ma_int16 ma_linear_resampler_mix_s16(ma_int16 x, ma_int16 y, ma_int32 a, const ma_int32 shift) -{ - ma_int32 b; - ma_int32 c; - ma_int32 r; - - MA_ASSERT(a <= (1<> shift); -} - -static void ma_linear_resampler_interpolate_frame_s16(ma_linear_resampler* pResampler, ma_int16* MA_RESTRICT pFrameOut) -{ - ma_uint32 c; - ma_uint32 a; - const ma_uint32 channels = pResampler->config.channels; - const ma_uint32 shift = 12; - - MA_ASSERT(pResampler != NULL); - MA_ASSERT(pFrameOut != NULL); - - a = (pResampler->inTimeFrac << shift) / pResampler->config.sampleRateOut; - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - ma_int16 s = ma_linear_resampler_mix_s16(pResampler->x0.s16[c], pResampler->x1.s16[c], a, shift); - pFrameOut[c] = s; - } -} - - -static void ma_linear_resampler_interpolate_frame_f32(ma_linear_resampler* pResampler, float* MA_RESTRICT pFrameOut) -{ - ma_uint32 c; - float a; - const ma_uint32 channels = pResampler->config.channels; - - MA_ASSERT(pResampler != NULL); - MA_ASSERT(pFrameOut != NULL); - - a = (float)pResampler->inTimeFrac / pResampler->config.sampleRateOut; - - MA_ASSUME(channels > 0); - for (c = 0; c < channels; c += 1) { - float s = ma_mix_f32_fast(pResampler->x0.f32[c], pResampler->x1.f32[c], a); - pFrameOut[c] = s; - } -} - -static ma_result ma_linear_resampler_process_pcm_frames_s16_downsample(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - const ma_int16* pFramesInS16; - /* */ ma_int16* pFramesOutS16; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - - MA_ASSERT(pResampler != NULL); - MA_ASSERT(pFrameCountIn != NULL); - MA_ASSERT(pFrameCountOut != NULL); - - pFramesInS16 = (const ma_int16*)pFramesIn; - pFramesOutS16 = ( ma_int16*)pFramesOut; - frameCountIn = *pFrameCountIn; - frameCountOut = *pFrameCountOut; - framesProcessedIn = 0; - framesProcessedOut = 0; - - while (framesProcessedOut < frameCountOut) { - /* Before interpolating we need to load the buffers. When doing this we need to ensure we run every input sample through the filter. */ - while (pResampler->inTimeInt > 0 && frameCountIn > framesProcessedIn) { - ma_uint32 iChannel; - - if (pFramesInS16 != NULL) { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.s16[iChannel] = pResampler->x1.s16[iChannel]; - pResampler->x1.s16[iChannel] = pFramesInS16[iChannel]; - } - pFramesInS16 += pResampler->config.channels; - } else { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.s16[iChannel] = pResampler->x1.s16[iChannel]; - pResampler->x1.s16[iChannel] = 0; - } - } - - /* Filter. */ - ma_lpf_process_pcm_frame_s16(&pResampler->lpf, pResampler->x1.s16, pResampler->x1.s16); - - framesProcessedIn += 1; - pResampler->inTimeInt -= 1; - } - - if (pResampler->inTimeInt > 0) { - break; /* Ran out of input data. */ - } - - /* Getting here means the frames have been loaded and filtered and we can generate the next output frame. */ - if (pFramesOutS16 != NULL) { - MA_ASSERT(pResampler->inTimeInt == 0); - ma_linear_resampler_interpolate_frame_s16(pResampler, pFramesOutS16); - - pFramesOutS16 += pResampler->config.channels; - } - - framesProcessedOut += 1; - - /* Advance time forward. */ - pResampler->inTimeInt += pResampler->inAdvanceInt; - pResampler->inTimeFrac += pResampler->inAdvanceFrac; - if (pResampler->inTimeFrac >= pResampler->config.sampleRateOut) { - pResampler->inTimeFrac -= pResampler->config.sampleRateOut; - pResampler->inTimeInt += 1; - } - } - - *pFrameCountIn = framesProcessedIn; - *pFrameCountOut = framesProcessedOut; - - return MA_SUCCESS; -} - -static ma_result ma_linear_resampler_process_pcm_frames_s16_upsample(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - const ma_int16* pFramesInS16; - /* */ ma_int16* pFramesOutS16; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - - MA_ASSERT(pResampler != NULL); - MA_ASSERT(pFrameCountIn != NULL); - MA_ASSERT(pFrameCountOut != NULL); - - pFramesInS16 = (const ma_int16*)pFramesIn; - pFramesOutS16 = ( ma_int16*)pFramesOut; - frameCountIn = *pFrameCountIn; - frameCountOut = *pFrameCountOut; - framesProcessedIn = 0; - framesProcessedOut = 0; - - while (framesProcessedOut < frameCountOut) { - /* Before interpolating we need to load the buffers. */ - while (pResampler->inTimeInt > 0 && frameCountIn > framesProcessedIn) { - ma_uint32 iChannel; - - if (pFramesInS16 != NULL) { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.s16[iChannel] = pResampler->x1.s16[iChannel]; - pResampler->x1.s16[iChannel] = pFramesInS16[iChannel]; - } - pFramesInS16 += pResampler->config.channels; - } else { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.s16[iChannel] = pResampler->x1.s16[iChannel]; - pResampler->x1.s16[iChannel] = 0; - } - } - - framesProcessedIn += 1; - pResampler->inTimeInt -= 1; - } - - if (pResampler->inTimeInt > 0) { - break; /* Ran out of input data. */ - } - - /* Getting here means the frames have been loaded and we can generate the next output frame. */ - if (pFramesOutS16 != NULL) { - MA_ASSERT(pResampler->inTimeInt == 0); - ma_linear_resampler_interpolate_frame_s16(pResampler, pFramesOutS16); - - /* Filter. */ - ma_lpf_process_pcm_frame_s16(&pResampler->lpf, pFramesOutS16, pFramesOutS16); - - pFramesOutS16 += pResampler->config.channels; - } - - framesProcessedOut += 1; - - /* Advance time forward. */ - pResampler->inTimeInt += pResampler->inAdvanceInt; - pResampler->inTimeFrac += pResampler->inAdvanceFrac; - if (pResampler->inTimeFrac >= pResampler->config.sampleRateOut) { - pResampler->inTimeFrac -= pResampler->config.sampleRateOut; - pResampler->inTimeInt += 1; - } - } - - *pFrameCountIn = framesProcessedIn; - *pFrameCountOut = framesProcessedOut; - - return MA_SUCCESS; -} - -static ma_result ma_linear_resampler_process_pcm_frames_s16(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - MA_ASSERT(pResampler != NULL); - - if (pResampler->config.sampleRateIn > pResampler->config.sampleRateOut) { - return ma_linear_resampler_process_pcm_frames_s16_downsample(pResampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } else { - return ma_linear_resampler_process_pcm_frames_s16_upsample(pResampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } -} - - -static ma_result ma_linear_resampler_process_pcm_frames_f32_downsample(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - const float* pFramesInF32; - /* */ float* pFramesOutF32; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - - MA_ASSERT(pResampler != NULL); - MA_ASSERT(pFrameCountIn != NULL); - MA_ASSERT(pFrameCountOut != NULL); - - pFramesInF32 = (const float*)pFramesIn; - pFramesOutF32 = ( float*)pFramesOut; - frameCountIn = *pFrameCountIn; - frameCountOut = *pFrameCountOut; - framesProcessedIn = 0; - framesProcessedOut = 0; - - while (framesProcessedOut < frameCountOut) { - /* Before interpolating we need to load the buffers. When doing this we need to ensure we run every input sample through the filter. */ - while (pResampler->inTimeInt > 0 && frameCountIn > framesProcessedIn) { - ma_uint32 iChannel; - - if (pFramesInF32 != NULL) { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.f32[iChannel] = pResampler->x1.f32[iChannel]; - pResampler->x1.f32[iChannel] = pFramesInF32[iChannel]; - } - pFramesInF32 += pResampler->config.channels; - } else { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.f32[iChannel] = pResampler->x1.f32[iChannel]; - pResampler->x1.f32[iChannel] = 0; - } - } - - /* Filter. */ - ma_lpf_process_pcm_frame_f32(&pResampler->lpf, pResampler->x1.f32, pResampler->x1.f32); - - framesProcessedIn += 1; - pResampler->inTimeInt -= 1; - } - - if (pResampler->inTimeInt > 0) { - break; /* Ran out of input data. */ - } - - /* Getting here means the frames have been loaded and filtered and we can generate the next output frame. */ - if (pFramesOutF32 != NULL) { - MA_ASSERT(pResampler->inTimeInt == 0); - ma_linear_resampler_interpolate_frame_f32(pResampler, pFramesOutF32); - - pFramesOutF32 += pResampler->config.channels; - } - - framesProcessedOut += 1; - - /* Advance time forward. */ - pResampler->inTimeInt += pResampler->inAdvanceInt; - pResampler->inTimeFrac += pResampler->inAdvanceFrac; - if (pResampler->inTimeFrac >= pResampler->config.sampleRateOut) { - pResampler->inTimeFrac -= pResampler->config.sampleRateOut; - pResampler->inTimeInt += 1; - } - } - - *pFrameCountIn = framesProcessedIn; - *pFrameCountOut = framesProcessedOut; - - return MA_SUCCESS; -} - -static ma_result ma_linear_resampler_process_pcm_frames_f32_upsample(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - const float* pFramesInF32; - /* */ float* pFramesOutF32; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - - MA_ASSERT(pResampler != NULL); - MA_ASSERT(pFrameCountIn != NULL); - MA_ASSERT(pFrameCountOut != NULL); - - pFramesInF32 = (const float*)pFramesIn; - pFramesOutF32 = ( float*)pFramesOut; - frameCountIn = *pFrameCountIn; - frameCountOut = *pFrameCountOut; - framesProcessedIn = 0; - framesProcessedOut = 0; - - while (framesProcessedOut < frameCountOut) { - /* Before interpolating we need to load the buffers. */ - while (pResampler->inTimeInt > 0 && frameCountIn > framesProcessedIn) { - ma_uint32 iChannel; - - if (pFramesInF32 != NULL) { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.f32[iChannel] = pResampler->x1.f32[iChannel]; - pResampler->x1.f32[iChannel] = pFramesInF32[iChannel]; - } - pFramesInF32 += pResampler->config.channels; - } else { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.f32[iChannel] = pResampler->x1.f32[iChannel]; - pResampler->x1.f32[iChannel] = 0; - } - } - - framesProcessedIn += 1; - pResampler->inTimeInt -= 1; - } - - if (pResampler->inTimeInt > 0) { - break; /* Ran out of input data. */ - } - - /* Getting here means the frames have been loaded and we can generate the next output frame. */ - if (pFramesOutF32 != NULL) { - MA_ASSERT(pResampler->inTimeInt == 0); - ma_linear_resampler_interpolate_frame_f32(pResampler, pFramesOutF32); - - /* Filter. */ - ma_lpf_process_pcm_frame_f32(&pResampler->lpf, pFramesOutF32, pFramesOutF32); - - pFramesOutF32 += pResampler->config.channels; - } - - framesProcessedOut += 1; - - /* Advance time forward. */ - pResampler->inTimeInt += pResampler->inAdvanceInt; - pResampler->inTimeFrac += pResampler->inAdvanceFrac; - if (pResampler->inTimeFrac >= pResampler->config.sampleRateOut) { - pResampler->inTimeFrac -= pResampler->config.sampleRateOut; - pResampler->inTimeInt += 1; - } - } - - *pFrameCountIn = framesProcessedIn; - *pFrameCountOut = framesProcessedOut; - - return MA_SUCCESS; -} - -static ma_result ma_linear_resampler_process_pcm_frames_f32(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - MA_ASSERT(pResampler != NULL); - - if (pResampler->config.sampleRateIn > pResampler->config.sampleRateOut) { - return ma_linear_resampler_process_pcm_frames_f32_downsample(pResampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } else { - return ma_linear_resampler_process_pcm_frames_f32_upsample(pResampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } -} - - -MA_API ma_result ma_linear_resampler_process_pcm_frames(ma_linear_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - /* */ if (pResampler->config.format == ma_format_s16) { - return ma_linear_resampler_process_pcm_frames_s16(pResampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } else if (pResampler->config.format == ma_format_f32) { - return ma_linear_resampler_process_pcm_frames_f32(pResampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } else { - /* Should never get here. Getting here means the format is not supported and you didn't check the return value of ma_linear_resampler_init(). */ - MA_ASSERT(MA_FALSE); - return MA_INVALID_ARGS; - } -} - - -MA_API ma_result ma_linear_resampler_set_rate(ma_linear_resampler* pResampler, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut) -{ - return ma_linear_resampler_set_rate_internal(pResampler, NULL, NULL, sampleRateIn, sampleRateOut, /* isResamplerAlreadyInitialized = */ MA_TRUE); -} - -MA_API ma_result ma_linear_resampler_set_rate_ratio(ma_linear_resampler* pResampler, float ratioInOut) -{ - ma_uint32 n; - ma_uint32 d; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (ratioInOut <= 0) { - return MA_INVALID_ARGS; - } - - d = 1000; - n = (ma_uint32)(ratioInOut * d); - - if (n == 0) { - return MA_INVALID_ARGS; /* Ratio too small. */ - } - - MA_ASSERT(n != 0); - - return ma_linear_resampler_set_rate(pResampler, n, d); -} - -MA_API ma_uint64 ma_linear_resampler_get_input_latency(const ma_linear_resampler* pResampler) -{ - if (pResampler == NULL) { - return 0; - } - - return 1 + ma_lpf_get_latency(&pResampler->lpf); -} - -MA_API ma_uint64 ma_linear_resampler_get_output_latency(const ma_linear_resampler* pResampler) -{ - if (pResampler == NULL) { - return 0; - } - - return ma_linear_resampler_get_input_latency(pResampler) * pResampler->config.sampleRateOut / pResampler->config.sampleRateIn; -} - -MA_API ma_result ma_linear_resampler_get_required_input_frame_count(const ma_linear_resampler* pResampler, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount) -{ - ma_uint64 inputFrameCount; - - if (pInputFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - *pInputFrameCount = 0; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (outputFrameCount == 0) { - return MA_SUCCESS; - } - - /* Any whole input frames are consumed before the first output frame is generated. */ - inputFrameCount = pResampler->inTimeInt; - outputFrameCount -= 1; - - /* The rest of the output frames can be calculated in constant time. */ - inputFrameCount += outputFrameCount * pResampler->inAdvanceInt; - inputFrameCount += (pResampler->inTimeFrac + (outputFrameCount * pResampler->inAdvanceFrac)) / pResampler->config.sampleRateOut; - - *pInputFrameCount = inputFrameCount; - - return MA_SUCCESS; -} - -MA_API ma_result ma_linear_resampler_get_expected_output_frame_count(const ma_linear_resampler* pResampler, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount) -{ - ma_uint64 outputFrameCount; - ma_uint64 preliminaryInputFrameCountFromFrac; - ma_uint64 preliminaryInputFrameCount; - - if (pOutputFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - *pOutputFrameCount = 0; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - /* - The first step is to get a preliminary output frame count. This will either be exactly equal to what we need, or less by 1. We need to - determine how many input frames will be consumed by this value. If it's greater than our original input frame count it means we won't - be able to generate an extra frame because we will have run out of input data. Otherwise we will have enough input for the generation - of an extra output frame. This add-by-one logic is necessary due to how the data loading logic works when processing frames. - */ - outputFrameCount = (inputFrameCount * pResampler->config.sampleRateOut) / pResampler->config.sampleRateIn; - - /* - We need to determine how many *whole* input frames will have been processed to generate our preliminary output frame count. This is - used in the logic below to determine whether or not we need to add an extra output frame. - */ - preliminaryInputFrameCountFromFrac = (pResampler->inTimeFrac + outputFrameCount*pResampler->inAdvanceFrac) / pResampler->config.sampleRateOut; - preliminaryInputFrameCount = (pResampler->inTimeInt + outputFrameCount*pResampler->inAdvanceInt ) + preliminaryInputFrameCountFromFrac; - - /* - If the total number of *whole* input frames that would be required to generate our preliminary output frame count is greather than - the amount of whole input frames we have available as input we need to *not* add an extra output frame as there won't be enough data - to actually process. Otherwise we need to add the extra output frame. - */ - if (preliminaryInputFrameCount <= inputFrameCount) { - outputFrameCount += 1; - } - - *pOutputFrameCount = outputFrameCount; - - return MA_SUCCESS; -} - -MA_API ma_result ma_linear_resampler_reset(ma_linear_resampler* pResampler) -{ - ma_uint32 iChannel; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - /* Timers need to be cleared back to zero. */ - pResampler->inTimeInt = 1; /* Set this to one to force an input sample to always be loaded for the first output frame. */ - pResampler->inTimeFrac = 0; - - /* Cached samples need to be cleared. */ - if (pResampler->config.format == ma_format_f32) { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.f32[iChannel] = 0; - pResampler->x1.f32[iChannel] = 0; - } - } else { - for (iChannel = 0; iChannel < pResampler->config.channels; iChannel += 1) { - pResampler->x0.s16[iChannel] = 0; - pResampler->x1.s16[iChannel] = 0; - } - } - - /* The low pass filter needs to have it's cache reset. */ - ma_lpf_clear_cache(&pResampler->lpf); - - return MA_SUCCESS; -} - - - -/* Linear resampler backend vtable. */ -static ma_linear_resampler_config ma_resampling_backend_get_config__linear(const ma_resampler_config* pConfig) -{ - ma_linear_resampler_config linearConfig; - - linearConfig = ma_linear_resampler_config_init(pConfig->format, pConfig->channels, pConfig->sampleRateIn, pConfig->sampleRateOut); - linearConfig.lpfOrder = pConfig->linear.lpfOrder; - - return linearConfig; -} - -static ma_result ma_resampling_backend_get_heap_size__linear(void* pUserData, const ma_resampler_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_linear_resampler_config linearConfig; - - (void)pUserData; - - linearConfig = ma_resampling_backend_get_config__linear(pConfig); - - return ma_linear_resampler_get_heap_size(&linearConfig, pHeapSizeInBytes); -} - -static ma_result ma_resampling_backend_init__linear(void* pUserData, const ma_resampler_config* pConfig, void* pHeap, ma_resampling_backend** ppBackend) -{ - ma_resampler* pResampler = (ma_resampler*)pUserData; - ma_result result; - ma_linear_resampler_config linearConfig; - - (void)pUserData; - - linearConfig = ma_resampling_backend_get_config__linear(pConfig); - - result = ma_linear_resampler_init_preallocated(&linearConfig, pHeap, &pResampler->state.linear); - if (result != MA_SUCCESS) { - return result; - } - - *ppBackend = &pResampler->state.linear; - - return MA_SUCCESS; -} - -static void ma_resampling_backend_uninit__linear(void* pUserData, ma_resampling_backend* pBackend, const ma_allocation_callbacks* pAllocationCallbacks) -{ - (void)pUserData; - - ma_linear_resampler_uninit((ma_linear_resampler*)pBackend, pAllocationCallbacks); -} - -static ma_result ma_resampling_backend_process__linear(void* pUserData, ma_resampling_backend* pBackend, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - (void)pUserData; - - return ma_linear_resampler_process_pcm_frames((ma_linear_resampler*)pBackend, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); -} - -static ma_result ma_resampling_backend_set_rate__linear(void* pUserData, ma_resampling_backend* pBackend, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut) -{ - (void)pUserData; - - return ma_linear_resampler_set_rate((ma_linear_resampler*)pBackend, sampleRateIn, sampleRateOut); -} - -static ma_uint64 ma_resampling_backend_get_input_latency__linear(void* pUserData, const ma_resampling_backend* pBackend) -{ - (void)pUserData; - - return ma_linear_resampler_get_input_latency((const ma_linear_resampler*)pBackend); -} - -static ma_uint64 ma_resampling_backend_get_output_latency__linear(void* pUserData, const ma_resampling_backend* pBackend) -{ - (void)pUserData; - - return ma_linear_resampler_get_output_latency((const ma_linear_resampler*)pBackend); -} - -static ma_result ma_resampling_backend_get_required_input_frame_count__linear(void* pUserData, const ma_resampling_backend* pBackend, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount) -{ - (void)pUserData; - - return ma_linear_resampler_get_required_input_frame_count((const ma_linear_resampler*)pBackend, outputFrameCount, pInputFrameCount); -} - -static ma_result ma_resampling_backend_get_expected_output_frame_count__linear(void* pUserData, const ma_resampling_backend* pBackend, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount) -{ - (void)pUserData; - - return ma_linear_resampler_get_expected_output_frame_count((const ma_linear_resampler*)pBackend, inputFrameCount, pOutputFrameCount); -} - -static ma_result ma_resampling_backend_reset__linear(void* pUserData, ma_resampling_backend* pBackend) -{ - (void)pUserData; - - return ma_linear_resampler_reset((ma_linear_resampler*)pBackend); -} - -static ma_resampling_backend_vtable g_ma_linear_resampler_vtable = -{ - ma_resampling_backend_get_heap_size__linear, - ma_resampling_backend_init__linear, - ma_resampling_backend_uninit__linear, - ma_resampling_backend_process__linear, - ma_resampling_backend_set_rate__linear, - ma_resampling_backend_get_input_latency__linear, - ma_resampling_backend_get_output_latency__linear, - ma_resampling_backend_get_required_input_frame_count__linear, - ma_resampling_backend_get_expected_output_frame_count__linear, - ma_resampling_backend_reset__linear -}; - - - -MA_API ma_resampler_config ma_resampler_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut, ma_resample_algorithm algorithm) -{ - ma_resampler_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRateIn = sampleRateIn; - config.sampleRateOut = sampleRateOut; - config.algorithm = algorithm; - - /* Linear. */ - config.linear.lpfOrder = ma_min(MA_DEFAULT_RESAMPLER_LPF_ORDER, MA_MAX_FILTER_ORDER); - - return config; -} - -static ma_result ma_resampler_get_vtable(const ma_resampler_config* pConfig, ma_resampler* pResampler, ma_resampling_backend_vtable** ppVTable, void** ppUserData) -{ - MA_ASSERT(pConfig != NULL); - MA_ASSERT(ppVTable != NULL); - MA_ASSERT(ppUserData != NULL); - - /* Safety. */ - *ppVTable = NULL; - *ppUserData = NULL; - - switch (pConfig->algorithm) - { - case ma_resample_algorithm_linear: - { - *ppVTable = &g_ma_linear_resampler_vtable; - *ppUserData = pResampler; - } break; - - case ma_resample_algorithm_custom: - { - *ppVTable = pConfig->pBackendVTable; - *ppUserData = pConfig->pBackendUserData; - } break; - - default: return MA_INVALID_ARGS; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_resampler_get_heap_size(const ma_resampler_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_resampling_backend_vtable* pVTable; - void* pVTableUserData; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_resampler_get_vtable(pConfig, NULL, &pVTable, &pVTableUserData); - if (result != MA_SUCCESS) { - return result; - } - - if (pVTable == NULL || pVTable->onGetHeapSize == NULL) { - return MA_NOT_IMPLEMENTED; - } - - result = pVTable->onGetHeapSize(pVTableUserData, pConfig, pHeapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_resampler_init_preallocated(const ma_resampler_config* pConfig, void* pHeap, ma_resampler* pResampler) -{ - ma_result result; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pResampler); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - pResampler->_pHeap = pHeap; - pResampler->format = pConfig->format; - pResampler->channels = pConfig->channels; - pResampler->sampleRateIn = pConfig->sampleRateIn; - pResampler->sampleRateOut = pConfig->sampleRateOut; - - result = ma_resampler_get_vtable(pConfig, pResampler, &pResampler->pBackendVTable, &pResampler->pBackendUserData); - if (result != MA_SUCCESS) { - return result; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onInit == NULL) { - return MA_NOT_IMPLEMENTED; /* onInit not implemented. */ - } - - result = pResampler->pBackendVTable->onInit(pResampler->pBackendUserData, pConfig, pHeap, &pResampler->pBackend); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_resampler_init(const ma_resampler_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_resampler* pResampler) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_resampler_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_resampler_init_preallocated(pConfig, pHeap, pResampler); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pResampler->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_resampler_uninit(ma_resampler* pResampler, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pResampler == NULL) { - return; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onUninit == NULL) { - return; - } - - pResampler->pBackendVTable->onUninit(pResampler->pBackendUserData, pResampler->pBackend, pAllocationCallbacks); - - if (pResampler->_ownsHeap) { - ma_free(pResampler->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_resampler_process_pcm_frames(ma_resampler* pResampler, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (pFrameCountOut == NULL && pFrameCountIn == NULL) { - return MA_INVALID_ARGS; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onProcess == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pResampler->pBackendVTable->onProcess(pResampler->pBackendUserData, pResampler->pBackend, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); -} - -MA_API ma_result ma_resampler_set_rate(ma_resampler* pResampler, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut) -{ - ma_result result; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (sampleRateIn == 0 || sampleRateOut == 0) { - return MA_INVALID_ARGS; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onSetRate == NULL) { - return MA_NOT_IMPLEMENTED; - } - - result = pResampler->pBackendVTable->onSetRate(pResampler->pBackendUserData, pResampler->pBackend, sampleRateIn, sampleRateOut); - if (result != MA_SUCCESS) { - return result; - } - - pResampler->sampleRateIn = sampleRateIn; - pResampler->sampleRateOut = sampleRateOut; - - return MA_SUCCESS; -} - -MA_API ma_result ma_resampler_set_rate_ratio(ma_resampler* pResampler, float ratio) -{ - ma_uint32 n; - ma_uint32 d; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (ratio <= 0) { - return MA_INVALID_ARGS; - } - - d = 1000; - n = (ma_uint32)(ratio * d); - - if (n == 0) { - return MA_INVALID_ARGS; /* Ratio too small. */ - } - - MA_ASSERT(n != 0); - - return ma_resampler_set_rate(pResampler, n, d); -} - -MA_API ma_uint64 ma_resampler_get_input_latency(const ma_resampler* pResampler) -{ - if (pResampler == NULL) { - return 0; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onGetInputLatency == NULL) { - return 0; - } - - return pResampler->pBackendVTable->onGetInputLatency(pResampler->pBackendUserData, pResampler->pBackend); -} - -MA_API ma_uint64 ma_resampler_get_output_latency(const ma_resampler* pResampler) -{ - if (pResampler == NULL) { - return 0; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onGetOutputLatency == NULL) { - return 0; - } - - return pResampler->pBackendVTable->onGetOutputLatency(pResampler->pBackendUserData, pResampler->pBackend); -} - -MA_API ma_result ma_resampler_get_required_input_frame_count(const ma_resampler* pResampler, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount) -{ - if (pInputFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - *pInputFrameCount = 0; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onGetRequiredInputFrameCount == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pResampler->pBackendVTable->onGetRequiredInputFrameCount(pResampler->pBackendUserData, pResampler->pBackend, outputFrameCount, pInputFrameCount); -} - -MA_API ma_result ma_resampler_get_expected_output_frame_count(const ma_resampler* pResampler, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount) -{ - if (pOutputFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - *pOutputFrameCount = 0; - - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onGetExpectedOutputFrameCount == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pResampler->pBackendVTable->onGetExpectedOutputFrameCount(pResampler->pBackendUserData, pResampler->pBackend, inputFrameCount, pOutputFrameCount); -} - -MA_API ma_result ma_resampler_reset(ma_resampler* pResampler) -{ - if (pResampler == NULL) { - return MA_INVALID_ARGS; - } - - if (pResampler->pBackendVTable == NULL || pResampler->pBackendVTable->onReset == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pResampler->pBackendVTable->onReset(pResampler->pBackendUserData, pResampler->pBackend); -} - -/************************************************************************************************************************************************************** - -Channel Conversion - -**************************************************************************************************************************************************************/ -#ifndef MA_CHANNEL_CONVERTER_FIXED_POINT_SHIFT -#define MA_CHANNEL_CONVERTER_FIXED_POINT_SHIFT 12 -#endif - -#define MA_PLANE_LEFT 0 -#define MA_PLANE_RIGHT 1 -#define MA_PLANE_FRONT 2 -#define MA_PLANE_BACK 3 -#define MA_PLANE_BOTTOM 4 -#define MA_PLANE_TOP 5 - -static float g_maChannelPlaneRatios[MA_CHANNEL_POSITION_COUNT][6] = { - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_NONE */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_MONO */ - { 0.5f, 0.0f, 0.5f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_FRONT_LEFT */ - { 0.0f, 0.5f, 0.5f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_FRONT_RIGHT */ - { 0.0f, 0.0f, 1.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_FRONT_CENTER */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_LFE */ - { 0.5f, 0.0f, 0.0f, 0.5f, 0.0f, 0.0f}, /* MA_CHANNEL_BACK_LEFT */ - { 0.0f, 0.5f, 0.0f, 0.5f, 0.0f, 0.0f}, /* MA_CHANNEL_BACK_RIGHT */ - { 0.25f, 0.0f, 0.75f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_FRONT_LEFT_CENTER */ - { 0.0f, 0.25f, 0.75f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_FRONT_RIGHT_CENTER */ - { 0.0f, 0.0f, 0.0f, 1.0f, 0.0f, 0.0f}, /* MA_CHANNEL_BACK_CENTER */ - { 1.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_SIDE_LEFT */ - { 0.0f, 1.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_SIDE_RIGHT */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 1.0f}, /* MA_CHANNEL_TOP_CENTER */ - { 0.33f, 0.0f, 0.33f, 0.0f, 0.0f, 0.34f}, /* MA_CHANNEL_TOP_FRONT_LEFT */ - { 0.0f, 0.0f, 0.5f, 0.0f, 0.0f, 0.5f}, /* MA_CHANNEL_TOP_FRONT_CENTER */ - { 0.0f, 0.33f, 0.33f, 0.0f, 0.0f, 0.34f}, /* MA_CHANNEL_TOP_FRONT_RIGHT */ - { 0.33f, 0.0f, 0.0f, 0.33f, 0.0f, 0.34f}, /* MA_CHANNEL_TOP_BACK_LEFT */ - { 0.0f, 0.0f, 0.0f, 0.5f, 0.0f, 0.5f}, /* MA_CHANNEL_TOP_BACK_CENTER */ - { 0.0f, 0.33f, 0.0f, 0.33f, 0.0f, 0.34f}, /* MA_CHANNEL_TOP_BACK_RIGHT */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_0 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_1 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_2 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_3 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_4 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_5 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_6 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_7 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_8 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_9 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_10 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_11 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_12 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_13 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_14 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_15 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_16 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_17 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_18 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_19 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_20 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_21 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_22 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_23 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_24 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_25 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_26 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_27 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_28 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_29 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_30 */ - { 0.0f, 0.0f, 0.0f, 0.0f, 0.0f, 0.0f}, /* MA_CHANNEL_AUX_31 */ -}; - -static float ma_calculate_channel_position_rectangular_weight(ma_channel channelPositionA, ma_channel channelPositionB) -{ - /* - Imagine the following simplified example: You have a single input speaker which is the front/left speaker which you want to convert to - the following output configuration: - - - front/left - - side/left - - back/left - - The front/left output is easy - it the same speaker position so it receives the full contribution of the front/left input. The amount - of contribution to apply to the side/left and back/left speakers, however, is a bit more complicated. - - Imagine the front/left speaker as emitting audio from two planes - the front plane and the left plane. You can think of the front/left - speaker emitting half of it's total volume from the front, and the other half from the left. Since part of it's volume is being emitted - from the left side, and the side/left and back/left channels also emit audio from the left plane, one would expect that they would - receive some amount of contribution from front/left speaker. The amount of contribution depends on how many planes are shared between - the two speakers. Note that in the examples below I've added a top/front/left speaker as an example just to show how the math works - across 3 spatial dimensions. - - The first thing to do is figure out how each speaker's volume is spread over each of plane: - - front/left: 2 planes (front and left) = 1/2 = half it's total volume on each plane - - side/left: 1 plane (left only) = 1/1 = entire volume from left plane - - back/left: 2 planes (back and left) = 1/2 = half it's total volume on each plane - - top/front/left: 3 planes (top, front and left) = 1/3 = one third it's total volume on each plane - - The amount of volume each channel contributes to each of it's planes is what controls how much it is willing to given and take to other - channels on the same plane. The volume that is willing to the given by one channel is multiplied by the volume that is willing to be - taken by the other to produce the final contribution. - */ - - /* Contribution = Sum(Volume to Give * Volume to Take) */ - float contribution = - g_maChannelPlaneRatios[channelPositionA][0] * g_maChannelPlaneRatios[channelPositionB][0] + - g_maChannelPlaneRatios[channelPositionA][1] * g_maChannelPlaneRatios[channelPositionB][1] + - g_maChannelPlaneRatios[channelPositionA][2] * g_maChannelPlaneRatios[channelPositionB][2] + - g_maChannelPlaneRatios[channelPositionA][3] * g_maChannelPlaneRatios[channelPositionB][3] + - g_maChannelPlaneRatios[channelPositionA][4] * g_maChannelPlaneRatios[channelPositionB][4] + - g_maChannelPlaneRatios[channelPositionA][5] * g_maChannelPlaneRatios[channelPositionB][5]; - - return contribution; -} - -MA_API ma_channel_converter_config ma_channel_converter_config_init(ma_format format, ma_uint32 channelsIn, const ma_channel* pChannelMapIn, ma_uint32 channelsOut, const ma_channel* pChannelMapOut, ma_channel_mix_mode mixingMode) -{ - ma_channel_converter_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channelsIn = channelsIn; - config.channelsOut = channelsOut; - config.pChannelMapIn = pChannelMapIn; - config.pChannelMapOut = pChannelMapOut; - config.mixingMode = mixingMode; - - return config; -} - -static ma_int32 ma_channel_converter_float_to_fixed(float x) -{ - return (ma_int32)(x * (1< 0); - - for (iChannel = 0; iChannel < channels; ++iChannel) { - if (ma_is_spatial_channel_position(ma_channel_map_get_channel(pChannelMap, channels, iChannel))) { - spatialChannelCount++; - } - } - - return spatialChannelCount; -} - -static ma_bool32 ma_is_spatial_channel_position(ma_channel channelPosition) -{ - int i; - - if (channelPosition == MA_CHANNEL_NONE || channelPosition == MA_CHANNEL_MONO || channelPosition == MA_CHANNEL_LFE) { - return MA_FALSE; - } - - if (channelPosition >= MA_CHANNEL_AUX_0 && channelPosition <= MA_CHANNEL_AUX_31) { - return MA_FALSE; - } - - for (i = 0; i < 6; ++i) { /* Each side of a cube. */ - if (g_maChannelPlaneRatios[channelPosition][i] != 0) { - return MA_TRUE; - } - } - - return MA_FALSE; -} - - -static ma_bool32 ma_channel_map_is_passthrough(const ma_channel* pChannelMapIn, ma_uint32 channelsIn, const ma_channel* pChannelMapOut, ma_uint32 channelsOut) -{ - if (channelsOut == channelsIn) { - return ma_channel_map_is_equal(pChannelMapOut, pChannelMapIn, channelsOut); - } else { - return MA_FALSE; /* Channel counts differ, so cannot be a passthrough. */ - } -} - -static ma_channel_conversion_path ma_channel_map_get_conversion_path(const ma_channel* pChannelMapIn, ma_uint32 channelsIn, const ma_channel* pChannelMapOut, ma_uint32 channelsOut, ma_channel_mix_mode mode) -{ - if (ma_channel_map_is_passthrough(pChannelMapIn, channelsIn, pChannelMapOut, channelsOut)) { - return ma_channel_conversion_path_passthrough; - } - - if (channelsOut == 1 && (pChannelMapOut == NULL || pChannelMapOut[0] == MA_CHANNEL_MONO)) { - return ma_channel_conversion_path_mono_out; - } - - if (channelsIn == 1 && (pChannelMapIn == NULL || pChannelMapIn[0] == MA_CHANNEL_MONO)) { - return ma_channel_conversion_path_mono_in; - } - - if (mode == ma_channel_mix_mode_custom_weights) { - return ma_channel_conversion_path_weights; - } - - /* - We can use a simple shuffle if both channel maps have the same channel count and all channel - positions are present in both. - */ - if (channelsIn == channelsOut) { - ma_uint32 iChannelIn; - ma_bool32 areAllChannelPositionsPresent = MA_TRUE; - for (iChannelIn = 0; iChannelIn < channelsIn; ++iChannelIn) { - ma_bool32 isInputChannelPositionInOutput = MA_FALSE; - if (ma_channel_map_contains_channel_position(channelsOut, pChannelMapOut, ma_channel_map_get_channel(pChannelMapIn, channelsIn, iChannelIn))) { - isInputChannelPositionInOutput = MA_TRUE; - break; - } - - if (!isInputChannelPositionInOutput) { - areAllChannelPositionsPresent = MA_FALSE; - break; - } - } - - if (areAllChannelPositionsPresent) { - return ma_channel_conversion_path_shuffle; - } - } - - /* Getting here means we'll need to use weights. */ - return ma_channel_conversion_path_weights; -} - - -static ma_result ma_channel_map_build_shuffle_table(const ma_channel* pChannelMapIn, ma_uint32 channelCountIn, const ma_channel* pChannelMapOut, ma_uint32 channelCountOut, ma_uint8* pShuffleTable) -{ - ma_uint32 iChannelIn; - ma_uint32 iChannelOut; - - if (pShuffleTable == NULL || channelCountIn == 0 || channelCountOut == 0) { - return MA_INVALID_ARGS; - } - - /* - When building the shuffle table we just do a 1:1 mapping based on the first occurance of a channel. If the - input channel has more than one occurance of a channel position, the second one will be ignored. - */ - for (iChannelOut = 0; iChannelOut < channelCountOut; iChannelOut += 1) { - ma_channel channelOut; - - /* Default to MA_CHANNEL_INDEX_NULL so that if a mapping is not found it'll be set appropriately. */ - pShuffleTable[iChannelOut] = MA_CHANNEL_INDEX_NULL; - - channelOut = ma_channel_map_get_channel(pChannelMapOut, channelCountOut, iChannelOut); - for (iChannelIn = 0; iChannelIn < channelCountIn; iChannelIn += 1) { - ma_channel channelIn; - - channelIn = ma_channel_map_get_channel(pChannelMapIn, channelCountIn, iChannelIn); - if (channelOut == channelIn) { - pShuffleTable[iChannelOut] = (ma_uint8)iChannelIn; - break; - } - - /* - Getting here means the channels don't exactly match, but we are going to support some - relaxed matching for practicality. If, for example, there are two stereo channel maps, - but one uses front left/right and the other uses side left/right, it makes logical - sense to just map these. The way we'll do it is we'll check if there is a logical - corresponding mapping, and if so, apply it, but we will *not* break from the loop, - thereby giving the loop a chance to find an exact match later which will take priority. - */ - switch (channelOut) - { - /* Left channels. */ - case MA_CHANNEL_FRONT_LEFT: - case MA_CHANNEL_SIDE_LEFT: - { - switch (channelIn) { - case MA_CHANNEL_FRONT_LEFT: - case MA_CHANNEL_SIDE_LEFT: - { - pShuffleTable[iChannelOut] = (ma_uint8)iChannelIn; - } break; - } - } break; - - /* Right channels. */ - case MA_CHANNEL_FRONT_RIGHT: - case MA_CHANNEL_SIDE_RIGHT: - { - switch (channelIn) { - case MA_CHANNEL_FRONT_RIGHT: - case MA_CHANNEL_SIDE_RIGHT: - { - pShuffleTable[iChannelOut] = (ma_uint8)iChannelIn; - } break; - } - } break; - - default: break; - } - } - } - - return MA_SUCCESS; -} - - -static void ma_channel_map_apply_shuffle_table_u8(ma_uint8* pFramesOut, ma_uint32 channelsOut, const ma_uint8* pFramesIn, ma_uint32 channelsIn, ma_uint64 frameCount, const ma_uint8* pShuffleTable) -{ - ma_uint64 iFrame; - ma_uint32 iChannelOut; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_uint8 iChannelIn = pShuffleTable[iChannelOut]; - if (iChannelIn < channelsIn) { /* For safety, and to deal with MA_CHANNEL_INDEX_NULL. */ - pFramesOut[iChannelOut] = pFramesIn[iChannelIn]; - } else { - pFramesOut[iChannelOut] = 0; - } - } - - pFramesOut += channelsOut; - pFramesIn += channelsIn; - } -} - -static void ma_channel_map_apply_shuffle_table_s16(ma_int16* pFramesOut, ma_uint32 channelsOut, const ma_int16* pFramesIn, ma_uint32 channelsIn, ma_uint64 frameCount, const ma_uint8* pShuffleTable) -{ - ma_uint64 iFrame; - ma_uint32 iChannelOut; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_uint8 iChannelIn = pShuffleTable[iChannelOut]; - if (iChannelIn < channelsIn) { /* For safety, and to deal with MA_CHANNEL_INDEX_NULL. */ - pFramesOut[iChannelOut] = pFramesIn[iChannelIn]; - } else { - pFramesOut[iChannelOut] = 0; - } - } - - pFramesOut += channelsOut; - pFramesIn += channelsIn; - } -} - -static void ma_channel_map_apply_shuffle_table_s24(ma_uint8* pFramesOut, ma_uint32 channelsOut, const ma_uint8* pFramesIn, ma_uint32 channelsIn, ma_uint64 frameCount, const ma_uint8* pShuffleTable) -{ - ma_uint64 iFrame; - ma_uint32 iChannelOut; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_uint8 iChannelIn = pShuffleTable[iChannelOut]; - if (iChannelIn < channelsIn) { /* For safety, and to deal with MA_CHANNEL_INDEX_NULL. */ - pFramesOut[iChannelOut*3 + 0] = pFramesIn[iChannelIn*3 + 0]; - pFramesOut[iChannelOut*3 + 1] = pFramesIn[iChannelIn*3 + 1]; - pFramesOut[iChannelOut*3 + 2] = pFramesIn[iChannelIn*3 + 2]; - } else { - pFramesOut[iChannelOut*3 + 0] = 0; - } pFramesOut[iChannelOut*3 + 1] = 0; - } pFramesOut[iChannelOut*3 + 2] = 0; - - pFramesOut += channelsOut*3; - pFramesIn += channelsIn*3; - } -} - -static void ma_channel_map_apply_shuffle_table_s32(ma_int32* pFramesOut, ma_uint32 channelsOut, const ma_int32* pFramesIn, ma_uint32 channelsIn, ma_uint64 frameCount, const ma_uint8* pShuffleTable) -{ - ma_uint64 iFrame; - ma_uint32 iChannelOut; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_uint8 iChannelIn = pShuffleTable[iChannelOut]; - if (iChannelIn < channelsIn) { /* For safety, and to deal with MA_CHANNEL_INDEX_NULL. */ - pFramesOut[iChannelOut] = pFramesIn[iChannelIn]; - } else { - pFramesOut[iChannelOut] = 0; - } - } - - pFramesOut += channelsOut; - pFramesIn += channelsIn; - } -} - -static void ma_channel_map_apply_shuffle_table_f32(float* pFramesOut, ma_uint32 channelsOut, const float* pFramesIn, ma_uint32 channelsIn, ma_uint64 frameCount, const ma_uint8* pShuffleTable) -{ - ma_uint64 iFrame; - ma_uint32 iChannelOut; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_uint8 iChannelIn = pShuffleTable[iChannelOut]; - if (iChannelIn < channelsIn) { /* For safety, and to deal with MA_CHANNEL_INDEX_NULL. */ - pFramesOut[iChannelOut] = pFramesIn[iChannelIn]; - } else { - pFramesOut[iChannelOut] = 0; - } - } - - pFramesOut += channelsOut; - pFramesIn += channelsIn; - } -} - -static ma_result ma_channel_map_apply_shuffle_table(void* pFramesOut, ma_uint32 channelsOut, const void* pFramesIn, ma_uint32 channelsIn, ma_uint64 frameCount, const ma_uint8* pShuffleTable, ma_format format) -{ - if (pFramesOut == NULL || pFramesIn == NULL || channelsOut == 0 || pShuffleTable == NULL) { - return MA_INVALID_ARGS; - } - - switch (format) - { - case ma_format_u8: - { - ma_channel_map_apply_shuffle_table_u8((ma_uint8*)pFramesOut, channelsOut, (const ma_uint8*)pFramesIn, channelsIn, frameCount, pShuffleTable); - } break; - - case ma_format_s16: - { - ma_channel_map_apply_shuffle_table_s16((ma_int16*)pFramesOut, channelsOut, (const ma_int16*)pFramesIn, channelsIn, frameCount, pShuffleTable); - } break; - - case ma_format_s24: - { - ma_channel_map_apply_shuffle_table_s24((ma_uint8*)pFramesOut, channelsOut, (const ma_uint8*)pFramesIn, channelsIn, frameCount, pShuffleTable); - } break; - - case ma_format_s32: - { - ma_channel_map_apply_shuffle_table_s32((ma_int32*)pFramesOut, channelsOut, (const ma_int32*)pFramesIn, channelsIn, frameCount, pShuffleTable); - } break; - - case ma_format_f32: - { - ma_channel_map_apply_shuffle_table_f32((float*)pFramesOut, channelsOut, (const float*)pFramesIn, channelsIn, frameCount, pShuffleTable); - } break; - - default: return MA_INVALID_ARGS; /* Unknown format. */ - } - - return MA_SUCCESS; -} - -static ma_result ma_channel_map_apply_mono_out_f32(float* pFramesOut, const float* pFramesIn, const ma_channel* pChannelMapIn, ma_uint32 channelsIn, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint32 iChannelIn; - ma_uint32 accumulationCount; - - if (pFramesOut == NULL || pFramesIn == NULL || channelsIn == 0) { - return MA_INVALID_ARGS; - } - - /* In this case the output stream needs to be the average of all channels, ignoring NONE. */ - - /* A quick pre-processing step to get the accumulation counter since we're ignoring NONE channels. */ - accumulationCount = 0; - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - if (ma_channel_map_get_channel(pChannelMapIn, channelsIn, iChannelIn) != MA_CHANNEL_NONE) { - accumulationCount += 1; - } - } - - if (accumulationCount > 0) { /* <-- Prevent a division by zero. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float accumulation = 0; - - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - ma_channel channelIn = ma_channel_map_get_channel(pChannelMapIn, channelsIn, iChannelIn); - if (channelIn != MA_CHANNEL_NONE) { - accumulation += pFramesIn[iChannelIn]; - } - } - - pFramesOut[0] = accumulation / accumulationCount; - pFramesOut += 1; - pFramesIn += channelsIn; - } - } else { - ma_silence_pcm_frames(pFramesOut, frameCount, ma_format_f32, 1); - } - - return MA_SUCCESS; -} - -static ma_result ma_channel_map_apply_mono_in_f32(float* MA_RESTRICT pFramesOut, const ma_channel* pChannelMapOut, ma_uint32 channelsOut, const float* MA_RESTRICT pFramesIn, ma_uint64 frameCount, ma_mono_expansion_mode monoExpansionMode) -{ - ma_uint64 iFrame; - ma_uint32 iChannelOut; - - if (pFramesOut == NULL || channelsOut == 0 || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - /* Note that the MA_CHANNEL_NONE channel must be ignored in all cases. */ - switch (monoExpansionMode) - { - case ma_mono_expansion_mode_average: - { - float weight; - ma_uint32 validChannelCount = 0; - - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelOut != MA_CHANNEL_NONE) { - validChannelCount += 1; - } - } - - weight = 1.0f / validChannelCount; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelOut != MA_CHANNEL_NONE) { - pFramesOut[iChannelOut] = pFramesIn[0] * weight; - } - } - - pFramesOut += channelsOut; - pFramesIn += 1; - } - } break; - - case ma_mono_expansion_mode_stereo_only: - { - if (channelsOut >= 2) { - ma_uint32 iChannelLeft = (ma_uint32)-1; - ma_uint32 iChannelRight = (ma_uint32)-1; - - /* - We first need to find our stereo channels. We prefer front-left and front-right, but - if they're not available, we'll also try side-left and side-right. If neither are - available we'll fall through to the default case below. - */ - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelOut == MA_CHANNEL_SIDE_LEFT) { - iChannelLeft = iChannelOut; - } - if (channelOut == MA_CHANNEL_SIDE_RIGHT) { - iChannelRight = iChannelOut; - } - } - - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelOut == MA_CHANNEL_FRONT_LEFT) { - iChannelLeft = iChannelOut; - } - if (channelOut == MA_CHANNEL_FRONT_RIGHT) { - iChannelRight = iChannelOut; - } - } - - - if (iChannelLeft != (ma_uint32)-1 && iChannelRight != (ma_uint32)-1) { - /* We found our stereo channels so we can duplicate the signal across those channels. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelOut != MA_CHANNEL_NONE) { - if (iChannelOut == iChannelLeft || iChannelOut == iChannelRight) { - pFramesOut[iChannelOut] = pFramesIn[0]; - } else { - pFramesOut[iChannelOut] = 0.0f; - } - } - } - - pFramesOut += channelsOut; - pFramesIn += 1; - } - - break; /* Get out of the switch. */ - } else { - /* Fallthrough. Does not have left and right channels. */ - goto default_handler; - } - } else { - /* Fallthrough. Does not have stereo channels. */ - goto default_handler; - } - }; /* Fallthrough. See comments above. */ - - case ma_mono_expansion_mode_duplicate: - default: - { - default_handler: - { - if (channelsOut <= MA_MAX_CHANNELS) { - ma_bool32 hasEmptyChannel = MA_FALSE; - ma_channel channelPositions[MA_MAX_CHANNELS]; - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - channelPositions[iChannelOut] = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelPositions[iChannelOut] == MA_CHANNEL_NONE) { - hasEmptyChannel = MA_TRUE; - } - } - - if (hasEmptyChannel == MA_FALSE) { - /* - Faster path when there's no MA_CHANNEL_NONE channel positions. This should hopefully - help the compiler with auto-vectorization.m - */ - if (channelsOut == 2) { - #if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - /* We want to do two frames in each iteration. */ - ma_uint64 unrolledFrameCount = frameCount >> 1; - - for (iFrame = 0; iFrame < unrolledFrameCount; iFrame += 1) { - __m128 in0 = _mm_set1_ps(pFramesIn[iFrame*2 + 0]); - __m128 in1 = _mm_set1_ps(pFramesIn[iFrame*2 + 1]); - _mm_storeu_ps(&pFramesOut[iFrame*4 + 0], _mm_shuffle_ps(in1, in0, _MM_SHUFFLE(0, 0, 0, 0))); - } - - /* Tail. */ - iFrame = unrolledFrameCount << 1; - goto generic_on_fastpath; - } else - #endif - { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < 2; iChannelOut += 1) { - pFramesOut[iFrame*2 + iChannelOut] = pFramesIn[iFrame]; - } - } - } - } else if (channelsOut == 6) { - #if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - /* We want to do two frames in each iteration so we can have a multiple of 4 samples. */ - ma_uint64 unrolledFrameCount = frameCount >> 1; - - for (iFrame = 0; iFrame < unrolledFrameCount; iFrame += 1) { - __m128 in0 = _mm_set1_ps(pFramesIn[iFrame*2 + 0]); - __m128 in1 = _mm_set1_ps(pFramesIn[iFrame*2 + 1]); - - _mm_storeu_ps(&pFramesOut[iFrame*12 + 0], in0); - _mm_storeu_ps(&pFramesOut[iFrame*12 + 4], _mm_shuffle_ps(in1, in0, _MM_SHUFFLE(0, 0, 0, 0))); - _mm_storeu_ps(&pFramesOut[iFrame*12 + 8], in1); - } - - /* Tail. */ - iFrame = unrolledFrameCount << 1; - goto generic_on_fastpath; - } else - #endif - { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < 6; iChannelOut += 1) { - pFramesOut[iFrame*6 + iChannelOut] = pFramesIn[iFrame]; - } - } - } - } else if (channelsOut == 8) { - #if defined(MA_SUPPORT_SSE2) - if (ma_has_sse2()) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - __m128 in = _mm_set1_ps(pFramesIn[iFrame]); - _mm_storeu_ps(&pFramesOut[iFrame*8 + 0], in); - _mm_storeu_ps(&pFramesOut[iFrame*8 + 4], in); - } - } else - #endif - { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < 8; iChannelOut += 1) { - pFramesOut[iFrame*8 + iChannelOut] = pFramesIn[iFrame]; - } - } - } - } else { - iFrame = 0; - - #if defined(MA_SUPPORT_SSE2) /* For silencing a warning with non-x86 builds. */ - generic_on_fastpath: - #endif - { - for (; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - pFramesOut[iFrame*channelsOut + iChannelOut] = pFramesIn[iFrame]; - } - } - } - } - } else { - /* Slow path. Need to handle MA_CHANNEL_NONE. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - if (channelPositions[iChannelOut] != MA_CHANNEL_NONE) { - pFramesOut[iFrame*channelsOut + iChannelOut] = pFramesIn[iFrame]; - } - } - } - } - } else { - /* Slow path. Too many channels to store on the stack. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - if (channelOut != MA_CHANNEL_NONE) { - pFramesOut[iFrame*channelsOut + iChannelOut] = pFramesIn[iFrame]; - } - } - } - } - } - } break; - } - - return MA_SUCCESS; -} - -static void ma_channel_map_apply_f32(float* pFramesOut, const ma_channel* pChannelMapOut, ma_uint32 channelsOut, const float* pFramesIn, const ma_channel* pChannelMapIn, ma_uint32 channelsIn, ma_uint64 frameCount, ma_channel_mix_mode mode, ma_mono_expansion_mode monoExpansionMode) -{ - ma_channel_conversion_path conversionPath = ma_channel_map_get_conversion_path(pChannelMapIn, channelsIn, pChannelMapOut, channelsOut, mode); - - /* Optimized Path: Passthrough */ - if (conversionPath == ma_channel_conversion_path_passthrough) { - ma_copy_pcm_frames(pFramesOut, pFramesIn, frameCount, ma_format_f32, channelsOut); - return; - } - - /* Special Path: Mono Output. */ - if (conversionPath == ma_channel_conversion_path_mono_out) { - ma_channel_map_apply_mono_out_f32(pFramesOut, pFramesIn, pChannelMapIn, channelsIn, frameCount); - return; - } - - /* Special Path: Mono Input. */ - if (conversionPath == ma_channel_conversion_path_mono_in) { - ma_channel_map_apply_mono_in_f32(pFramesOut, pChannelMapOut, channelsOut, pFramesIn, frameCount, monoExpansionMode); - return; - } - - /* Getting here means we aren't running on an optimized conversion path. */ - if (channelsOut <= MA_MAX_CHANNELS) { - ma_result result; - - if (mode == ma_channel_mix_mode_simple) { - ma_channel shuffleTable[MA_MAX_CHANNELS]; - - result = ma_channel_map_build_shuffle_table(pChannelMapIn, channelsIn, pChannelMapOut, channelsOut, shuffleTable); - if (result != MA_SUCCESS) { - return; - } - - result = ma_channel_map_apply_shuffle_table(pFramesOut, channelsOut, pFramesIn, channelsIn, frameCount, shuffleTable, ma_format_f32); - if (result != MA_SUCCESS) { - return; - } - } else { - ma_uint32 iFrame; - ma_uint32 iChannelOut; - ma_uint32 iChannelIn; - float weights[32][32]; /* Do not use MA_MAX_CHANNELS here! */ - - /* - If we have a small enough number of channels, pre-compute the weights. Otherwise we'll just need to - fall back to a slower path because otherwise we'll run out of stack space. - */ - if (channelsIn <= ma_countof(weights) && channelsOut <= ma_countof(weights)) { - /* Pre-compute weights. */ - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - ma_channel channelIn = ma_channel_map_get_channel(pChannelMapIn, channelsIn, iChannelIn); - weights[iChannelOut][iChannelIn] = ma_calculate_channel_position_rectangular_weight(channelOut, channelIn); - } - } - - iFrame = 0; - - /* Experiment: Try an optimized unroll for some specific cases to see how it improves performance. RESULT: Good gains. */ - if (channelsOut == 8) { - /* Experiment 2: Expand the inner loop to see what kind of different it makes. RESULT: Small, but worthwhile gain. */ - if (channelsIn == 2) { - for (; iFrame < frameCount; iFrame += 1) { - float accumulation[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }; - - accumulation[0] += pFramesIn[iFrame*2 + 0] * weights[0][0]; - accumulation[1] += pFramesIn[iFrame*2 + 0] * weights[1][0]; - accumulation[2] += pFramesIn[iFrame*2 + 0] * weights[2][0]; - accumulation[3] += pFramesIn[iFrame*2 + 0] * weights[3][0]; - accumulation[4] += pFramesIn[iFrame*2 + 0] * weights[4][0]; - accumulation[5] += pFramesIn[iFrame*2 + 0] * weights[5][0]; - accumulation[6] += pFramesIn[iFrame*2 + 0] * weights[6][0]; - accumulation[7] += pFramesIn[iFrame*2 + 0] * weights[7][0]; - - accumulation[0] += pFramesIn[iFrame*2 + 1] * weights[0][1]; - accumulation[1] += pFramesIn[iFrame*2 + 1] * weights[1][1]; - accumulation[2] += pFramesIn[iFrame*2 + 1] * weights[2][1]; - accumulation[3] += pFramesIn[iFrame*2 + 1] * weights[3][1]; - accumulation[4] += pFramesIn[iFrame*2 + 1] * weights[4][1]; - accumulation[5] += pFramesIn[iFrame*2 + 1] * weights[5][1]; - accumulation[6] += pFramesIn[iFrame*2 + 1] * weights[6][1]; - accumulation[7] += pFramesIn[iFrame*2 + 1] * weights[7][1]; - - pFramesOut[iFrame*8 + 0] = accumulation[0]; - pFramesOut[iFrame*8 + 1] = accumulation[1]; - pFramesOut[iFrame*8 + 2] = accumulation[2]; - pFramesOut[iFrame*8 + 3] = accumulation[3]; - pFramesOut[iFrame*8 + 4] = accumulation[4]; - pFramesOut[iFrame*8 + 5] = accumulation[5]; - pFramesOut[iFrame*8 + 6] = accumulation[6]; - pFramesOut[iFrame*8 + 7] = accumulation[7]; - } - } else { - /* When outputting to 8 channels, we can do everything in groups of two 4x SIMD operations. */ - for (; iFrame < frameCount; iFrame += 1) { - float accumulation[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }; - - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - accumulation[0] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[0][iChannelIn]; - accumulation[1] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[1][iChannelIn]; - accumulation[2] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[2][iChannelIn]; - accumulation[3] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[3][iChannelIn]; - accumulation[4] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[4][iChannelIn]; - accumulation[5] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[5][iChannelIn]; - accumulation[6] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[6][iChannelIn]; - accumulation[7] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[7][iChannelIn]; - } - - pFramesOut[iFrame*8 + 0] = accumulation[0]; - pFramesOut[iFrame*8 + 1] = accumulation[1]; - pFramesOut[iFrame*8 + 2] = accumulation[2]; - pFramesOut[iFrame*8 + 3] = accumulation[3]; - pFramesOut[iFrame*8 + 4] = accumulation[4]; - pFramesOut[iFrame*8 + 5] = accumulation[5]; - pFramesOut[iFrame*8 + 6] = accumulation[6]; - pFramesOut[iFrame*8 + 7] = accumulation[7]; - } - } - } else if (channelsOut == 6) { - /* - When outputting to 6 channels we unfortunately don't have a nice multiple of 4 to do 4x SIMD operations. Instead we'll - expand our weights and do two frames at a time. - */ - for (; iFrame < frameCount; iFrame += 1) { - float accumulation[12] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; - - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - accumulation[0] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[0][iChannelIn]; - accumulation[1] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[1][iChannelIn]; - accumulation[2] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[2][iChannelIn]; - accumulation[3] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[3][iChannelIn]; - accumulation[4] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[4][iChannelIn]; - accumulation[5] += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[5][iChannelIn]; - } - - pFramesOut[iFrame*6 + 0] = accumulation[0]; - pFramesOut[iFrame*6 + 1] = accumulation[1]; - pFramesOut[iFrame*6 + 2] = accumulation[2]; - pFramesOut[iFrame*6 + 3] = accumulation[3]; - pFramesOut[iFrame*6 + 4] = accumulation[4]; - pFramesOut[iFrame*6 + 5] = accumulation[5]; - } - } - - /* Leftover frames. */ - for (; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - float accumulation = 0; - - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - accumulation += pFramesIn[iFrame*channelsIn + iChannelIn] * weights[iChannelOut][iChannelIn]; - } - - pFramesOut[iFrame*channelsOut + iChannelOut] = accumulation; - } - } - } else { - /* Cannot pre-compute weights because not enough room in stack-allocated buffer. */ - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelOut = 0; iChannelOut < channelsOut; iChannelOut += 1) { - float accumulation = 0; - ma_channel channelOut = ma_channel_map_get_channel(pChannelMapOut, channelsOut, iChannelOut); - - for (iChannelIn = 0; iChannelIn < channelsIn; iChannelIn += 1) { - ma_channel channelIn = ma_channel_map_get_channel(pChannelMapIn, channelsIn, iChannelIn); - accumulation += pFramesIn[iFrame*channelsIn + iChannelIn] * ma_calculate_channel_position_rectangular_weight(channelOut, channelIn); - } - - pFramesOut[iFrame*channelsOut + iChannelOut] = accumulation; - } - } - } - } - } else { - /* Fall back to silence. If you hit this, what are you doing with so many channels?! */ - ma_silence_pcm_frames(pFramesOut, frameCount, ma_format_f32, channelsOut); - } -} - - -typedef struct -{ - size_t sizeInBytes; - size_t channelMapInOffset; - size_t channelMapOutOffset; - size_t shuffleTableOffset; - size_t weightsOffset; -} ma_channel_converter_heap_layout; - -static ma_channel_conversion_path ma_channel_converter_config_get_conversion_path(const ma_channel_converter_config* pConfig) -{ - return ma_channel_map_get_conversion_path(pConfig->pChannelMapIn, pConfig->channelsIn, pConfig->pChannelMapOut, pConfig->channelsOut, pConfig->mixingMode); -} - -static ma_result ma_channel_converter_get_heap_layout(const ma_channel_converter_config* pConfig, ma_channel_converter_heap_layout* pHeapLayout) -{ - ma_channel_conversion_path conversionPath; - - MA_ASSERT(pHeapLayout != NULL); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channelsIn == 0 || pConfig->channelsOut == 0) { - return MA_INVALID_ARGS; - } - - if (!ma_channel_map_is_valid(pConfig->pChannelMapIn, pConfig->channelsIn)) { - return MA_INVALID_ARGS; - } - - if (!ma_channel_map_is_valid(pConfig->pChannelMapOut, pConfig->channelsOut)) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Input channel map. Only need to allocate this if we have an input channel map (otherwise default channel map is assumed). */ - pHeapLayout->channelMapInOffset = pHeapLayout->sizeInBytes; - if (pConfig->pChannelMapIn != NULL) { - pHeapLayout->sizeInBytes += sizeof(ma_channel) * pConfig->channelsIn; - } - - /* Output channel map. Only need to allocate this if we have an output channel map (otherwise default channel map is assumed). */ - pHeapLayout->channelMapOutOffset = pHeapLayout->sizeInBytes; - if (pConfig->pChannelMapOut != NULL) { - pHeapLayout->sizeInBytes += sizeof(ma_channel) * pConfig->channelsOut; - } - - /* Alignment for the next section. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - /* Whether or not we use weights of a shuffle table depends on the channel map themselves and the algorithm we've chosen. */ - conversionPath = ma_channel_converter_config_get_conversion_path(pConfig); - - /* Shuffle table */ - pHeapLayout->shuffleTableOffset = pHeapLayout->sizeInBytes; - if (conversionPath == ma_channel_conversion_path_shuffle) { - pHeapLayout->sizeInBytes += sizeof(ma_uint8) * pConfig->channelsOut; - } - - /* Weights */ - pHeapLayout->weightsOffset = pHeapLayout->sizeInBytes; - if (conversionPath == ma_channel_conversion_path_weights) { - pHeapLayout->sizeInBytes += sizeof(float*) * pConfig->channelsIn; - pHeapLayout->sizeInBytes += sizeof(float ) * pConfig->channelsIn * pConfig->channelsOut; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_channel_converter_get_heap_size(const ma_channel_converter_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_channel_converter_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_channel_converter_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_channel_converter_init_preallocated(const ma_channel_converter_config* pConfig, void* pHeap, ma_channel_converter* pConverter) -{ - ma_result result; - ma_channel_converter_heap_layout heapLayout; - - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pConverter); - - result = ma_channel_converter_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pConverter->_pHeap = pHeap; - MA_ZERO_MEMORY(pConverter->_pHeap, heapLayout.sizeInBytes); - - pConverter->format = pConfig->format; - pConverter->channelsIn = pConfig->channelsIn; - pConverter->channelsOut = pConfig->channelsOut; - pConverter->mixingMode = pConfig->mixingMode; - - if (pConfig->pChannelMapIn != NULL) { - pConverter->pChannelMapIn = (ma_channel*)ma_offset_ptr(pHeap, heapLayout.channelMapInOffset); - ma_channel_map_copy_or_default(pConverter->pChannelMapIn, pConfig->channelsIn, pConfig->pChannelMapIn, pConfig->channelsIn); - } else { - pConverter->pChannelMapIn = NULL; /* Use default channel map. */ - } - - if (pConfig->pChannelMapOut != NULL) { - pConverter->pChannelMapOut = (ma_channel*)ma_offset_ptr(pHeap, heapLayout.channelMapOutOffset); - ma_channel_map_copy_or_default(pConverter->pChannelMapOut, pConfig->channelsOut, pConfig->pChannelMapOut, pConfig->channelsOut); - } else { - pConverter->pChannelMapOut = NULL; /* Use default channel map. */ - } - - pConverter->conversionPath = ma_channel_converter_config_get_conversion_path(pConfig); - - if (pConverter->conversionPath == ma_channel_conversion_path_shuffle) { - pConverter->pShuffleTable = (ma_uint8*)ma_offset_ptr(pHeap, heapLayout.shuffleTableOffset); - ma_channel_map_build_shuffle_table(pConverter->pChannelMapIn, pConverter->channelsIn, pConverter->pChannelMapOut, pConverter->channelsOut, pConverter->pShuffleTable); - } - - if (pConverter->conversionPath == ma_channel_conversion_path_weights) { - ma_uint32 iChannelIn; - ma_uint32 iChannelOut; - - if (pConverter->format == ma_format_f32) { - pConverter->weights.f32 = (float** )ma_offset_ptr(pHeap, heapLayout.weightsOffset); - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; iChannelIn += 1) { - pConverter->weights.f32[iChannelIn] = (float*)ma_offset_ptr(pHeap, heapLayout.weightsOffset + ((sizeof(float*) * pConverter->channelsIn) + (sizeof(float) * pConverter->channelsOut * iChannelIn))); - } - } else { - pConverter->weights.s16 = (ma_int32**)ma_offset_ptr(pHeap, heapLayout.weightsOffset); - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; iChannelIn += 1) { - pConverter->weights.s16[iChannelIn] = (ma_int32*)ma_offset_ptr(pHeap, heapLayout.weightsOffset + ((sizeof(ma_int32*) * pConverter->channelsIn) + (sizeof(ma_int32) * pConverter->channelsOut * iChannelIn))); - } - } - - /* Silence our weights by default. */ - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; iChannelIn += 1) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; iChannelOut += 1) { - if (pConverter->format == ma_format_f32) { - pConverter->weights.f32[iChannelIn][iChannelOut] = 0.0f; - } else { - pConverter->weights.s16[iChannelIn][iChannelOut] = 0; - } - } - } - - /* - We now need to fill out our weights table. This is determined by the mixing mode. - */ - - /* In all cases we need to make sure all channels that are present in both channel maps have a 1:1 mapping. */ - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - ma_channel channelPosIn = ma_channel_map_get_channel(pConverter->pChannelMapIn, pConverter->channelsIn, iChannelIn); - - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_channel channelPosOut = ma_channel_map_get_channel(pConverter->pChannelMapOut, pConverter->channelsOut, iChannelOut); - - if (channelPosIn == channelPosOut) { - float weight = 1; - - if (pConverter->format == ma_format_f32) { - pConverter->weights.f32[iChannelIn][iChannelOut] = weight; - } else { - pConverter->weights.s16[iChannelIn][iChannelOut] = ma_channel_converter_float_to_fixed(weight); - } - } - } - } - - switch (pConverter->mixingMode) - { - case ma_channel_mix_mode_custom_weights: - { - if (pConfig->ppWeights == NULL) { - return MA_INVALID_ARGS; /* Config specified a custom weights mixing mode, but no custom weights have been specified. */ - } - - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; iChannelIn += 1) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; iChannelOut += 1) { - float weight = pConfig->ppWeights[iChannelIn][iChannelOut]; - - if (pConverter->format == ma_format_f32) { - pConverter->weights.f32[iChannelIn][iChannelOut] = weight; - } else { - pConverter->weights.s16[iChannelIn][iChannelOut] = ma_channel_converter_float_to_fixed(weight); - } - } - } - } break; - - case ma_channel_mix_mode_simple: - { - /* - In simple mode, only set weights for channels that have exactly matching types, leave the rest at - zero. The 1:1 mappings have already been covered before this switch statement. - */ - } break; - - case ma_channel_mix_mode_rectangular: - default: - { - /* Unmapped input channels. */ - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - ma_channel channelPosIn = ma_channel_map_get_channel(pConverter->pChannelMapIn, pConverter->channelsIn, iChannelIn); - - if (ma_is_spatial_channel_position(channelPosIn)) { - if (!ma_channel_map_contains_channel_position(pConverter->channelsOut, pConverter->pChannelMapOut, channelPosIn)) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_channel channelPosOut = ma_channel_map_get_channel(pConverter->pChannelMapOut, pConverter->channelsOut, iChannelOut); - - if (ma_is_spatial_channel_position(channelPosOut)) { - float weight = 0; - if (pConverter->mixingMode == ma_channel_mix_mode_rectangular) { - weight = ma_calculate_channel_position_rectangular_weight(channelPosIn, channelPosOut); - } - - /* Only apply the weight if we haven't already got some contribution from the respective channels. */ - if (pConverter->format == ma_format_f32) { - if (pConverter->weights.f32[iChannelIn][iChannelOut] == 0) { - pConverter->weights.f32[iChannelIn][iChannelOut] = weight; - } - } else { - if (pConverter->weights.s16[iChannelIn][iChannelOut] == 0) { - pConverter->weights.s16[iChannelIn][iChannelOut] = ma_channel_converter_float_to_fixed(weight); - } - } - } - } - } - } - } - - /* Unmapped output channels. */ - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_channel channelPosOut = ma_channel_map_get_channel(pConverter->pChannelMapOut, pConverter->channelsOut, iChannelOut); - - if (ma_is_spatial_channel_position(channelPosOut)) { - if (!ma_channel_map_contains_channel_position(pConverter->channelsIn, pConverter->pChannelMapIn, channelPosOut)) { - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - ma_channel channelPosIn = ma_channel_map_get_channel(pConverter->pChannelMapIn, pConverter->channelsIn, iChannelIn); - - if (ma_is_spatial_channel_position(channelPosIn)) { - float weight = 0; - if (pConverter->mixingMode == ma_channel_mix_mode_rectangular) { - weight = ma_calculate_channel_position_rectangular_weight(channelPosIn, channelPosOut); - } - - /* Only apply the weight if we haven't already got some contribution from the respective channels. */ - if (pConverter->format == ma_format_f32) { - if (pConverter->weights.f32[iChannelIn][iChannelOut] == 0) { - pConverter->weights.f32[iChannelIn][iChannelOut] = weight; - } - } else { - if (pConverter->weights.s16[iChannelIn][iChannelOut] == 0) { - pConverter->weights.s16[iChannelIn][iChannelOut] = ma_channel_converter_float_to_fixed(weight); - } - } - } - } - } - } - } - - /* If LFE is in the output channel map but was not present in the input channel map, configure its weight now */ - if (pConfig->calculateLFEFromSpatialChannels) { - if (!ma_channel_map_contains_channel_position(pConverter->channelsIn, pConverter->pChannelMapIn, MA_CHANNEL_LFE)) { - ma_uint32 spatialChannelCount = ma_channel_map_get_spatial_channel_count(pConverter->pChannelMapIn, pConverter->channelsIn); - ma_uint32 iChannelOutLFE; - - if (spatialChannelCount > 0 && ma_channel_map_find_channel_position(pConverter->channelsOut, pConverter->pChannelMapOut, MA_CHANNEL_LFE, &iChannelOutLFE)) { - const float weightForLFE = 1.0f / spatialChannelCount; - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - const ma_channel channelPosIn = ma_channel_map_get_channel(pConverter->pChannelMapIn, pConverter->channelsIn, iChannelIn); - if (ma_is_spatial_channel_position(channelPosIn)) { - if (pConverter->format == ma_format_f32) { - if (pConverter->weights.f32[iChannelIn][iChannelOutLFE] == 0) { - pConverter->weights.f32[iChannelIn][iChannelOutLFE] = weightForLFE; - } - } else { - if (pConverter->weights.s16[iChannelIn][iChannelOutLFE] == 0) { - pConverter->weights.s16[iChannelIn][iChannelOutLFE] = ma_channel_converter_float_to_fixed(weightForLFE); - } - } - } - } - } - } - } - } break; - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_channel_converter_init(const ma_channel_converter_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_channel_converter* pConverter) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_channel_converter_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_channel_converter_init_preallocated(pConfig, pHeap, pConverter); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pConverter->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_channel_converter_uninit(ma_channel_converter* pConverter, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pConverter == NULL) { - return; - } - - if (pConverter->_ownsHeap) { - ma_free(pConverter->_pHeap, pAllocationCallbacks); - } -} - -static ma_result ma_channel_converter_process_pcm_frames__passthrough(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pFramesOut != NULL); - MA_ASSERT(pFramesIn != NULL); - - ma_copy_memory_64(pFramesOut, pFramesIn, frameCount * ma_get_bytes_per_frame(pConverter->format, pConverter->channelsOut)); - return MA_SUCCESS; -} - -static ma_result ma_channel_converter_process_pcm_frames__shuffle(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pFramesOut != NULL); - MA_ASSERT(pFramesIn != NULL); - MA_ASSERT(pConverter->channelsIn == pConverter->channelsOut); - - return ma_channel_map_apply_shuffle_table(pFramesOut, pConverter->channelsOut, pFramesIn, pConverter->channelsIn, frameCount, pConverter->pShuffleTable, pConverter->format); -} - -static ma_result ma_channel_converter_process_pcm_frames__mono_in(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pFramesOut != NULL); - MA_ASSERT(pFramesIn != NULL); - MA_ASSERT(pConverter->channelsIn == 1); - - switch (pConverter->format) - { - case ma_format_u8: - { - /* */ ma_uint8* pFramesOutU8 = ( ma_uint8*)pFramesOut; - const ma_uint8* pFramesInU8 = (const ma_uint8*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < pConverter->channelsOut; iChannel += 1) { - pFramesOutU8[iFrame*pConverter->channelsOut + iChannel] = pFramesInU8[iFrame]; - } - } - } break; - - case ma_format_s16: - { - /* */ ma_int16* pFramesOutS16 = ( ma_int16*)pFramesOut; - const ma_int16* pFramesInS16 = (const ma_int16*)pFramesIn; - - if (pConverter->channelsOut == 2) { - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - pFramesOutS16[iFrame*2 + 0] = pFramesInS16[iFrame]; - pFramesOutS16[iFrame*2 + 1] = pFramesInS16[iFrame]; - } - } else { - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < pConverter->channelsOut; iChannel += 1) { - pFramesOutS16[iFrame*pConverter->channelsOut + iChannel] = pFramesInS16[iFrame]; - } - } - } - } break; - - case ma_format_s24: - { - /* */ ma_uint8* pFramesOutS24 = ( ma_uint8*)pFramesOut; - const ma_uint8* pFramesInS24 = (const ma_uint8*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < pConverter->channelsOut; iChannel += 1) { - ma_uint64 iSampleOut = iFrame*pConverter->channelsOut + iChannel; - ma_uint64 iSampleIn = iFrame; - pFramesOutS24[iSampleOut*3 + 0] = pFramesInS24[iSampleIn*3 + 0]; - pFramesOutS24[iSampleOut*3 + 1] = pFramesInS24[iSampleIn*3 + 1]; - pFramesOutS24[iSampleOut*3 + 2] = pFramesInS24[iSampleIn*3 + 2]; - } - } - } break; - - case ma_format_s32: - { - /* */ ma_int32* pFramesOutS32 = ( ma_int32*)pFramesOut; - const ma_int32* pFramesInS32 = (const ma_int32*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < pConverter->channelsOut; iChannel += 1) { - pFramesOutS32[iFrame*pConverter->channelsOut + iChannel] = pFramesInS32[iFrame]; - } - } - } break; - - case ma_format_f32: - { - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - if (pConverter->channelsOut == 2) { - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - pFramesOutF32[iFrame*2 + 0] = pFramesInF32[iFrame]; - pFramesOutF32[iFrame*2 + 1] = pFramesInF32[iFrame]; - } - } else { - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < pConverter->channelsOut; iChannel += 1) { - pFramesOutF32[iFrame*pConverter->channelsOut + iChannel] = pFramesInF32[iFrame]; - } - } - } - } break; - - default: return MA_INVALID_OPERATION; /* Unknown format. */ - } - - return MA_SUCCESS; -} - -static ma_result ma_channel_converter_process_pcm_frames__mono_out(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint32 iChannel; - - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pFramesOut != NULL); - MA_ASSERT(pFramesIn != NULL); - MA_ASSERT(pConverter->channelsOut == 1); - - switch (pConverter->format) - { - case ma_format_u8: - { - /* */ ma_uint8* pFramesOutU8 = ( ma_uint8*)pFramesOut; - const ma_uint8* pFramesInU8 = (const ma_uint8*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_int32 t = 0; - for (iChannel = 0; iChannel < pConverter->channelsIn; iChannel += 1) { - t += ma_pcm_sample_u8_to_s16_no_scale(pFramesInU8[iFrame*pConverter->channelsIn + iChannel]); - } - - pFramesOutU8[iFrame] = ma_clip_u8(t / pConverter->channelsOut); - } - } break; - - case ma_format_s16: - { - /* */ ma_int16* pFramesOutS16 = ( ma_int16*)pFramesOut; - const ma_int16* pFramesInS16 = (const ma_int16*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_int32 t = 0; - for (iChannel = 0; iChannel < pConverter->channelsIn; iChannel += 1) { - t += pFramesInS16[iFrame*pConverter->channelsIn + iChannel]; - } - - pFramesOutS16[iFrame] = (ma_int16)(t / pConverter->channelsIn); - } - } break; - - case ma_format_s24: - { - /* */ ma_uint8* pFramesOutS24 = ( ma_uint8*)pFramesOut; - const ma_uint8* pFramesInS24 = (const ma_uint8*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_int64 t = 0; - for (iChannel = 0; iChannel < pConverter->channelsIn; iChannel += 1) { - t += ma_pcm_sample_s24_to_s32_no_scale(&pFramesInS24[(iFrame*pConverter->channelsIn + iChannel)*3]); - } - - ma_pcm_sample_s32_to_s24_no_scale(t / pConverter->channelsIn, &pFramesOutS24[iFrame*3]); - } - } break; - - case ma_format_s32: - { - /* */ ma_int32* pFramesOutS32 = ( ma_int32*)pFramesOut; - const ma_int32* pFramesInS32 = (const ma_int32*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - ma_int64 t = 0; - for (iChannel = 0; iChannel < pConverter->channelsIn; iChannel += 1) { - t += pFramesInS32[iFrame*pConverter->channelsIn + iChannel]; - } - - pFramesOutS32[iFrame] = (ma_int32)(t / pConverter->channelsIn); - } - } break; - - case ma_format_f32: - { - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; ++iFrame) { - float t = 0; - for (iChannel = 0; iChannel < pConverter->channelsIn; iChannel += 1) { - t += pFramesInF32[iFrame*pConverter->channelsIn + iChannel]; - } - - pFramesOutF32[iFrame] = t / pConverter->channelsIn; - } - } break; - - default: return MA_INVALID_OPERATION; /* Unknown format. */ - } - - return MA_SUCCESS; -} - -static ma_result ma_channel_converter_process_pcm_frames__weights(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - ma_uint32 iFrame; - ma_uint32 iChannelIn; - ma_uint32 iChannelOut; - - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pFramesOut != NULL); - MA_ASSERT(pFramesIn != NULL); - - /* This is the more complicated case. Each of the output channels is accumulated with 0 or more input channels. */ - - /* Clear. */ - ma_zero_memory_64(pFramesOut, frameCount * ma_get_bytes_per_frame(pConverter->format, pConverter->channelsOut)); - - /* Accumulate. */ - switch (pConverter->format) - { - case ma_format_u8: - { - /* */ ma_uint8* pFramesOutU8 = ( ma_uint8*)pFramesOut; - const ma_uint8* pFramesInU8 = (const ma_uint8*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_int16 u8_O = ma_pcm_sample_u8_to_s16_no_scale(pFramesOutU8[iFrame*pConverter->channelsOut + iChannelOut]); - ma_int16 u8_I = ma_pcm_sample_u8_to_s16_no_scale(pFramesInU8 [iFrame*pConverter->channelsIn + iChannelIn ]); - ma_int32 s = (ma_int32)ma_clamp(u8_O + ((u8_I * pConverter->weights.s16[iChannelIn][iChannelOut]) >> MA_CHANNEL_CONVERTER_FIXED_POINT_SHIFT), -128, 127); - pFramesOutU8[iFrame*pConverter->channelsOut + iChannelOut] = ma_clip_u8((ma_int16)s); - } - } - } - } break; - - case ma_format_s16: - { - /* */ ma_int16* pFramesOutS16 = ( ma_int16*)pFramesOut; - const ma_int16* pFramesInS16 = (const ma_int16*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_int32 s = pFramesOutS16[iFrame*pConverter->channelsOut + iChannelOut]; - s += (pFramesInS16[iFrame*pConverter->channelsIn + iChannelIn] * pConverter->weights.s16[iChannelIn][iChannelOut]) >> MA_CHANNEL_CONVERTER_FIXED_POINT_SHIFT; - - pFramesOutS16[iFrame*pConverter->channelsOut + iChannelOut] = (ma_int16)ma_clamp(s, -32768, 32767); - } - } - } - } break; - - case ma_format_s24: - { - /* */ ma_uint8* pFramesOutS24 = ( ma_uint8*)pFramesOut; - const ma_uint8* pFramesInS24 = (const ma_uint8*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_int64 s24_O = ma_pcm_sample_s24_to_s32_no_scale(&pFramesOutS24[(iFrame*pConverter->channelsOut + iChannelOut)*3]); - ma_int64 s24_I = ma_pcm_sample_s24_to_s32_no_scale(&pFramesInS24 [(iFrame*pConverter->channelsIn + iChannelIn )*3]); - ma_int64 s24 = (ma_int32)ma_clamp(s24_O + ((s24_I * pConverter->weights.s16[iChannelIn][iChannelOut]) >> MA_CHANNEL_CONVERTER_FIXED_POINT_SHIFT), -8388608, 8388607); - ma_pcm_sample_s32_to_s24_no_scale(s24, &pFramesOutS24[(iFrame*pConverter->channelsOut + iChannelOut)*3]); - } - } - } - } break; - - case ma_format_s32: - { - /* */ ma_int32* pFramesOutS32 = ( ma_int32*)pFramesOut; - const ma_int32* pFramesInS32 = (const ma_int32*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - ma_int64 s = pFramesOutS32[iFrame*pConverter->channelsOut + iChannelOut]; - s += ((ma_int64)pFramesInS32[iFrame*pConverter->channelsIn + iChannelIn] * pConverter->weights.s16[iChannelIn][iChannelOut]) >> MA_CHANNEL_CONVERTER_FIXED_POINT_SHIFT; - - pFramesOutS32[iFrame*pConverter->channelsOut + iChannelOut] = ma_clip_s32(s); - } - } - } - } break; - - case ma_format_f32: - { - /* */ float* pFramesOutF32 = ( float*)pFramesOut; - const float* pFramesInF32 = (const float*)pFramesIn; - - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannelIn = 0; iChannelIn < pConverter->channelsIn; ++iChannelIn) { - for (iChannelOut = 0; iChannelOut < pConverter->channelsOut; ++iChannelOut) { - pFramesOutF32[iFrame*pConverter->channelsOut + iChannelOut] += pFramesInF32[iFrame*pConverter->channelsIn + iChannelIn] * pConverter->weights.f32[iChannelIn][iChannelOut]; - } - } - } - } break; - - default: return MA_INVALID_OPERATION; /* Unknown format. */ - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_channel_converter_process_pcm_frames(ma_channel_converter* pConverter, void* pFramesOut, const void* pFramesIn, ma_uint64 frameCount) -{ - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - if (pFramesOut == NULL) { - return MA_INVALID_ARGS; - } - - if (pFramesIn == NULL) { - ma_zero_memory_64(pFramesOut, frameCount * ma_get_bytes_per_frame(pConverter->format, pConverter->channelsOut)); - return MA_SUCCESS; - } - - switch (pConverter->conversionPath) - { - case ma_channel_conversion_path_passthrough: return ma_channel_converter_process_pcm_frames__passthrough(pConverter, pFramesOut, pFramesIn, frameCount); - case ma_channel_conversion_path_mono_out: return ma_channel_converter_process_pcm_frames__mono_out(pConverter, pFramesOut, pFramesIn, frameCount); - case ma_channel_conversion_path_mono_in: return ma_channel_converter_process_pcm_frames__mono_in(pConverter, pFramesOut, pFramesIn, frameCount); - case ma_channel_conversion_path_shuffle: return ma_channel_converter_process_pcm_frames__shuffle(pConverter, pFramesOut, pFramesIn, frameCount); - case ma_channel_conversion_path_weights: - default: - { - return ma_channel_converter_process_pcm_frames__weights(pConverter, pFramesOut, pFramesIn, frameCount); - } - } -} - -MA_API ma_result ma_channel_converter_get_input_channel_map(const ma_channel_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pConverter == NULL || pChannelMap == NULL) { - return MA_INVALID_ARGS; - } - - ma_channel_map_copy_or_default(pChannelMap, channelMapCap, pConverter->pChannelMapIn, pConverter->channelsIn); - - return MA_SUCCESS; -} - -MA_API ma_result ma_channel_converter_get_output_channel_map(const ma_channel_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pConverter == NULL || pChannelMap == NULL) { - return MA_INVALID_ARGS; - } - - ma_channel_map_copy_or_default(pChannelMap, channelMapCap, pConverter->pChannelMapOut, pConverter->channelsOut); - - return MA_SUCCESS; -} - - -/************************************************************************************************************************************************************** - -Data Conversion - -**************************************************************************************************************************************************************/ -MA_API ma_data_converter_config ma_data_converter_config_init_default() -{ - ma_data_converter_config config; - MA_ZERO_OBJECT(&config); - - config.ditherMode = ma_dither_mode_none; - config.resampling.algorithm = ma_resample_algorithm_linear; - config.allowDynamicSampleRate = MA_FALSE; /* Disable dynamic sample rates by default because dynamic rate adjustments should be quite rare and it allows an optimization for cases when the in and out sample rates are the same. */ - - /* Linear resampling defaults. */ - config.resampling.linear.lpfOrder = 1; - - return config; -} - -MA_API ma_data_converter_config ma_data_converter_config_init(ma_format formatIn, ma_format formatOut, ma_uint32 channelsIn, ma_uint32 channelsOut, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut) -{ - ma_data_converter_config config = ma_data_converter_config_init_default(); - config.formatIn = formatIn; - config.formatOut = formatOut; - config.channelsIn = channelsIn; - config.channelsOut = channelsOut; - config.sampleRateIn = sampleRateIn; - config.sampleRateOut = sampleRateOut; - - return config; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t channelConverterOffset; - size_t resamplerOffset; -} ma_data_converter_heap_layout; - -static ma_bool32 ma_data_converter_config_is_resampler_required(const ma_data_converter_config* pConfig) -{ - MA_ASSERT(pConfig != NULL); - - return pConfig->allowDynamicSampleRate || pConfig->sampleRateIn != pConfig->sampleRateOut; -} - -static ma_format ma_data_converter_config_get_mid_format(const ma_data_converter_config* pConfig) -{ - MA_ASSERT(pConfig != NULL); - - /* - We want to avoid as much data conversion as possible. The channel converter and linear - resampler both support s16 and f32 natively. We need to decide on the format to use for this - stage. We call this the mid format because it's used in the middle stage of the conversion - pipeline. If the output format is either s16 or f32 we use that one. If that is not the case it - will do the same thing for the input format. If it's neither we just use f32. If we are using a - custom resampling backend, we can only guarantee that f32 will be supported so we'll be forced - to use that if resampling is required. - */ - if (ma_data_converter_config_is_resampler_required(pConfig) && pConfig->resampling.algorithm != ma_resample_algorithm_linear) { - return ma_format_f32; /* <-- Force f32 since that is the only one we can guarantee will be supported by the resampler. */ - } else { - /* */ if (pConfig->formatOut == ma_format_s16 || pConfig->formatOut == ma_format_f32) { - return pConfig->formatOut; - } else if (pConfig->formatIn == ma_format_s16 || pConfig->formatIn == ma_format_f32) { - return pConfig->formatIn; - } else { - return ma_format_f32; - } - } -} - -static ma_channel_converter_config ma_channel_converter_config_init_from_data_converter_config(const ma_data_converter_config* pConfig) -{ - ma_channel_converter_config channelConverterConfig; - - MA_ASSERT(pConfig != NULL); - - channelConverterConfig = ma_channel_converter_config_init(ma_data_converter_config_get_mid_format(pConfig), pConfig->channelsIn, pConfig->pChannelMapIn, pConfig->channelsOut, pConfig->pChannelMapOut, pConfig->channelMixMode); - channelConverterConfig.ppWeights = pConfig->ppChannelWeights; - channelConverterConfig.calculateLFEFromSpatialChannels = pConfig->calculateLFEFromSpatialChannels; - - return channelConverterConfig; -} - -static ma_resampler_config ma_resampler_config_init_from_data_converter_config(const ma_data_converter_config* pConfig) -{ - ma_resampler_config resamplerConfig; - ma_uint32 resamplerChannels; - - MA_ASSERT(pConfig != NULL); - - /* The resampler is the most expensive part of the conversion process, so we need to do it at the stage where the channel count is at it's lowest. */ - if (pConfig->channelsIn < pConfig->channelsOut) { - resamplerChannels = pConfig->channelsIn; - } else { - resamplerChannels = pConfig->channelsOut; - } - - resamplerConfig = ma_resampler_config_init(ma_data_converter_config_get_mid_format(pConfig), resamplerChannels, pConfig->sampleRateIn, pConfig->sampleRateOut, pConfig->resampling.algorithm); - resamplerConfig.linear = pConfig->resampling.linear; - resamplerConfig.pBackendVTable = pConfig->resampling.pBackendVTable; - resamplerConfig.pBackendUserData = pConfig->resampling.pBackendUserData; - - return resamplerConfig; -} - -static ma_result ma_data_converter_get_heap_layout(const ma_data_converter_config* pConfig, ma_data_converter_heap_layout* pHeapLayout) -{ - ma_result result; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channelsIn == 0 || pConfig->channelsOut == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Channel converter. */ - pHeapLayout->channelConverterOffset = pHeapLayout->sizeInBytes; - { - size_t heapSizeInBytes; - ma_channel_converter_config channelConverterConfig = ma_channel_converter_config_init_from_data_converter_config(pConfig); - - result = ma_channel_converter_get_heap_size(&channelConverterConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += heapSizeInBytes; - } - - /* Resampler. */ - pHeapLayout->resamplerOffset = pHeapLayout->sizeInBytes; - if (ma_data_converter_config_is_resampler_required(pConfig)) { - size_t heapSizeInBytes; - ma_resampler_config resamplerConfig = ma_resampler_config_init_from_data_converter_config(pConfig); - - result = ma_resampler_get_heap_size(&resamplerConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes += heapSizeInBytes; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_converter_get_heap_size(const ma_data_converter_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_data_converter_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_data_converter_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_converter_init_preallocated(const ma_data_converter_config* pConfig, void* pHeap, ma_data_converter* pConverter) -{ - ma_result result; - ma_data_converter_heap_layout heapLayout; - ma_format midFormat; - ma_bool32 isResamplingRequired; - - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pConverter); - - result = ma_data_converter_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pConverter->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pConverter->formatIn = pConfig->formatIn; - pConverter->formatOut = pConfig->formatOut; - pConverter->channelsIn = pConfig->channelsIn; - pConverter->channelsOut = pConfig->channelsOut; - pConverter->sampleRateIn = pConfig->sampleRateIn; - pConverter->sampleRateOut = pConfig->sampleRateOut; - pConverter->ditherMode = pConfig->ditherMode; - - /* - Determine if resampling is required. We need to do this so we can determine an appropriate - mid format to use. If resampling is required, the mid format must be ma_format_f32 since - that is the only one that is guaranteed to supported by custom resampling backends. - */ - isResamplingRequired = ma_data_converter_config_is_resampler_required(pConfig); - midFormat = ma_data_converter_config_get_mid_format(pConfig); - - - /* Channel converter. We always initialize this, but we check if it configures itself as a passthrough to determine whether or not it's needed. */ - { - ma_channel_converter_config channelConverterConfig = ma_channel_converter_config_init_from_data_converter_config(pConfig); - - result = ma_channel_converter_init_preallocated(&channelConverterConfig, ma_offset_ptr(pHeap, heapLayout.channelConverterOffset), &pConverter->channelConverter); - if (result != MA_SUCCESS) { - return result; - } - - /* If the channel converter is not a passthrough we need to enable it. Otherwise we can skip it. */ - if (pConverter->channelConverter.conversionPath != ma_channel_conversion_path_passthrough) { - pConverter->hasChannelConverter = MA_TRUE; - } - } - - - /* Resampler. */ - if (isResamplingRequired) { - ma_resampler_config resamplerConfig = ma_resampler_config_init_from_data_converter_config(pConfig); - - result = ma_resampler_init_preallocated(&resamplerConfig, ma_offset_ptr(pHeap, heapLayout.resamplerOffset), &pConverter->resampler); - if (result != MA_SUCCESS) { - return result; - } - - pConverter->hasResampler = MA_TRUE; - } - - - /* We can simplify pre- and post-format conversion if we have neither channel conversion nor resampling. */ - if (pConverter->hasChannelConverter == MA_FALSE && pConverter->hasResampler == MA_FALSE) { - /* We have neither channel conversion nor resampling so we'll only need one of pre- or post-format conversion, or none if the input and output formats are the same. */ - if (pConverter->formatIn == pConverter->formatOut) { - /* The formats are the same so we can just pass through. */ - pConverter->hasPreFormatConversion = MA_FALSE; - pConverter->hasPostFormatConversion = MA_FALSE; - } else { - /* The formats are different so we need to do either pre- or post-format conversion. It doesn't matter which. */ - pConverter->hasPreFormatConversion = MA_FALSE; - pConverter->hasPostFormatConversion = MA_TRUE; - } - } else { - /* We have a channel converter and/or resampler so we'll need channel conversion based on the mid format. */ - if (pConverter->formatIn != midFormat) { - pConverter->hasPreFormatConversion = MA_TRUE; - } - if (pConverter->formatOut != midFormat) { - pConverter->hasPostFormatConversion = MA_TRUE; - } - } - - /* We can enable passthrough optimizations if applicable. Note that we'll only be able to do this if the sample rate is static. */ - if (pConverter->hasPreFormatConversion == MA_FALSE && - pConverter->hasPostFormatConversion == MA_FALSE && - pConverter->hasChannelConverter == MA_FALSE && - pConverter->hasResampler == MA_FALSE) { - pConverter->isPassthrough = MA_TRUE; - } - - - /* We now need to determine our execution path. */ - if (pConverter->isPassthrough) { - pConverter->executionPath = ma_data_converter_execution_path_passthrough; - } else { - if (pConverter->channelsIn < pConverter->channelsOut) { - /* Do resampling first, if necessary. */ - MA_ASSERT(pConverter->hasChannelConverter == MA_TRUE); - - if (pConverter->hasResampler) { - pConverter->executionPath = ma_data_converter_execution_path_resample_first; - } else { - pConverter->executionPath = ma_data_converter_execution_path_channels_only; - } - } else { - /* Do channel conversion first, if necessary. */ - if (pConverter->hasChannelConverter) { - if (pConverter->hasResampler) { - pConverter->executionPath = ma_data_converter_execution_path_channels_first; - } else { - pConverter->executionPath = ma_data_converter_execution_path_channels_only; - } - } else { - /* Channel routing not required. */ - if (pConverter->hasResampler) { - pConverter->executionPath = ma_data_converter_execution_path_resample_only; - } else { - pConverter->executionPath = ma_data_converter_execution_path_format_only; - } - } - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_converter_init(const ma_data_converter_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_converter* pConverter) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_data_converter_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_data_converter_init_preallocated(pConfig, pHeap, pConverter); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pConverter->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_data_converter_uninit(ma_data_converter* pConverter, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pConverter == NULL) { - return; - } - - if (pConverter->hasResampler) { - ma_resampler_uninit(&pConverter->resampler, pAllocationCallbacks); - } - - ma_channel_converter_uninit(&pConverter->channelConverter, pAllocationCallbacks); - - if (pConverter->_ownsHeap) { - ma_free(pConverter->_pHeap, pAllocationCallbacks); - } -} - -static ma_result ma_data_converter_process_pcm_frames__passthrough(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 frameCount; - - MA_ASSERT(pConverter != NULL); - - frameCountIn = 0; - if (pFrameCountIn != NULL) { - frameCountIn = *pFrameCountIn; - } - - frameCountOut = 0; - if (pFrameCountOut != NULL) { - frameCountOut = *pFrameCountOut; - } - - frameCount = ma_min(frameCountIn, frameCountOut); - - if (pFramesOut != NULL) { - if (pFramesIn != NULL) { - ma_copy_memory_64(pFramesOut, pFramesIn, frameCount * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } else { - ma_zero_memory_64(pFramesOut, frameCount * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } - } - - if (pFrameCountIn != NULL) { - *pFrameCountIn = frameCount; - } - if (pFrameCountOut != NULL) { - *pFrameCountOut = frameCount; - } - - return MA_SUCCESS; -} - -static ma_result ma_data_converter_process_pcm_frames__format_only(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 frameCount; - - MA_ASSERT(pConverter != NULL); - - frameCountIn = 0; - if (pFrameCountIn != NULL) { - frameCountIn = *pFrameCountIn; - } - - frameCountOut = 0; - if (pFrameCountOut != NULL) { - frameCountOut = *pFrameCountOut; - } - - frameCount = ma_min(frameCountIn, frameCountOut); - - if (pFramesOut != NULL) { - if (pFramesIn != NULL) { - ma_convert_pcm_frames_format(pFramesOut, pConverter->formatOut, pFramesIn, pConverter->formatIn, frameCount, pConverter->channelsIn, pConverter->ditherMode); - } else { - ma_zero_memory_64(pFramesOut, frameCount * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } - } - - if (pFrameCountIn != NULL) { - *pFrameCountIn = frameCount; - } - if (pFrameCountOut != NULL) { - *pFrameCountOut = frameCount; - } - - return MA_SUCCESS; -} - - -static ma_result ma_data_converter_process_pcm_frames__resample_with_format_conversion(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - ma_result result = MA_SUCCESS; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - - MA_ASSERT(pConverter != NULL); - - frameCountIn = 0; - if (pFrameCountIn != NULL) { - frameCountIn = *pFrameCountIn; - } - - frameCountOut = 0; - if (pFrameCountOut != NULL) { - frameCountOut = *pFrameCountOut; - } - - framesProcessedIn = 0; - framesProcessedOut = 0; - - while (framesProcessedOut < frameCountOut) { - ma_uint8 pTempBufferOut[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - const ma_uint32 tempBufferOutCap = sizeof(pTempBufferOut) / ma_get_bytes_per_frame(pConverter->resampler.format, pConverter->resampler.channels); - const void* pFramesInThisIteration; - /* */ void* pFramesOutThisIteration; - ma_uint64 frameCountInThisIteration; - ma_uint64 frameCountOutThisIteration; - - if (pFramesIn != NULL) { - pFramesInThisIteration = ma_offset_ptr(pFramesIn, framesProcessedIn * ma_get_bytes_per_frame(pConverter->formatIn, pConverter->channelsIn)); - } else { - pFramesInThisIteration = NULL; - } - - if (pFramesOut != NULL) { - pFramesOutThisIteration = ma_offset_ptr(pFramesOut, framesProcessedOut * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } else { - pFramesOutThisIteration = NULL; - } - - /* Do a pre format conversion if necessary. */ - if (pConverter->hasPreFormatConversion) { - ma_uint8 pTempBufferIn[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - const ma_uint32 tempBufferInCap = sizeof(pTempBufferIn) / ma_get_bytes_per_frame(pConverter->resampler.format, pConverter->resampler.channels); - - frameCountInThisIteration = (frameCountIn - framesProcessedIn); - if (frameCountInThisIteration > tempBufferInCap) { - frameCountInThisIteration = tempBufferInCap; - } - - if (pConverter->hasPostFormatConversion) { - if (frameCountInThisIteration > tempBufferOutCap) { - frameCountInThisIteration = tempBufferOutCap; - } - } - - if (pFramesInThisIteration != NULL) { - ma_convert_pcm_frames_format(pTempBufferIn, pConverter->resampler.format, pFramesInThisIteration, pConverter->formatIn, frameCountInThisIteration, pConverter->channelsIn, pConverter->ditherMode); - } else { - MA_ZERO_MEMORY(pTempBufferIn, sizeof(pTempBufferIn)); - } - - frameCountOutThisIteration = (frameCountOut - framesProcessedOut); - - if (pConverter->hasPostFormatConversion) { - /* Both input and output conversion required. Output to the temp buffer. */ - if (frameCountOutThisIteration > tempBufferOutCap) { - frameCountOutThisIteration = tempBufferOutCap; - } - - result = ma_resampler_process_pcm_frames(&pConverter->resampler, pTempBufferIn, &frameCountInThisIteration, pTempBufferOut, &frameCountOutThisIteration); - } else { - /* Only pre-format required. Output straight to the output buffer. */ - result = ma_resampler_process_pcm_frames(&pConverter->resampler, pTempBufferIn, &frameCountInThisIteration, pFramesOutThisIteration, &frameCountOutThisIteration); - } - - if (result != MA_SUCCESS) { - break; - } - } else { - /* No pre-format required. Just read straight from the input buffer. */ - MA_ASSERT(pConverter->hasPostFormatConversion == MA_TRUE); - - frameCountInThisIteration = (frameCountIn - framesProcessedIn); - frameCountOutThisIteration = (frameCountOut - framesProcessedOut); - if (frameCountOutThisIteration > tempBufferOutCap) { - frameCountOutThisIteration = tempBufferOutCap; - } - - result = ma_resampler_process_pcm_frames(&pConverter->resampler, pFramesInThisIteration, &frameCountInThisIteration, pTempBufferOut, &frameCountOutThisIteration); - if (result != MA_SUCCESS) { - break; - } - } - - /* If we are doing a post format conversion we need to do that now. */ - if (pConverter->hasPostFormatConversion) { - if (pFramesOutThisIteration != NULL) { - ma_convert_pcm_frames_format(pFramesOutThisIteration, pConverter->formatOut, pTempBufferOut, pConverter->resampler.format, frameCountOutThisIteration, pConverter->resampler.channels, pConverter->ditherMode); - } - } - - framesProcessedIn += frameCountInThisIteration; - framesProcessedOut += frameCountOutThisIteration; - - MA_ASSERT(framesProcessedIn <= frameCountIn); - MA_ASSERT(framesProcessedOut <= frameCountOut); - - if (frameCountOutThisIteration == 0) { - break; /* Consumed all of our input data. */ - } - } - - if (pFrameCountIn != NULL) { - *pFrameCountIn = framesProcessedIn; - } - if (pFrameCountOut != NULL) { - *pFrameCountOut = framesProcessedOut; - } - - return result; -} - -static ma_result ma_data_converter_process_pcm_frames__resample_only(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - MA_ASSERT(pConverter != NULL); - - if (pConverter->hasPreFormatConversion == MA_FALSE && pConverter->hasPostFormatConversion == MA_FALSE) { - /* Neither pre- nor post-format required. This is simple case where only resampling is required. */ - return ma_resampler_process_pcm_frames(&pConverter->resampler, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } else { - /* Format conversion required. */ - return ma_data_converter_process_pcm_frames__resample_with_format_conversion(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - } -} - -static ma_result ma_data_converter_process_pcm_frames__channels_only(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - ma_result result; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 frameCount; - - MA_ASSERT(pConverter != NULL); - - frameCountIn = 0; - if (pFrameCountIn != NULL) { - frameCountIn = *pFrameCountIn; - } - - frameCountOut = 0; - if (pFrameCountOut != NULL) { - frameCountOut = *pFrameCountOut; - } - - frameCount = ma_min(frameCountIn, frameCountOut); - - if (pConverter->hasPreFormatConversion == MA_FALSE && pConverter->hasPostFormatConversion == MA_FALSE) { - /* No format conversion required. */ - result = ma_channel_converter_process_pcm_frames(&pConverter->channelConverter, pFramesOut, pFramesIn, frameCount); - if (result != MA_SUCCESS) { - return result; - } - } else { - /* Format conversion required. */ - ma_uint64 framesProcessed = 0; - - while (framesProcessed < frameCount) { - ma_uint8 pTempBufferOut[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - const ma_uint32 tempBufferOutCap = sizeof(pTempBufferOut) / ma_get_bytes_per_frame(pConverter->channelConverter.format, pConverter->channelConverter.channelsOut); - const void* pFramesInThisIteration; - /* */ void* pFramesOutThisIteration; - ma_uint64 frameCountThisIteration; - - if (pFramesIn != NULL) { - pFramesInThisIteration = ma_offset_ptr(pFramesIn, framesProcessed * ma_get_bytes_per_frame(pConverter->formatIn, pConverter->channelsIn)); - } else { - pFramesInThisIteration = NULL; - } - - if (pFramesOut != NULL) { - pFramesOutThisIteration = ma_offset_ptr(pFramesOut, framesProcessed * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } else { - pFramesOutThisIteration = NULL; - } - - /* Do a pre format conversion if necessary. */ - if (pConverter->hasPreFormatConversion) { - ma_uint8 pTempBufferIn[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - const ma_uint32 tempBufferInCap = sizeof(pTempBufferIn) / ma_get_bytes_per_frame(pConverter->channelConverter.format, pConverter->channelConverter.channelsIn); - - frameCountThisIteration = (frameCount - framesProcessed); - if (frameCountThisIteration > tempBufferInCap) { - frameCountThisIteration = tempBufferInCap; - } - - if (pConverter->hasPostFormatConversion) { - if (frameCountThisIteration > tempBufferOutCap) { - frameCountThisIteration = tempBufferOutCap; - } - } - - if (pFramesInThisIteration != NULL) { - ma_convert_pcm_frames_format(pTempBufferIn, pConverter->channelConverter.format, pFramesInThisIteration, pConverter->formatIn, frameCountThisIteration, pConverter->channelsIn, pConverter->ditherMode); - } else { - MA_ZERO_MEMORY(pTempBufferIn, sizeof(pTempBufferIn)); - } - - if (pConverter->hasPostFormatConversion) { - /* Both input and output conversion required. Output to the temp buffer. */ - result = ma_channel_converter_process_pcm_frames(&pConverter->channelConverter, pTempBufferOut, pTempBufferIn, frameCountThisIteration); - } else { - /* Only pre-format required. Output straight to the output buffer. */ - result = ma_channel_converter_process_pcm_frames(&pConverter->channelConverter, pFramesOutThisIteration, pTempBufferIn, frameCountThisIteration); - } - - if (result != MA_SUCCESS) { - break; - } - } else { - /* No pre-format required. Just read straight from the input buffer. */ - MA_ASSERT(pConverter->hasPostFormatConversion == MA_TRUE); - - frameCountThisIteration = (frameCount - framesProcessed); - if (frameCountThisIteration > tempBufferOutCap) { - frameCountThisIteration = tempBufferOutCap; - } - - result = ma_channel_converter_process_pcm_frames(&pConverter->channelConverter, pTempBufferOut, pFramesInThisIteration, frameCountThisIteration); - if (result != MA_SUCCESS) { - break; - } - } - - /* If we are doing a post format conversion we need to do that now. */ - if (pConverter->hasPostFormatConversion) { - if (pFramesOutThisIteration != NULL) { - ma_convert_pcm_frames_format(pFramesOutThisIteration, pConverter->formatOut, pTempBufferOut, pConverter->channelConverter.format, frameCountThisIteration, pConverter->channelConverter.channelsOut, pConverter->ditherMode); - } - } - - framesProcessed += frameCountThisIteration; - } - } - - if (pFrameCountIn != NULL) { - *pFrameCountIn = frameCount; - } - if (pFrameCountOut != NULL) { - *pFrameCountOut = frameCount; - } - - return MA_SUCCESS; -} - -static ma_result ma_data_converter_process_pcm_frames__resample_first(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - ma_result result; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - ma_uint8 pTempBufferIn[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In resampler format. */ - ma_uint64 tempBufferInCap; - ma_uint8 pTempBufferMid[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In resampler format, channel converter input format. */ - ma_uint64 tempBufferMidCap; - ma_uint8 pTempBufferOut[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In channel converter output format. */ - ma_uint64 tempBufferOutCap; - - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pConverter->resampler.format == pConverter->channelConverter.format); - MA_ASSERT(pConverter->resampler.channels == pConverter->channelConverter.channelsIn); - MA_ASSERT(pConverter->resampler.channels < pConverter->channelConverter.channelsOut); - - frameCountIn = 0; - if (pFrameCountIn != NULL) { - frameCountIn = *pFrameCountIn; - } - - frameCountOut = 0; - if (pFrameCountOut != NULL) { - frameCountOut = *pFrameCountOut; - } - - framesProcessedIn = 0; - framesProcessedOut = 0; - - tempBufferInCap = sizeof(pTempBufferIn) / ma_get_bytes_per_frame(pConverter->resampler.format, pConverter->resampler.channels); - tempBufferMidCap = sizeof(pTempBufferIn) / ma_get_bytes_per_frame(pConverter->resampler.format, pConverter->resampler.channels); - tempBufferOutCap = sizeof(pTempBufferOut) / ma_get_bytes_per_frame(pConverter->channelConverter.format, pConverter->channelConverter.channelsOut); - - while (framesProcessedOut < frameCountOut) { - ma_uint64 frameCountInThisIteration; - ma_uint64 frameCountOutThisIteration; - const void* pRunningFramesIn = NULL; - void* pRunningFramesOut = NULL; - const void* pResampleBufferIn; - void* pChannelsBufferOut; - - if (pFramesIn != NULL) { - pRunningFramesIn = ma_offset_ptr(pFramesIn, framesProcessedIn * ma_get_bytes_per_frame(pConverter->formatIn, pConverter->channelsIn)); - } - if (pFramesOut != NULL) { - pRunningFramesOut = ma_offset_ptr(pFramesOut, framesProcessedOut * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } - - /* Run input data through the resampler and output it to the temporary buffer. */ - frameCountInThisIteration = (frameCountIn - framesProcessedIn); - - if (pConverter->hasPreFormatConversion) { - if (frameCountInThisIteration > tempBufferInCap) { - frameCountInThisIteration = tempBufferInCap; - } - } - - frameCountOutThisIteration = (frameCountOut - framesProcessedOut); - if (frameCountOutThisIteration > tempBufferMidCap) { - frameCountOutThisIteration = tempBufferMidCap; - } - - /* We can't read more frames than can fit in the output buffer. */ - if (pConverter->hasPostFormatConversion) { - if (frameCountOutThisIteration > tempBufferOutCap) { - frameCountOutThisIteration = tempBufferOutCap; - } - } - - /* We need to ensure we don't try to process too many input frames that we run out of room in the output buffer. If this happens we'll end up glitching. */ - - /* - We need to try to predict how many input frames will be required for the resampler. If the - resampler can tell us, we'll use that. Otherwise we'll need to make a best guess. The further - off we are from this, the more wasted format conversions we'll end up doing. - */ - #if 1 - { - ma_uint64 requiredInputFrameCount; - - result = ma_resampler_get_required_input_frame_count(&pConverter->resampler, frameCountOutThisIteration, &requiredInputFrameCount); - if (result != MA_SUCCESS) { - /* Fall back to a best guess. */ - requiredInputFrameCount = (frameCountOutThisIteration * pConverter->resampler.sampleRateIn) / pConverter->resampler.sampleRateOut; - } - - if (frameCountInThisIteration > requiredInputFrameCount) { - frameCountInThisIteration = requiredInputFrameCount; - } - } - #endif - - if (pConverter->hasPreFormatConversion) { - if (pFramesIn != NULL) { - ma_convert_pcm_frames_format(pTempBufferIn, pConverter->resampler.format, pRunningFramesIn, pConverter->formatIn, frameCountInThisIteration, pConverter->channelsIn, pConverter->ditherMode); - pResampleBufferIn = pTempBufferIn; - } else { - pResampleBufferIn = NULL; - } - } else { - pResampleBufferIn = pRunningFramesIn; - } - - result = ma_resampler_process_pcm_frames(&pConverter->resampler, pResampleBufferIn, &frameCountInThisIteration, pTempBufferMid, &frameCountOutThisIteration); - if (result != MA_SUCCESS) { - return result; - } - - - /* - The input data has been resampled so now we need to run it through the channel converter. The input data is always contained in pTempBufferMid. We only need to do - this part if we have an output buffer. - */ - if (pFramesOut != NULL) { - if (pConverter->hasPostFormatConversion) { - pChannelsBufferOut = pTempBufferOut; - } else { - pChannelsBufferOut = pRunningFramesOut; - } - - result = ma_channel_converter_process_pcm_frames(&pConverter->channelConverter, pChannelsBufferOut, pTempBufferMid, frameCountOutThisIteration); - if (result != MA_SUCCESS) { - return result; - } - - /* Finally we do post format conversion. */ - if (pConverter->hasPostFormatConversion) { - ma_convert_pcm_frames_format(pRunningFramesOut, pConverter->formatOut, pChannelsBufferOut, pConverter->channelConverter.format, frameCountOutThisIteration, pConverter->channelConverter.channelsOut, pConverter->ditherMode); - } - } - - - framesProcessedIn += frameCountInThisIteration; - framesProcessedOut += frameCountOutThisIteration; - - MA_ASSERT(framesProcessedIn <= frameCountIn); - MA_ASSERT(framesProcessedOut <= frameCountOut); - - if (frameCountOutThisIteration == 0) { - break; /* Consumed all of our input data. */ - } - } - - if (pFrameCountIn != NULL) { - *pFrameCountIn = framesProcessedIn; - } - if (pFrameCountOut != NULL) { - *pFrameCountOut = framesProcessedOut; - } - - return MA_SUCCESS; -} - -static ma_result ma_data_converter_process_pcm_frames__channels_first(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - ma_result result; - ma_uint64 frameCountIn; - ma_uint64 frameCountOut; - ma_uint64 framesProcessedIn; - ma_uint64 framesProcessedOut; - ma_uint8 pTempBufferIn[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In resampler format. */ - ma_uint64 tempBufferInCap; - ma_uint8 pTempBufferMid[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In resampler format, channel converter input format. */ - ma_uint64 tempBufferMidCap; - ma_uint8 pTempBufferOut[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In channel converter output format. */ - ma_uint64 tempBufferOutCap; - - MA_ASSERT(pConverter != NULL); - MA_ASSERT(pConverter->resampler.format == pConverter->channelConverter.format); - MA_ASSERT(pConverter->resampler.channels == pConverter->channelConverter.channelsOut); - MA_ASSERT(pConverter->resampler.channels <= pConverter->channelConverter.channelsIn); - - frameCountIn = 0; - if (pFrameCountIn != NULL) { - frameCountIn = *pFrameCountIn; - } - - frameCountOut = 0; - if (pFrameCountOut != NULL) { - frameCountOut = *pFrameCountOut; - } - - framesProcessedIn = 0; - framesProcessedOut = 0; - - tempBufferInCap = sizeof(pTempBufferIn) / ma_get_bytes_per_frame(pConverter->channelConverter.format, pConverter->channelConverter.channelsIn); - tempBufferMidCap = sizeof(pTempBufferIn) / ma_get_bytes_per_frame(pConverter->channelConverter.format, pConverter->channelConverter.channelsOut); - tempBufferOutCap = sizeof(pTempBufferOut) / ma_get_bytes_per_frame(pConverter->resampler.format, pConverter->resampler.channels); - - while (framesProcessedOut < frameCountOut) { - ma_uint64 frameCountInThisIteration; - ma_uint64 frameCountOutThisIteration; - const void* pRunningFramesIn = NULL; - void* pRunningFramesOut = NULL; - const void* pChannelsBufferIn; - void* pResampleBufferOut; - - if (pFramesIn != NULL) { - pRunningFramesIn = ma_offset_ptr(pFramesIn, framesProcessedIn * ma_get_bytes_per_frame(pConverter->formatIn, pConverter->channelsIn)); - } - if (pFramesOut != NULL) { - pRunningFramesOut = ma_offset_ptr(pFramesOut, framesProcessedOut * ma_get_bytes_per_frame(pConverter->formatOut, pConverter->channelsOut)); - } - - /* - Before doing any processing we need to determine how many frames we should try processing - this iteration, for both input and output. The resampler requires us to perform format and - channel conversion before passing any data into it. If we get our input count wrong, we'll - end up peforming redundant pre-processing. This isn't the end of the world, but it does - result in some inefficiencies proportionate to how far our estimates are off. - - If the resampler has a means to calculate exactly how much we'll need, we'll use that. - Otherwise we'll make a best guess. In order to do this, we'll need to calculate the output - frame count first. - */ - frameCountOutThisIteration = (frameCountOut - framesProcessedOut); - if (frameCountOutThisIteration > tempBufferMidCap) { - frameCountOutThisIteration = tempBufferMidCap; - } - - if (pConverter->hasPostFormatConversion) { - if (frameCountOutThisIteration > tempBufferOutCap) { - frameCountOutThisIteration = tempBufferOutCap; - } - } - - /* Now that we have the output frame count we can determine the input frame count. */ - frameCountInThisIteration = (frameCountIn - framesProcessedIn); - if (pConverter->hasPreFormatConversion) { - if (frameCountInThisIteration > tempBufferInCap) { - frameCountInThisIteration = tempBufferInCap; - } - } - - if (frameCountInThisIteration > tempBufferMidCap) { - frameCountInThisIteration = tempBufferMidCap; - } - - #if 1 - { - ma_uint64 requiredInputFrameCount; - - result = ma_resampler_get_required_input_frame_count(&pConverter->resampler, frameCountOutThisIteration, &requiredInputFrameCount); - if (result != MA_SUCCESS) { - /* Fall back to a best guess. */ - requiredInputFrameCount = (frameCountOutThisIteration * pConverter->resampler.sampleRateIn) / pConverter->resampler.sampleRateOut; - } - - if (frameCountInThisIteration > requiredInputFrameCount) { - frameCountInThisIteration = requiredInputFrameCount; - } - } - #endif - - - /* Pre format conversion. */ - if (pConverter->hasPreFormatConversion) { - if (pRunningFramesIn != NULL) { - ma_convert_pcm_frames_format(pTempBufferIn, pConverter->channelConverter.format, pRunningFramesIn, pConverter->formatIn, frameCountInThisIteration, pConverter->channelsIn, pConverter->ditherMode); - pChannelsBufferIn = pTempBufferIn; - } else { - pChannelsBufferIn = NULL; - } - } else { - pChannelsBufferIn = pRunningFramesIn; - } - - - /* Channel conversion. */ - result = ma_channel_converter_process_pcm_frames(&pConverter->channelConverter, pTempBufferMid, pChannelsBufferIn, frameCountInThisIteration); - if (result != MA_SUCCESS) { - return result; - } - - - /* Resampling. */ - if (pConverter->hasPostFormatConversion) { - pResampleBufferOut = pTempBufferOut; - } else { - pResampleBufferOut = pRunningFramesOut; - } - - result = ma_resampler_process_pcm_frames(&pConverter->resampler, pTempBufferMid, &frameCountInThisIteration, pResampleBufferOut, &frameCountOutThisIteration); - if (result != MA_SUCCESS) { - return result; - } - - - /* Post format conversion. */ - if (pConverter->hasPostFormatConversion) { - if (pRunningFramesOut != NULL) { - ma_convert_pcm_frames_format(pRunningFramesOut, pConverter->formatOut, pResampleBufferOut, pConverter->resampler.format, frameCountOutThisIteration, pConverter->channelsOut, pConverter->ditherMode); - } - } - - - framesProcessedIn += frameCountInThisIteration; - framesProcessedOut += frameCountOutThisIteration; - - MA_ASSERT(framesProcessedIn <= frameCountIn); - MA_ASSERT(framesProcessedOut <= frameCountOut); - - if (frameCountOutThisIteration == 0) { - break; /* Consumed all of our input data. */ - } - } - - if (pFrameCountIn != NULL) { - *pFrameCountIn = framesProcessedIn; - } - if (pFrameCountOut != NULL) { - *pFrameCountOut = framesProcessedOut; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_converter_process_pcm_frames(ma_data_converter* pConverter, const void* pFramesIn, ma_uint64* pFrameCountIn, void* pFramesOut, ma_uint64* pFrameCountOut) -{ - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - switch (pConverter->executionPath) - { - case ma_data_converter_execution_path_passthrough: return ma_data_converter_process_pcm_frames__passthrough(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - case ma_data_converter_execution_path_format_only: return ma_data_converter_process_pcm_frames__format_only(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - case ma_data_converter_execution_path_channels_only: return ma_data_converter_process_pcm_frames__channels_only(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - case ma_data_converter_execution_path_resample_only: return ma_data_converter_process_pcm_frames__resample_only(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - case ma_data_converter_execution_path_resample_first: return ma_data_converter_process_pcm_frames__resample_first(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - case ma_data_converter_execution_path_channels_first: return ma_data_converter_process_pcm_frames__channels_first(pConverter, pFramesIn, pFrameCountIn, pFramesOut, pFrameCountOut); - default: return MA_INVALID_OPERATION; /* Should never hit this. */ - } -} - -MA_API ma_result ma_data_converter_set_rate(ma_data_converter* pConverter, ma_uint32 sampleRateIn, ma_uint32 sampleRateOut) -{ - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - if (pConverter->hasResampler == MA_FALSE) { - return MA_INVALID_OPERATION; /* Dynamic resampling not enabled. */ - } - - return ma_resampler_set_rate(&pConverter->resampler, sampleRateIn, sampleRateOut); -} - -MA_API ma_result ma_data_converter_set_rate_ratio(ma_data_converter* pConverter, float ratioInOut) -{ - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - if (pConverter->hasResampler == MA_FALSE) { - return MA_INVALID_OPERATION; /* Dynamic resampling not enabled. */ - } - - return ma_resampler_set_rate_ratio(&pConverter->resampler, ratioInOut); -} - -MA_API ma_uint64 ma_data_converter_get_input_latency(const ma_data_converter* pConverter) -{ - if (pConverter == NULL) { - return 0; - } - - if (pConverter->hasResampler) { - return ma_resampler_get_input_latency(&pConverter->resampler); - } - - return 0; /* No latency without a resampler. */ -} - -MA_API ma_uint64 ma_data_converter_get_output_latency(const ma_data_converter* pConverter) -{ - if (pConverter == NULL) { - return 0; - } - - if (pConverter->hasResampler) { - return ma_resampler_get_output_latency(&pConverter->resampler); - } - - return 0; /* No latency without a resampler. */ -} - -MA_API ma_result ma_data_converter_get_required_input_frame_count(const ma_data_converter* pConverter, ma_uint64 outputFrameCount, ma_uint64* pInputFrameCount) -{ - if (pInputFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - *pInputFrameCount = 0; - - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - if (pConverter->hasResampler) { - return ma_resampler_get_required_input_frame_count(&pConverter->resampler, outputFrameCount, pInputFrameCount); - } else { - *pInputFrameCount = outputFrameCount; /* 1:1 */ - return MA_SUCCESS; - } -} - -MA_API ma_result ma_data_converter_get_expected_output_frame_count(const ma_data_converter* pConverter, ma_uint64 inputFrameCount, ma_uint64* pOutputFrameCount) -{ - if (pOutputFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - *pOutputFrameCount = 0; - - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - if (pConverter->hasResampler) { - return ma_resampler_get_expected_output_frame_count(&pConverter->resampler, inputFrameCount, pOutputFrameCount); - } else { - *pOutputFrameCount = inputFrameCount; /* 1:1 */ - return MA_SUCCESS; - } -} - -MA_API ma_result ma_data_converter_get_input_channel_map(const ma_data_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pConverter == NULL || pChannelMap == NULL) { - return MA_INVALID_ARGS; - } - - if (pConverter->hasChannelConverter) { - ma_channel_converter_get_output_channel_map(&pConverter->channelConverter, pChannelMap, channelMapCap); - } else { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pConverter->channelsOut); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_converter_get_output_channel_map(const ma_data_converter* pConverter, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pConverter == NULL || pChannelMap == NULL) { - return MA_INVALID_ARGS; - } - - if (pConverter->hasChannelConverter) { - ma_channel_converter_get_input_channel_map(&pConverter->channelConverter, pChannelMap, channelMapCap); - } else { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pConverter->channelsIn); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_converter_reset(ma_data_converter* pConverter) -{ - if (pConverter == NULL) { - return MA_INVALID_ARGS; - } - - /* There's nothing to do if we're not resampling. */ - if (pConverter->hasResampler == MA_FALSE) { - return MA_SUCCESS; - } - - return ma_resampler_reset(&pConverter->resampler); -} - - - -/************************************************************************************************************************************************************** - -Channel Maps - -**************************************************************************************************************************************************************/ -static ma_channel ma_channel_map_init_standard_channel(ma_standard_channel_map standardChannelMap, ma_uint32 channelCount, ma_uint32 channelIndex); - -MA_API ma_channel ma_channel_map_get_channel(const ma_channel* pChannelMap, ma_uint32 channelCount, ma_uint32 channelIndex) -{ - if (pChannelMap == NULL) { - return ma_channel_map_init_standard_channel(ma_standard_channel_map_default, channelCount, channelIndex); - } else { - if (channelIndex >= channelCount) { - return MA_CHANNEL_NONE; - } - - return pChannelMap[channelIndex]; - } -} - -MA_API void ma_channel_map_init_blank(ma_channel* pChannelMap, ma_uint32 channels) -{ - if (pChannelMap == NULL) { - return; - } - - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channels); -} - - -static ma_channel ma_channel_map_init_standard_channel_microsoft(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - if (channelCount == 0 || channelIndex >= channelCount) { - return MA_CHANNEL_NONE; - } - - /* This is the Microsoft channel map. Based off the speaker configurations mentioned here: https://docs.microsoft.com/en-us/windows-hardware/drivers/ddi/content/ksmedia/ns-ksmedia-ksaudio_channel_config */ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: /* No defined, but best guess. */ - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 4: - { - switch (channelIndex) { - #ifndef MA_USE_QUAD_MICROSOFT_CHANNEL_MAP - /* Surround. Using the Surround profile has the advantage of the 3rd channel (MA_CHANNEL_FRONT_CENTER) mapping nicely with higher channel counts. */ - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_BACK_CENTER; - #else - /* Quad. */ - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - #endif - } - } break; - - case 5: /* Not defined, but best guess. */ - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 6: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_LFE; - case 4: return MA_CHANNEL_SIDE_LEFT; - case 5: return MA_CHANNEL_SIDE_RIGHT; - } - } break; - - case 7: /* Not defined, but best guess. */ - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_LFE; - case 4: return MA_CHANNEL_BACK_CENTER; - case 5: return MA_CHANNEL_SIDE_LEFT; - case 6: return MA_CHANNEL_SIDE_RIGHT; - } - } break; - - case 8: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_LFE; - case 4: return MA_CHANNEL_BACK_LEFT; - case 5: return MA_CHANNEL_BACK_RIGHT; - case 6: return MA_CHANNEL_SIDE_LEFT; - case 7: return MA_CHANNEL_SIDE_RIGHT; - } - } break; - } - - if (channelCount > 8) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 8)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - -static ma_channel ma_channel_map_init_standard_channel_alsa(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 4: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 5: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - case 4: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 6: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - case 4: return MA_CHANNEL_FRONT_CENTER; - case 5: return MA_CHANNEL_LFE; - } - } break; - - case 7: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - case 4: return MA_CHANNEL_FRONT_CENTER; - case 5: return MA_CHANNEL_LFE; - case 6: return MA_CHANNEL_BACK_CENTER; - } - } break; - - case 8: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - case 4: return MA_CHANNEL_FRONT_CENTER; - case 5: return MA_CHANNEL_LFE; - case 6: return MA_CHANNEL_SIDE_LEFT; - case 7: return MA_CHANNEL_SIDE_RIGHT; - } - } break; - } - - if (channelCount > 8) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 8)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - -static ma_channel ma_channel_map_init_standard_channel_rfc3551(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 4: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_BACK_CENTER; - } - } break; - - case 5: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 6: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_SIDE_LEFT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_FRONT_RIGHT; - case 4: return MA_CHANNEL_SIDE_RIGHT; - case 5: return MA_CHANNEL_BACK_CENTER; - } - } break; - } - - if (channelCount > 6) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 6)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - -static ma_channel ma_channel_map_init_standard_channel_flac(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 4: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 5: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 6: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_LFE; - case 4: return MA_CHANNEL_BACK_LEFT; - case 5: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 7: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_LFE; - case 4: return MA_CHANNEL_BACK_CENTER; - case 5: return MA_CHANNEL_SIDE_LEFT; - case 6: return MA_CHANNEL_SIDE_RIGHT; - } - } break; - - case 8: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_LFE; - case 4: return MA_CHANNEL_BACK_LEFT; - case 5: return MA_CHANNEL_BACK_RIGHT; - case 6: return MA_CHANNEL_SIDE_LEFT; - case 7: return MA_CHANNEL_SIDE_RIGHT; - } - } break; - } - - if (channelCount > 8) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 8)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - -static ma_channel ma_channel_map_init_standard_channel_vorbis(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 4: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 5: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 6: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - case 5: return MA_CHANNEL_LFE; - } - } break; - - case 7: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_SIDE_LEFT; - case 4: return MA_CHANNEL_SIDE_RIGHT; - case 5: return MA_CHANNEL_BACK_CENTER; - case 6: return MA_CHANNEL_LFE; - } - } break; - - case 8: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_SIDE_LEFT; - case 4: return MA_CHANNEL_SIDE_RIGHT; - case 5: return MA_CHANNEL_BACK_LEFT; - case 6: return MA_CHANNEL_BACK_RIGHT; - case 7: return MA_CHANNEL_LFE; - } - } break; - } - - if (channelCount > 8) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 8)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - -static ma_channel ma_channel_map_init_standard_channel_sound4(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 4: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 5: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 6: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_BACK_LEFT; - case 4: return MA_CHANNEL_BACK_RIGHT; - case 5: return MA_CHANNEL_LFE; - } - } break; - - case 7: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_SIDE_LEFT; - case 4: return MA_CHANNEL_SIDE_RIGHT; - case 5: return MA_CHANNEL_BACK_CENTER; - case 6: return MA_CHANNEL_LFE; - } - } break; - - case 8: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_CENTER; - case 2: return MA_CHANNEL_FRONT_RIGHT; - case 3: return MA_CHANNEL_SIDE_LEFT; - case 4: return MA_CHANNEL_SIDE_RIGHT; - case 5: return MA_CHANNEL_BACK_LEFT; - case 6: return MA_CHANNEL_BACK_RIGHT; - case 7: return MA_CHANNEL_LFE; - } - } break; - } - - if (channelCount > 8) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 8)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - -static ma_channel ma_channel_map_init_standard_channel_sndio(ma_uint32 channelCount, ma_uint32 channelIndex) -{ - switch (channelCount) - { - case 0: return MA_CHANNEL_NONE; - - case 1: - { - return MA_CHANNEL_MONO; - } break; - - case 2: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - } - } break; - - case 3: /* No defined, but best guess. */ - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 4: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - } - } break; - - case 5: /* Not defined, but best guess. */ - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - case 4: return MA_CHANNEL_FRONT_CENTER; - } - } break; - - case 6: - default: - { - switch (channelIndex) { - case 0: return MA_CHANNEL_FRONT_LEFT; - case 1: return MA_CHANNEL_FRONT_RIGHT; - case 2: return MA_CHANNEL_BACK_LEFT; - case 3: return MA_CHANNEL_BACK_RIGHT; - case 4: return MA_CHANNEL_FRONT_CENTER; - case 5: return MA_CHANNEL_LFE; - } - } break; - } - - if (channelCount > 6) { - if (channelIndex < 32) { /* We have 32 AUX channels. */ - return (ma_channel)(MA_CHANNEL_AUX_0 + (channelIndex - 6)); - } - } - - /* Getting here means we don't know how to map the channel position so just return MA_CHANNEL_NONE. */ - return MA_CHANNEL_NONE; -} - - -static ma_channel ma_channel_map_init_standard_channel(ma_standard_channel_map standardChannelMap, ma_uint32 channelCount, ma_uint32 channelIndex) -{ - if (channelCount == 0 || channelIndex >= channelCount) { - return MA_CHANNEL_NONE; - } - - switch (standardChannelMap) - { - case ma_standard_channel_map_alsa: - { - return ma_channel_map_init_standard_channel_alsa(channelCount, channelIndex); - } break; - - case ma_standard_channel_map_rfc3551: - { - return ma_channel_map_init_standard_channel_rfc3551(channelCount, channelIndex); - } break; - - case ma_standard_channel_map_flac: - { - return ma_channel_map_init_standard_channel_flac(channelCount, channelIndex); - } break; - - case ma_standard_channel_map_vorbis: - { - return ma_channel_map_init_standard_channel_vorbis(channelCount, channelIndex); - } break; - - case ma_standard_channel_map_sound4: - { - return ma_channel_map_init_standard_channel_sound4(channelCount, channelIndex); - } break; - - case ma_standard_channel_map_sndio: - { - return ma_channel_map_init_standard_channel_sndio(channelCount, channelIndex); - } break; - - case ma_standard_channel_map_microsoft: /* Also default. */ - /*case ma_standard_channel_map_default;*/ - default: - { - return ma_channel_map_init_standard_channel_microsoft(channelCount, channelIndex); - } break; - } -} - -MA_API void ma_channel_map_init_standard(ma_standard_channel_map standardChannelMap, ma_channel* pChannelMap, size_t channelMapCap, ma_uint32 channels) -{ - ma_uint32 iChannel; - - if (pChannelMap == NULL || channelMapCap == 0 || channels == 0) { - return; - } - - for (iChannel = 0; iChannel < channels; iChannel += 1) { - if (channelMapCap == 0) { - break; /* Ran out of room. */ - } - - pChannelMap[0] = ma_channel_map_init_standard_channel(standardChannelMap, channels, iChannel); - pChannelMap += 1; - channelMapCap -= 1; - } -} - -MA_API void ma_channel_map_copy(ma_channel* pOut, const ma_channel* pIn, ma_uint32 channels) -{ - if (pOut != NULL && pIn != NULL && channels > 0) { - MA_COPY_MEMORY(pOut, pIn, sizeof(*pOut) * channels); - } -} - -MA_API void ma_channel_map_copy_or_default(ma_channel* pOut, size_t channelMapCapOut, const ma_channel* pIn, ma_uint32 channels) -{ - if (pOut == NULL || channels == 0) { - return; - } - - if (pIn != NULL) { - ma_channel_map_copy(pOut, pIn, channels); - } else { - ma_channel_map_init_standard(ma_standard_channel_map_default, pOut, channelMapCapOut, channels); - } -} - -MA_API ma_bool32 ma_channel_map_is_valid(const ma_channel* pChannelMap, ma_uint32 channels) -{ - /* A channel count of 0 is invalid. */ - if (channels == 0) { - return MA_FALSE; - } - - /* It does not make sense to have a mono channel when there is more than 1 channel. */ - if (channels > 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < channels; ++iChannel) { - if (ma_channel_map_get_channel(pChannelMap, channels, iChannel) == MA_CHANNEL_MONO) { - return MA_FALSE; - } - } - } - - return MA_TRUE; -} - -MA_API ma_bool32 ma_channel_map_is_equal(const ma_channel* pChannelMapA, const ma_channel* pChannelMapB, ma_uint32 channels) -{ - ma_uint32 iChannel; - - if (pChannelMapA == pChannelMapB) { - return MA_TRUE; - } - - for (iChannel = 0; iChannel < channels; ++iChannel) { - if (ma_channel_map_get_channel(pChannelMapA, channels, iChannel) != ma_channel_map_get_channel(pChannelMapB, channels, iChannel)) { - return MA_FALSE; - } - } - - return MA_TRUE; -} - -MA_API ma_bool32 ma_channel_map_is_blank(const ma_channel* pChannelMap, ma_uint32 channels) -{ - ma_uint32 iChannel; - - /* A null channel map is equivalent to the default channel map. */ - if (pChannelMap == NULL) { - return MA_FALSE; - } - - for (iChannel = 0; iChannel < channels; ++iChannel) { - if (pChannelMap[iChannel] != MA_CHANNEL_NONE) { - return MA_FALSE; - } - } - - return MA_TRUE; -} - -MA_API ma_bool32 ma_channel_map_contains_channel_position(ma_uint32 channels, const ma_channel* pChannelMap, ma_channel channelPosition) -{ - return ma_channel_map_find_channel_position(channels, pChannelMap, channelPosition, NULL); -} - -MA_API ma_bool32 ma_channel_map_find_channel_position(ma_uint32 channels, const ma_channel* pChannelMap, ma_channel channelPosition, ma_uint32* pChannelIndex) -{ - ma_uint32 iChannel; - - if (pChannelIndex != NULL) { - *pChannelIndex = (ma_uint32)-1; - } - - for (iChannel = 0; iChannel < channels; ++iChannel) { - if (ma_channel_map_get_channel(pChannelMap, channels, iChannel) == channelPosition) { - if (pChannelIndex != NULL) { - *pChannelIndex = iChannel; - } - - return MA_TRUE; - } - } - - /* Getting here means the channel position was not found. */ - return MA_FALSE; -} - -MA_API size_t ma_channel_map_to_string(const ma_channel* pChannelMap, ma_uint32 channels, char* pBufferOut, size_t bufferCap) -{ - size_t len; - ma_uint32 iChannel; - - len = 0; - - for (iChannel = 0; iChannel < channels; iChannel += 1) { - const char* pChannelStr = ma_channel_position_to_string(ma_channel_map_get_channel(pChannelMap, channels, iChannel)); - size_t channelStrLen = strlen(pChannelStr); - - /* Append the string if necessary. */ - if (pBufferOut != NULL && bufferCap > len + channelStrLen) { - MA_COPY_MEMORY(pBufferOut + len, pChannelStr, channelStrLen); - } - len += channelStrLen; - - /* Append a space if it's not the last item. */ - if (iChannel+1 < channels) { - if (pBufferOut != NULL && bufferCap > len + 1) { - pBufferOut[len] = ' '; - } - len += 1; - } - } - - /* Null terminate. Don't increment the length here. */ - if (pBufferOut != NULL && bufferCap > len + 1) { - pBufferOut[len] = '\0'; - } - - return len; -} - -MA_API const char* ma_channel_position_to_string(ma_channel channel) -{ - switch (channel) - { - case MA_CHANNEL_NONE : return "CHANNEL_NONE"; - case MA_CHANNEL_MONO : return "CHANNEL_MONO"; - case MA_CHANNEL_FRONT_LEFT : return "CHANNEL_FRONT_LEFT"; - case MA_CHANNEL_FRONT_RIGHT : return "CHANNEL_FRONT_RIGHT"; - case MA_CHANNEL_FRONT_CENTER : return "CHANNEL_FRONT_CENTER"; - case MA_CHANNEL_LFE : return "CHANNEL_LFE"; - case MA_CHANNEL_BACK_LEFT : return "CHANNEL_BACK_LEFT"; - case MA_CHANNEL_BACK_RIGHT : return "CHANNEL_BACK_RIGHT"; - case MA_CHANNEL_FRONT_LEFT_CENTER : return "CHANNEL_FRONT_LEFT_CENTER "; - case MA_CHANNEL_FRONT_RIGHT_CENTER: return "CHANNEL_FRONT_RIGHT_CENTER"; - case MA_CHANNEL_BACK_CENTER : return "CHANNEL_BACK_CENTER"; - case MA_CHANNEL_SIDE_LEFT : return "CHANNEL_SIDE_LEFT"; - case MA_CHANNEL_SIDE_RIGHT : return "CHANNEL_SIDE_RIGHT"; - case MA_CHANNEL_TOP_CENTER : return "CHANNEL_TOP_CENTER"; - case MA_CHANNEL_TOP_FRONT_LEFT : return "CHANNEL_TOP_FRONT_LEFT"; - case MA_CHANNEL_TOP_FRONT_CENTER : return "CHANNEL_TOP_FRONT_CENTER"; - case MA_CHANNEL_TOP_FRONT_RIGHT : return "CHANNEL_TOP_FRONT_RIGHT"; - case MA_CHANNEL_TOP_BACK_LEFT : return "CHANNEL_TOP_BACK_LEFT"; - case MA_CHANNEL_TOP_BACK_CENTER : return "CHANNEL_TOP_BACK_CENTER"; - case MA_CHANNEL_TOP_BACK_RIGHT : return "CHANNEL_TOP_BACK_RIGHT"; - case MA_CHANNEL_AUX_0 : return "CHANNEL_AUX_0"; - case MA_CHANNEL_AUX_1 : return "CHANNEL_AUX_1"; - case MA_CHANNEL_AUX_2 : return "CHANNEL_AUX_2"; - case MA_CHANNEL_AUX_3 : return "CHANNEL_AUX_3"; - case MA_CHANNEL_AUX_4 : return "CHANNEL_AUX_4"; - case MA_CHANNEL_AUX_5 : return "CHANNEL_AUX_5"; - case MA_CHANNEL_AUX_6 : return "CHANNEL_AUX_6"; - case MA_CHANNEL_AUX_7 : return "CHANNEL_AUX_7"; - case MA_CHANNEL_AUX_8 : return "CHANNEL_AUX_8"; - case MA_CHANNEL_AUX_9 : return "CHANNEL_AUX_9"; - case MA_CHANNEL_AUX_10 : return "CHANNEL_AUX_10"; - case MA_CHANNEL_AUX_11 : return "CHANNEL_AUX_11"; - case MA_CHANNEL_AUX_12 : return "CHANNEL_AUX_12"; - case MA_CHANNEL_AUX_13 : return "CHANNEL_AUX_13"; - case MA_CHANNEL_AUX_14 : return "CHANNEL_AUX_14"; - case MA_CHANNEL_AUX_15 : return "CHANNEL_AUX_15"; - case MA_CHANNEL_AUX_16 : return "CHANNEL_AUX_16"; - case MA_CHANNEL_AUX_17 : return "CHANNEL_AUX_17"; - case MA_CHANNEL_AUX_18 : return "CHANNEL_AUX_18"; - case MA_CHANNEL_AUX_19 : return "CHANNEL_AUX_19"; - case MA_CHANNEL_AUX_20 : return "CHANNEL_AUX_20"; - case MA_CHANNEL_AUX_21 : return "CHANNEL_AUX_21"; - case MA_CHANNEL_AUX_22 : return "CHANNEL_AUX_22"; - case MA_CHANNEL_AUX_23 : return "CHANNEL_AUX_23"; - case MA_CHANNEL_AUX_24 : return "CHANNEL_AUX_24"; - case MA_CHANNEL_AUX_25 : return "CHANNEL_AUX_25"; - case MA_CHANNEL_AUX_26 : return "CHANNEL_AUX_26"; - case MA_CHANNEL_AUX_27 : return "CHANNEL_AUX_27"; - case MA_CHANNEL_AUX_28 : return "CHANNEL_AUX_28"; - case MA_CHANNEL_AUX_29 : return "CHANNEL_AUX_29"; - case MA_CHANNEL_AUX_30 : return "CHANNEL_AUX_30"; - case MA_CHANNEL_AUX_31 : return "CHANNEL_AUX_31"; - default: break; - } - - return "UNKNOWN"; -} - - - -/************************************************************************************************************************************************************** - -Conversion Helpers - -**************************************************************************************************************************************************************/ -MA_API ma_uint64 ma_convert_frames(void* pOut, ma_uint64 frameCountOut, ma_format formatOut, ma_uint32 channelsOut, ma_uint32 sampleRateOut, const void* pIn, ma_uint64 frameCountIn, ma_format formatIn, ma_uint32 channelsIn, ma_uint32 sampleRateIn) -{ - ma_data_converter_config config; - - config = ma_data_converter_config_init(formatIn, formatOut, channelsIn, channelsOut, sampleRateIn, sampleRateOut); - config.resampling.linear.lpfOrder = ma_min(MA_DEFAULT_RESAMPLER_LPF_ORDER, MA_MAX_FILTER_ORDER); - - return ma_convert_frames_ex(pOut, frameCountOut, pIn, frameCountIn, &config); -} - -MA_API ma_uint64 ma_convert_frames_ex(void* pOut, ma_uint64 frameCountOut, const void* pIn, ma_uint64 frameCountIn, const ma_data_converter_config* pConfig) -{ - ma_result result; - ma_data_converter converter; - - if (frameCountIn == 0 || pConfig == NULL) { - return 0; - } - - result = ma_data_converter_init(pConfig, NULL, &converter); - if (result != MA_SUCCESS) { - return 0; /* Failed to initialize the data converter. */ - } - - if (pOut == NULL) { - result = ma_data_converter_get_expected_output_frame_count(&converter, frameCountIn, &frameCountOut); - if (result != MA_SUCCESS) { - if (result == MA_NOT_IMPLEMENTED) { - /* No way to calculate the number of frames, so we'll need to brute force it and loop. */ - frameCountOut = 0; - - while (frameCountIn > 0) { - ma_uint64 framesProcessedIn = frameCountIn; - ma_uint64 framesProcessedOut = 0xFFFFFFFF; - - result = ma_data_converter_process_pcm_frames(&converter, pIn, &framesProcessedIn, NULL, &framesProcessedOut); - if (result != MA_SUCCESS) { - break; - } - - frameCountIn -= framesProcessedIn; - } - } - } - } else { - result = ma_data_converter_process_pcm_frames(&converter, pIn, &frameCountIn, pOut, &frameCountOut); - if (result != MA_SUCCESS) { - frameCountOut = 0; - } - } - - ma_data_converter_uninit(&converter, NULL); - return frameCountOut; -} - - -/************************************************************************************************************************************************************** - -Ring Buffer - -**************************************************************************************************************************************************************/ -static MA_INLINE ma_uint32 ma_rb__extract_offset_in_bytes(ma_uint32 encodedOffset) -{ - return encodedOffset & 0x7FFFFFFF; -} - -static MA_INLINE ma_uint32 ma_rb__extract_offset_loop_flag(ma_uint32 encodedOffset) -{ - return encodedOffset & 0x80000000; -} - -static MA_INLINE void* ma_rb__get_read_ptr(ma_rb* pRB) -{ - MA_ASSERT(pRB != NULL); - return ma_offset_ptr(pRB->pBuffer, ma_rb__extract_offset_in_bytes(c89atomic_load_32(&pRB->encodedReadOffset))); -} - -static MA_INLINE void* ma_rb__get_write_ptr(ma_rb* pRB) -{ - MA_ASSERT(pRB != NULL); - return ma_offset_ptr(pRB->pBuffer, ma_rb__extract_offset_in_bytes(c89atomic_load_32(&pRB->encodedWriteOffset))); -} - -static MA_INLINE ma_uint32 ma_rb__construct_offset(ma_uint32 offsetInBytes, ma_uint32 offsetLoopFlag) -{ - return offsetLoopFlag | offsetInBytes; -} - -static MA_INLINE void ma_rb__deconstruct_offset(ma_uint32 encodedOffset, ma_uint32* pOffsetInBytes, ma_uint32* pOffsetLoopFlag) -{ - MA_ASSERT(pOffsetInBytes != NULL); - MA_ASSERT(pOffsetLoopFlag != NULL); - - *pOffsetInBytes = ma_rb__extract_offset_in_bytes(encodedOffset); - *pOffsetLoopFlag = ma_rb__extract_offset_loop_flag(encodedOffset); -} - - -MA_API ma_result ma_rb_init_ex(size_t subbufferSizeInBytes, size_t subbufferCount, size_t subbufferStrideInBytes, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_rb* pRB) -{ - ma_result result; - const ma_uint32 maxSubBufferSize = 0x7FFFFFFF - (MA_SIMD_ALIGNMENT-1); - - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - if (subbufferSizeInBytes == 0 || subbufferCount == 0) { - return MA_INVALID_ARGS; - } - - if (subbufferSizeInBytes > maxSubBufferSize) { - return MA_INVALID_ARGS; /* Maximum buffer size is ~2GB. The most significant bit is a flag for use internally. */ - } - - - MA_ZERO_OBJECT(pRB); - - result = ma_allocation_callbacks_init_copy(&pRB->allocationCallbacks, pAllocationCallbacks); - if (result != MA_SUCCESS) { - return result; - } - - pRB->subbufferSizeInBytes = (ma_uint32)subbufferSizeInBytes; - pRB->subbufferCount = (ma_uint32)subbufferCount; - - if (pOptionalPreallocatedBuffer != NULL) { - pRB->subbufferStrideInBytes = (ma_uint32)subbufferStrideInBytes; - pRB->pBuffer = pOptionalPreallocatedBuffer; - } else { - size_t bufferSizeInBytes; - - /* - Here is where we allocate our own buffer. We always want to align this to MA_SIMD_ALIGNMENT for future SIMD optimization opportunity. To do this - we need to make sure the stride is a multiple of MA_SIMD_ALIGNMENT. - */ - pRB->subbufferStrideInBytes = (pRB->subbufferSizeInBytes + (MA_SIMD_ALIGNMENT-1)) & ~MA_SIMD_ALIGNMENT; - - bufferSizeInBytes = (size_t)pRB->subbufferCount*pRB->subbufferStrideInBytes; - pRB->pBuffer = ma_aligned_malloc(bufferSizeInBytes, MA_SIMD_ALIGNMENT, &pRB->allocationCallbacks); - if (pRB->pBuffer == NULL) { - return MA_OUT_OF_MEMORY; - } - - MA_ZERO_MEMORY(pRB->pBuffer, bufferSizeInBytes); - pRB->ownsBuffer = MA_TRUE; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_rb_init(size_t bufferSizeInBytes, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_rb* pRB) -{ - return ma_rb_init_ex(bufferSizeInBytes, 1, 0, pOptionalPreallocatedBuffer, pAllocationCallbacks, pRB); -} - -MA_API void ma_rb_uninit(ma_rb* pRB) -{ - if (pRB == NULL) { - return; - } - - if (pRB->ownsBuffer) { - ma_aligned_free(pRB->pBuffer, &pRB->allocationCallbacks); - } -} - -MA_API void ma_rb_reset(ma_rb* pRB) -{ - if (pRB == NULL) { - return; - } - - c89atomic_exchange_32(&pRB->encodedReadOffset, 0); - c89atomic_exchange_32(&pRB->encodedWriteOffset, 0); -} - -MA_API ma_result ma_rb_acquire_read(ma_rb* pRB, size_t* pSizeInBytes, void** ppBufferOut) -{ - ma_uint32 writeOffset; - ma_uint32 writeOffsetInBytes; - ma_uint32 writeOffsetLoopFlag; - ma_uint32 readOffset; - ma_uint32 readOffsetInBytes; - ma_uint32 readOffsetLoopFlag; - size_t bytesAvailable; - size_t bytesRequested; - - if (pRB == NULL || pSizeInBytes == NULL || ppBufferOut == NULL) { - return MA_INVALID_ARGS; - } - - /* The returned buffer should never move ahead of the write pointer. */ - writeOffset = c89atomic_load_32(&pRB->encodedWriteOffset); - ma_rb__deconstruct_offset(writeOffset, &writeOffsetInBytes, &writeOffsetLoopFlag); - - readOffset = c89atomic_load_32(&pRB->encodedReadOffset); - ma_rb__deconstruct_offset(readOffset, &readOffsetInBytes, &readOffsetLoopFlag); - - /* - The number of bytes available depends on whether or not the read and write pointers are on the same loop iteration. If so, we - can only read up to the write pointer. If not, we can only read up to the end of the buffer. - */ - if (readOffsetLoopFlag == writeOffsetLoopFlag) { - bytesAvailable = writeOffsetInBytes - readOffsetInBytes; - } else { - bytesAvailable = pRB->subbufferSizeInBytes - readOffsetInBytes; - } - - bytesRequested = *pSizeInBytes; - if (bytesRequested > bytesAvailable) { - bytesRequested = bytesAvailable; - } - - *pSizeInBytes = bytesRequested; - (*ppBufferOut) = ma_rb__get_read_ptr(pRB); - - return MA_SUCCESS; -} - -MA_API ma_result ma_rb_commit_read(ma_rb* pRB, size_t sizeInBytes) -{ - ma_uint32 readOffset; - ma_uint32 readOffsetInBytes; - ma_uint32 readOffsetLoopFlag; - ma_uint32 newReadOffsetInBytes; - ma_uint32 newReadOffsetLoopFlag; - - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - readOffset = c89atomic_load_32(&pRB->encodedReadOffset); - ma_rb__deconstruct_offset(readOffset, &readOffsetInBytes, &readOffsetLoopFlag); - - /* Check that sizeInBytes is correct. It should never go beyond the end of the buffer. */ - newReadOffsetInBytes = (ma_uint32)(readOffsetInBytes + sizeInBytes); - if (newReadOffsetInBytes > pRB->subbufferSizeInBytes) { - return MA_INVALID_ARGS; /* <-- sizeInBytes will cause the read offset to overflow. */ - } - - /* Move the read pointer back to the start if necessary. */ - newReadOffsetLoopFlag = readOffsetLoopFlag; - if (newReadOffsetInBytes == pRB->subbufferSizeInBytes) { - newReadOffsetInBytes = 0; - newReadOffsetLoopFlag ^= 0x80000000; - } - - c89atomic_exchange_32(&pRB->encodedReadOffset, ma_rb__construct_offset(newReadOffsetLoopFlag, newReadOffsetInBytes)); - - if (ma_rb_pointer_distance(pRB) == 0) { - return MA_AT_END; - } else { - return MA_SUCCESS; - } -} - -MA_API ma_result ma_rb_acquire_write(ma_rb* pRB, size_t* pSizeInBytes, void** ppBufferOut) -{ - ma_uint32 readOffset; - ma_uint32 readOffsetInBytes; - ma_uint32 readOffsetLoopFlag; - ma_uint32 writeOffset; - ma_uint32 writeOffsetInBytes; - ma_uint32 writeOffsetLoopFlag; - size_t bytesAvailable; - size_t bytesRequested; - - if (pRB == NULL || pSizeInBytes == NULL || ppBufferOut == NULL) { - return MA_INVALID_ARGS; - } - - /* The returned buffer should never overtake the read buffer. */ - readOffset = c89atomic_load_32(&pRB->encodedReadOffset); - ma_rb__deconstruct_offset(readOffset, &readOffsetInBytes, &readOffsetLoopFlag); - - writeOffset = c89atomic_load_32(&pRB->encodedWriteOffset); - ma_rb__deconstruct_offset(writeOffset, &writeOffsetInBytes, &writeOffsetLoopFlag); - - /* - In the case of writing, if the write pointer and the read pointer are on the same loop iteration we can only - write up to the end of the buffer. Otherwise we can only write up to the read pointer. The write pointer should - never overtake the read pointer. - */ - if (writeOffsetLoopFlag == readOffsetLoopFlag) { - bytesAvailable = pRB->subbufferSizeInBytes - writeOffsetInBytes; - } else { - bytesAvailable = readOffsetInBytes - writeOffsetInBytes; - } - - bytesRequested = *pSizeInBytes; - if (bytesRequested > bytesAvailable) { - bytesRequested = bytesAvailable; - } - - *pSizeInBytes = bytesRequested; - *ppBufferOut = ma_rb__get_write_ptr(pRB); - - /* Clear the buffer if desired. */ - if (pRB->clearOnWriteAcquire) { - MA_ZERO_MEMORY(*ppBufferOut, *pSizeInBytes); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_rb_commit_write(ma_rb* pRB, size_t sizeInBytes) -{ - ma_uint32 writeOffset; - ma_uint32 writeOffsetInBytes; - ma_uint32 writeOffsetLoopFlag; - ma_uint32 newWriteOffsetInBytes; - ma_uint32 newWriteOffsetLoopFlag; - - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - writeOffset = c89atomic_load_32(&pRB->encodedWriteOffset); - ma_rb__deconstruct_offset(writeOffset, &writeOffsetInBytes, &writeOffsetLoopFlag); - - /* Check that sizeInBytes is correct. It should never go beyond the end of the buffer. */ - newWriteOffsetInBytes = (ma_uint32)(writeOffsetInBytes + sizeInBytes); - if (newWriteOffsetInBytes > pRB->subbufferSizeInBytes) { - return MA_INVALID_ARGS; /* <-- sizeInBytes will cause the read offset to overflow. */ - } - - /* Move the read pointer back to the start if necessary. */ - newWriteOffsetLoopFlag = writeOffsetLoopFlag; - if (newWriteOffsetInBytes == pRB->subbufferSizeInBytes) { - newWriteOffsetInBytes = 0; - newWriteOffsetLoopFlag ^= 0x80000000; - } - - c89atomic_exchange_32(&pRB->encodedWriteOffset, ma_rb__construct_offset(newWriteOffsetLoopFlag, newWriteOffsetInBytes)); - - if (ma_rb_pointer_distance(pRB) == 0) { - return MA_AT_END; - } else { - return MA_SUCCESS; - } -} - -MA_API ma_result ma_rb_seek_read(ma_rb* pRB, size_t offsetInBytes) -{ - ma_uint32 readOffset; - ma_uint32 readOffsetInBytes; - ma_uint32 readOffsetLoopFlag; - ma_uint32 writeOffset; - ma_uint32 writeOffsetInBytes; - ma_uint32 writeOffsetLoopFlag; - ma_uint32 newReadOffsetInBytes; - ma_uint32 newReadOffsetLoopFlag; - - if (pRB == NULL || offsetInBytes > pRB->subbufferSizeInBytes) { - return MA_INVALID_ARGS; - } - - readOffset = c89atomic_load_32(&pRB->encodedReadOffset); - ma_rb__deconstruct_offset(readOffset, &readOffsetInBytes, &readOffsetLoopFlag); - - writeOffset = c89atomic_load_32(&pRB->encodedWriteOffset); - ma_rb__deconstruct_offset(writeOffset, &writeOffsetInBytes, &writeOffsetLoopFlag); - - newReadOffsetLoopFlag = readOffsetLoopFlag; - - /* We cannot go past the write buffer. */ - if (readOffsetLoopFlag == writeOffsetLoopFlag) { - if ((readOffsetInBytes + offsetInBytes) > writeOffsetInBytes) { - newReadOffsetInBytes = writeOffsetInBytes; - } else { - newReadOffsetInBytes = (ma_uint32)(readOffsetInBytes + offsetInBytes); - } - } else { - /* May end up looping. */ - if ((readOffsetInBytes + offsetInBytes) >= pRB->subbufferSizeInBytes) { - newReadOffsetInBytes = (ma_uint32)(readOffsetInBytes + offsetInBytes) - pRB->subbufferSizeInBytes; - newReadOffsetLoopFlag ^= 0x80000000; /* <-- Looped. */ - } else { - newReadOffsetInBytes = (ma_uint32)(readOffsetInBytes + offsetInBytes); - } - } - - c89atomic_exchange_32(&pRB->encodedReadOffset, ma_rb__construct_offset(newReadOffsetInBytes, newReadOffsetLoopFlag)); - return MA_SUCCESS; -} - -MA_API ma_result ma_rb_seek_write(ma_rb* pRB, size_t offsetInBytes) -{ - ma_uint32 readOffset; - ma_uint32 readOffsetInBytes; - ma_uint32 readOffsetLoopFlag; - ma_uint32 writeOffset; - ma_uint32 writeOffsetInBytes; - ma_uint32 writeOffsetLoopFlag; - ma_uint32 newWriteOffsetInBytes; - ma_uint32 newWriteOffsetLoopFlag; - - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - readOffset = c89atomic_load_32(&pRB->encodedReadOffset); - ma_rb__deconstruct_offset(readOffset, &readOffsetInBytes, &readOffsetLoopFlag); - - writeOffset = c89atomic_load_32(&pRB->encodedWriteOffset); - ma_rb__deconstruct_offset(writeOffset, &writeOffsetInBytes, &writeOffsetLoopFlag); - - newWriteOffsetLoopFlag = writeOffsetLoopFlag; - - /* We cannot go past the write buffer. */ - if (readOffsetLoopFlag == writeOffsetLoopFlag) { - /* May end up looping. */ - if ((writeOffsetInBytes + offsetInBytes) >= pRB->subbufferSizeInBytes) { - newWriteOffsetInBytes = (ma_uint32)(writeOffsetInBytes + offsetInBytes) - pRB->subbufferSizeInBytes; - newWriteOffsetLoopFlag ^= 0x80000000; /* <-- Looped. */ - } else { - newWriteOffsetInBytes = (ma_uint32)(writeOffsetInBytes + offsetInBytes); - } - } else { - if ((writeOffsetInBytes + offsetInBytes) > readOffsetInBytes) { - newWriteOffsetInBytes = readOffsetInBytes; - } else { - newWriteOffsetInBytes = (ma_uint32)(writeOffsetInBytes + offsetInBytes); - } - } - - c89atomic_exchange_32(&pRB->encodedWriteOffset, ma_rb__construct_offset(newWriteOffsetInBytes, newWriteOffsetLoopFlag)); - return MA_SUCCESS; -} - -MA_API ma_int32 ma_rb_pointer_distance(ma_rb* pRB) -{ - ma_uint32 readOffset; - ma_uint32 readOffsetInBytes; - ma_uint32 readOffsetLoopFlag; - ma_uint32 writeOffset; - ma_uint32 writeOffsetInBytes; - ma_uint32 writeOffsetLoopFlag; - - if (pRB == NULL) { - return 0; - } - - readOffset = c89atomic_load_32(&pRB->encodedReadOffset); - ma_rb__deconstruct_offset(readOffset, &readOffsetInBytes, &readOffsetLoopFlag); - - writeOffset = c89atomic_load_32(&pRB->encodedWriteOffset); - ma_rb__deconstruct_offset(writeOffset, &writeOffsetInBytes, &writeOffsetLoopFlag); - - if (readOffsetLoopFlag == writeOffsetLoopFlag) { - return writeOffsetInBytes - readOffsetInBytes; - } else { - return writeOffsetInBytes + (pRB->subbufferSizeInBytes - readOffsetInBytes); - } -} - -MA_API ma_uint32 ma_rb_available_read(ma_rb* pRB) -{ - ma_int32 dist; - - if (pRB == NULL) { - return 0; - } - - dist = ma_rb_pointer_distance(pRB); - if (dist < 0) { - return 0; - } - - return dist; -} - -MA_API ma_uint32 ma_rb_available_write(ma_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return (ma_uint32)(ma_rb_get_subbuffer_size(pRB) - ma_rb_pointer_distance(pRB)); -} - -MA_API size_t ma_rb_get_subbuffer_size(ma_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return pRB->subbufferSizeInBytes; -} - -MA_API size_t ma_rb_get_subbuffer_stride(ma_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - if (pRB->subbufferStrideInBytes == 0) { - return (size_t)pRB->subbufferSizeInBytes; - } - - return (size_t)pRB->subbufferStrideInBytes; -} - -MA_API size_t ma_rb_get_subbuffer_offset(ma_rb* pRB, size_t subbufferIndex) -{ - if (pRB == NULL) { - return 0; - } - - return subbufferIndex * ma_rb_get_subbuffer_stride(pRB); -} - -MA_API void* ma_rb_get_subbuffer_ptr(ma_rb* pRB, size_t subbufferIndex, void* pBuffer) -{ - if (pRB == NULL) { - return NULL; - } - - return ma_offset_ptr(pBuffer, ma_rb_get_subbuffer_offset(pRB, subbufferIndex)); -} - - - -static MA_INLINE ma_uint32 ma_pcm_rb_get_bpf(ma_pcm_rb* pRB) -{ - MA_ASSERT(pRB != NULL); - - return ma_get_bytes_per_frame(pRB->format, pRB->channels); -} - -MA_API ma_result ma_pcm_rb_init_ex(ma_format format, ma_uint32 channels, ma_uint32 subbufferSizeInFrames, ma_uint32 subbufferCount, ma_uint32 subbufferStrideInFrames, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_pcm_rb* pRB) -{ - ma_uint32 bpf; - ma_result result; - - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pRB); - - bpf = ma_get_bytes_per_frame(format, channels); - if (bpf == 0) { - return MA_INVALID_ARGS; - } - - result = ma_rb_init_ex(subbufferSizeInFrames*bpf, subbufferCount, subbufferStrideInFrames*bpf, pOptionalPreallocatedBuffer, pAllocationCallbacks, &pRB->rb); - if (result != MA_SUCCESS) { - return result; - } - - pRB->format = format; - pRB->channels = channels; - - return MA_SUCCESS; -} - -MA_API ma_result ma_pcm_rb_init(ma_format format, ma_uint32 channels, ma_uint32 bufferSizeInFrames, void* pOptionalPreallocatedBuffer, const ma_allocation_callbacks* pAllocationCallbacks, ma_pcm_rb* pRB) -{ - return ma_pcm_rb_init_ex(format, channels, bufferSizeInFrames, 1, 0, pOptionalPreallocatedBuffer, pAllocationCallbacks, pRB); -} - -MA_API void ma_pcm_rb_uninit(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return; - } - - ma_rb_uninit(&pRB->rb); -} - -MA_API void ma_pcm_rb_reset(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return; - } - - ma_rb_reset(&pRB->rb); -} - -MA_API ma_result ma_pcm_rb_acquire_read(ma_pcm_rb* pRB, ma_uint32* pSizeInFrames, void** ppBufferOut) -{ - size_t sizeInBytes; - ma_result result; - - if (pRB == NULL || pSizeInFrames == NULL) { - return MA_INVALID_ARGS; - } - - sizeInBytes = *pSizeInFrames * ma_pcm_rb_get_bpf(pRB); - - result = ma_rb_acquire_read(&pRB->rb, &sizeInBytes, ppBufferOut); - if (result != MA_SUCCESS) { - return result; - } - - *pSizeInFrames = (ma_uint32)(sizeInBytes / (size_t)ma_pcm_rb_get_bpf(pRB)); - return MA_SUCCESS; -} - -MA_API ma_result ma_pcm_rb_commit_read(ma_pcm_rb* pRB, ma_uint32 sizeInFrames) -{ - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - return ma_rb_commit_read(&pRB->rb, sizeInFrames * ma_pcm_rb_get_bpf(pRB)); -} - -MA_API ma_result ma_pcm_rb_acquire_write(ma_pcm_rb* pRB, ma_uint32* pSizeInFrames, void** ppBufferOut) -{ - size_t sizeInBytes; - ma_result result; - - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - sizeInBytes = *pSizeInFrames * ma_pcm_rb_get_bpf(pRB); - - result = ma_rb_acquire_write(&pRB->rb, &sizeInBytes, ppBufferOut); - if (result != MA_SUCCESS) { - return result; - } - - *pSizeInFrames = (ma_uint32)(sizeInBytes / ma_pcm_rb_get_bpf(pRB)); - return MA_SUCCESS; -} - -MA_API ma_result ma_pcm_rb_commit_write(ma_pcm_rb* pRB, ma_uint32 sizeInFrames) -{ - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - return ma_rb_commit_write(&pRB->rb, sizeInFrames * ma_pcm_rb_get_bpf(pRB)); -} - -MA_API ma_result ma_pcm_rb_seek_read(ma_pcm_rb* pRB, ma_uint32 offsetInFrames) -{ - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - return ma_rb_seek_read(&pRB->rb, offsetInFrames * ma_pcm_rb_get_bpf(pRB)); -} - -MA_API ma_result ma_pcm_rb_seek_write(ma_pcm_rb* pRB, ma_uint32 offsetInFrames) -{ - if (pRB == NULL) { - return MA_INVALID_ARGS; - } - - return ma_rb_seek_write(&pRB->rb, offsetInFrames * ma_pcm_rb_get_bpf(pRB)); -} - -MA_API ma_int32 ma_pcm_rb_pointer_distance(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return ma_rb_pointer_distance(&pRB->rb) / ma_pcm_rb_get_bpf(pRB); -} - -MA_API ma_uint32 ma_pcm_rb_available_read(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return ma_rb_available_read(&pRB->rb) / ma_pcm_rb_get_bpf(pRB); -} - -MA_API ma_uint32 ma_pcm_rb_available_write(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return ma_rb_available_write(&pRB->rb) / ma_pcm_rb_get_bpf(pRB); -} - -MA_API ma_uint32 ma_pcm_rb_get_subbuffer_size(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return (ma_uint32)(ma_rb_get_subbuffer_size(&pRB->rb) / ma_pcm_rb_get_bpf(pRB)); -} - -MA_API ma_uint32 ma_pcm_rb_get_subbuffer_stride(ma_pcm_rb* pRB) -{ - if (pRB == NULL) { - return 0; - } - - return (ma_uint32)(ma_rb_get_subbuffer_stride(&pRB->rb) / ma_pcm_rb_get_bpf(pRB)); -} - -MA_API ma_uint32 ma_pcm_rb_get_subbuffer_offset(ma_pcm_rb* pRB, ma_uint32 subbufferIndex) -{ - if (pRB == NULL) { - return 0; - } - - return (ma_uint32)(ma_rb_get_subbuffer_offset(&pRB->rb, subbufferIndex) / ma_pcm_rb_get_bpf(pRB)); -} - -MA_API void* ma_pcm_rb_get_subbuffer_ptr(ma_pcm_rb* pRB, ma_uint32 subbufferIndex, void* pBuffer) -{ - if (pRB == NULL) { - return NULL; - } - - return ma_rb_get_subbuffer_ptr(&pRB->rb, subbufferIndex, pBuffer); -} - - - -MA_API ma_result ma_duplex_rb_init(ma_format captureFormat, ma_uint32 captureChannels, ma_uint32 sampleRate, ma_uint32 captureInternalSampleRate, ma_uint32 captureInternalPeriodSizeInFrames, const ma_allocation_callbacks* pAllocationCallbacks, ma_duplex_rb* pRB) -{ - ma_result result; - ma_uint32 sizeInFrames; - - sizeInFrames = (ma_uint32)ma_calculate_frame_count_after_resampling(sampleRate, captureInternalSampleRate, captureInternalPeriodSizeInFrames * 5); - if (sizeInFrames == 0) { - return MA_INVALID_ARGS; - } - - result = ma_pcm_rb_init(captureFormat, captureChannels, sizeInFrames, NULL, pAllocationCallbacks, &pRB->rb); - if (result != MA_SUCCESS) { - return result; - } - - /* Seek forward a bit so we have a bit of a buffer in case of desyncs. */ - ma_pcm_rb_seek_write((ma_pcm_rb*)pRB, captureInternalPeriodSizeInFrames * 2); - - return MA_SUCCESS; -} - -MA_API ma_result ma_duplex_rb_uninit(ma_duplex_rb* pRB) -{ - ma_pcm_rb_uninit((ma_pcm_rb*)pRB); - return MA_SUCCESS; -} - - - -/************************************************************************************************************************************************************** - -Miscellaneous Helpers - -**************************************************************************************************************************************************************/ -MA_API const char* ma_result_description(ma_result result) -{ - switch (result) - { - case MA_SUCCESS: return "No error"; - case MA_ERROR: return "Unknown error"; - case MA_INVALID_ARGS: return "Invalid argument"; - case MA_INVALID_OPERATION: return "Invalid operation"; - case MA_OUT_OF_MEMORY: return "Out of memory"; - case MA_OUT_OF_RANGE: return "Out of range"; - case MA_ACCESS_DENIED: return "Permission denied"; - case MA_DOES_NOT_EXIST: return "Resource does not exist"; - case MA_ALREADY_EXISTS: return "Resource already exists"; - case MA_TOO_MANY_OPEN_FILES: return "Too many open files"; - case MA_INVALID_FILE: return "Invalid file"; - case MA_TOO_BIG: return "Too large"; - case MA_PATH_TOO_LONG: return "Path too long"; - case MA_NAME_TOO_LONG: return "Name too long"; - case MA_NOT_DIRECTORY: return "Not a directory"; - case MA_IS_DIRECTORY: return "Is a directory"; - case MA_DIRECTORY_NOT_EMPTY: return "Directory not empty"; - case MA_AT_END: return "At end"; - case MA_NO_SPACE: return "No space available"; - case MA_BUSY: return "Device or resource busy"; - case MA_IO_ERROR: return "Input/output error"; - case MA_INTERRUPT: return "Interrupted"; - case MA_UNAVAILABLE: return "Resource unavailable"; - case MA_ALREADY_IN_USE: return "Resource already in use"; - case MA_BAD_ADDRESS: return "Bad address"; - case MA_BAD_SEEK: return "Illegal seek"; - case MA_BAD_PIPE: return "Broken pipe"; - case MA_DEADLOCK: return "Deadlock"; - case MA_TOO_MANY_LINKS: return "Too many links"; - case MA_NOT_IMPLEMENTED: return "Not implemented"; - case MA_NO_MESSAGE: return "No message of desired type"; - case MA_BAD_MESSAGE: return "Invalid message"; - case MA_NO_DATA_AVAILABLE: return "No data available"; - case MA_INVALID_DATA: return "Invalid data"; - case MA_TIMEOUT: return "Timeout"; - case MA_NO_NETWORK: return "Network unavailable"; - case MA_NOT_UNIQUE: return "Not unique"; - case MA_NOT_SOCKET: return "Socket operation on non-socket"; - case MA_NO_ADDRESS: return "Destination address required"; - case MA_BAD_PROTOCOL: return "Protocol wrong type for socket"; - case MA_PROTOCOL_UNAVAILABLE: return "Protocol not available"; - case MA_PROTOCOL_NOT_SUPPORTED: return "Protocol not supported"; - case MA_PROTOCOL_FAMILY_NOT_SUPPORTED: return "Protocol family not supported"; - case MA_ADDRESS_FAMILY_NOT_SUPPORTED: return "Address family not supported"; - case MA_SOCKET_NOT_SUPPORTED: return "Socket type not supported"; - case MA_CONNECTION_RESET: return "Connection reset"; - case MA_ALREADY_CONNECTED: return "Already connected"; - case MA_NOT_CONNECTED: return "Not connected"; - case MA_CONNECTION_REFUSED: return "Connection refused"; - case MA_NO_HOST: return "No host"; - case MA_IN_PROGRESS: return "Operation in progress"; - case MA_CANCELLED: return "Operation cancelled"; - case MA_MEMORY_ALREADY_MAPPED: return "Memory already mapped"; - - case MA_FORMAT_NOT_SUPPORTED: return "Format not supported"; - case MA_DEVICE_TYPE_NOT_SUPPORTED: return "Device type not supported"; - case MA_SHARE_MODE_NOT_SUPPORTED: return "Share mode not supported"; - case MA_NO_BACKEND: return "No backend"; - case MA_NO_DEVICE: return "No device"; - case MA_API_NOT_FOUND: return "API not found"; - case MA_INVALID_DEVICE_CONFIG: return "Invalid device config"; - - case MA_DEVICE_NOT_INITIALIZED: return "Device not initialized"; - case MA_DEVICE_NOT_STARTED: return "Device not started"; - - case MA_FAILED_TO_INIT_BACKEND: return "Failed to initialize backend"; - case MA_FAILED_TO_OPEN_BACKEND_DEVICE: return "Failed to open backend device"; - case MA_FAILED_TO_START_BACKEND_DEVICE: return "Failed to start backend device"; - case MA_FAILED_TO_STOP_BACKEND_DEVICE: return "Failed to stop backend device"; - - default: return "Unknown error"; - } -} - -MA_API void* ma_malloc(size_t sz, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - if (pAllocationCallbacks->onMalloc != NULL) { - return pAllocationCallbacks->onMalloc(sz, pAllocationCallbacks->pUserData); - } else { - return NULL; /* Do not fall back to the default implementation. */ - } - } else { - return ma__malloc_default(sz, NULL); - } -} - -MA_API void* ma_calloc(size_t sz, const ma_allocation_callbacks* pAllocationCallbacks) -{ - void* p = ma_malloc(sz, pAllocationCallbacks); - if (p != NULL) { - MA_ZERO_MEMORY(p, sz); - } - - return p; -} - -MA_API void* ma_realloc(void* p, size_t sz, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(p, sz, pAllocationCallbacks->pUserData); - } else { - return NULL; /* Do not fall back to the default implementation. */ - } - } else { - return ma__realloc_default(p, sz, NULL); - } -} - -MA_API void ma_free(void* p, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (p == NULL) { - return; - } - - if (pAllocationCallbacks != NULL) { - if (pAllocationCallbacks->onFree != NULL) { - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } else { - return; /* Do no fall back to the default implementation. */ - } - } else { - ma__free_default(p, NULL); - } -} - -MA_API void* ma_aligned_malloc(size_t sz, size_t alignment, const ma_allocation_callbacks* pAllocationCallbacks) -{ - size_t extraBytes; - void* pUnaligned; - void* pAligned; - - if (alignment == 0) { - return 0; - } - - extraBytes = alignment-1 + sizeof(void*); - - pUnaligned = ma_malloc(sz + extraBytes, pAllocationCallbacks); - if (pUnaligned == NULL) { - return NULL; - } - - pAligned = (void*)(((ma_uintptr)pUnaligned + extraBytes) & ~((ma_uintptr)(alignment-1))); - ((void**)pAligned)[-1] = pUnaligned; - - return pAligned; -} - -MA_API void ma_aligned_free(void* p, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_free(((void**)p)[-1], pAllocationCallbacks); -} - -MA_API const char* ma_get_format_name(ma_format format) -{ - switch (format) - { - case ma_format_unknown: return "Unknown"; - case ma_format_u8: return "8-bit Unsigned Integer"; - case ma_format_s16: return "16-bit Signed Integer"; - case ma_format_s24: return "24-bit Signed Integer (Tightly Packed)"; - case ma_format_s32: return "32-bit Signed Integer"; - case ma_format_f32: return "32-bit IEEE Floating Point"; - default: return "Invalid"; - } -} - -MA_API void ma_blend_f32(float* pOut, float* pInA, float* pInB, float factor, ma_uint32 channels) -{ - ma_uint32 i; - for (i = 0; i < channels; ++i) { - pOut[i] = ma_mix_f32(pInA[i], pInB[i], factor); - } -} - - -MA_API ma_uint32 ma_get_bytes_per_sample(ma_format format) -{ - ma_uint32 sizes[] = { - 0, /* unknown */ - 1, /* u8 */ - 2, /* s16 */ - 3, /* s24 */ - 4, /* s32 */ - 4, /* f32 */ - }; - return sizes[format]; -} - - - -#define MA_DATA_SOURCE_DEFAULT_RANGE_BEG 0 -#define MA_DATA_SOURCE_DEFAULT_RANGE_END ~((ma_uint64)0) -#define MA_DATA_SOURCE_DEFAULT_LOOP_POINT_BEG 0 -#define MA_DATA_SOURCE_DEFAULT_LOOP_POINT_END ~((ma_uint64)0) - -MA_API ma_data_source_config ma_data_source_config_init(void) -{ - ma_data_source_config config; - - MA_ZERO_OBJECT(&config); - - return config; -} - - -MA_API ma_result ma_data_source_init(const ma_data_source_config* pConfig, ma_data_source* pDataSource) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDataSourceBase); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - pDataSourceBase->vtable = pConfig->vtable; - pDataSourceBase->rangeBegInFrames = MA_DATA_SOURCE_DEFAULT_RANGE_BEG; - pDataSourceBase->rangeEndInFrames = MA_DATA_SOURCE_DEFAULT_RANGE_END; - pDataSourceBase->loopBegInFrames = MA_DATA_SOURCE_DEFAULT_LOOP_POINT_BEG; - pDataSourceBase->loopEndInFrames = MA_DATA_SOURCE_DEFAULT_LOOP_POINT_END; - pDataSourceBase->pCurrent = pDataSource; /* Always read from ourself by default. */ - pDataSourceBase->pNext = NULL; - pDataSourceBase->onGetNext = NULL; - - return MA_SUCCESS; -} - -MA_API void ma_data_source_uninit(ma_data_source* pDataSource) -{ - if (pDataSource == NULL) { - return; - } - - /* - This is placeholder in case we need this later. Data sources need to call this in their - uninitialization routine to ensure things work later on if something is added here. - */ -} - -static ma_result ma_data_source_resolve_current(ma_data_source* pDataSource, ma_data_source** ppCurrentDataSource) -{ - ma_data_source_base* pCurrentDataSource = (ma_data_source_base*)pDataSource; - - MA_ASSERT(pDataSource != NULL); - MA_ASSERT(ppCurrentDataSource != NULL); - - if (pCurrentDataSource->pCurrent == NULL) { - /* - The current data source is NULL. If we're using this in the context of a chain we need to return NULL - here so that we don't end up looping. Otherwise we just return the data source itself. - */ - if (pCurrentDataSource->pNext != NULL || pCurrentDataSource->onGetNext != NULL) { - pCurrentDataSource = NULL; - } else { - pCurrentDataSource = (ma_data_source_base*)pDataSource; /* Not being used in a chain. Make sure we just always read from the data source itself at all times. */ - } - } else { - pCurrentDataSource = (ma_data_source_base*)pCurrentDataSource->pCurrent; - } - - *ppCurrentDataSource = pCurrentDataSource; - - return MA_SUCCESS; -} - -static ma_result ma_data_source_read_pcm_frames_within_range(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - ma_result result; - ma_uint64 framesRead = 0; - ma_bool32 loop = ma_data_source_is_looping(pDataSource); - - if (pDataSourceBase == NULL) { - return MA_AT_END; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if ((pDataSourceBase->vtable->flags & MA_DATA_SOURCE_SELF_MANAGED_RANGE_AND_LOOP_POINT) != 0 || (pDataSourceBase->rangeEndInFrames == ~((ma_uint64)0) && (pDataSourceBase->loopEndInFrames == ~((ma_uint64)0) || loop == MA_FALSE))) { - /* Either the data source is self-managing the range, or no range is set - just read like normal. The data source itself will tell us when the end is reached. */ - result = pDataSourceBase->vtable->onRead(pDataSourceBase, pFramesOut, frameCount, &framesRead); - } else { - /* Need to clamp to within the range. */ - ma_uint64 relativeCursor; - ma_uint64 absoluteCursor; - - result = ma_data_source_get_cursor_in_pcm_frames(pDataSourceBase, &relativeCursor); - if (result != MA_SUCCESS) { - /* Failed to retrieve the cursor. Cannot read within a range or loop points. Just read like normal - this may happen for things like noise data sources where it doesn't really matter. */ - result = pDataSourceBase->vtable->onRead(pDataSourceBase, pFramesOut, frameCount, &framesRead); - } else { - ma_uint64 rangeBeg; - ma_uint64 rangeEnd; - - /* We have the cursor. We need to make sure we don't read beyond our range. */ - rangeBeg = pDataSourceBase->rangeBegInFrames; - rangeEnd = pDataSourceBase->rangeEndInFrames; - - absoluteCursor = rangeBeg + relativeCursor; - - /* If looping, make sure we're within range. */ - if (loop) { - if (pDataSourceBase->loopEndInFrames != ~((ma_uint64)0)) { - rangeEnd = ma_min(rangeEnd, pDataSourceBase->rangeBegInFrames + pDataSourceBase->loopEndInFrames); - } - } - - if (frameCount > (rangeEnd - absoluteCursor) && rangeEnd != ~((ma_uint64)0)) { - frameCount = (rangeEnd - absoluteCursor); - } - - /* - If the cursor is sitting on the end of the range the frame count will be set to 0 which can - result in MA_INVALID_ARGS. In this case, we don't want to try reading, but instead return - MA_AT_END so the higher level function can know about it. - */ - if (frameCount > 0) { - result = pDataSourceBase->vtable->onRead(pDataSourceBase, pFramesOut, frameCount, &framesRead); - } else { - result = MA_AT_END; /* The cursor is sitting on the end of the range which means we're at the end. */ - } - } - } - - if (pFramesRead != NULL) { - *pFramesRead = framesRead; - } - - /* We need to make sure MA_AT_END is returned if we hit the end of the range. */ - if (result == MA_SUCCESS && framesRead == 0) { - result = MA_AT_END; - } - - return result; -} - -MA_API ma_result ma_data_source_read_pcm_frames(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - ma_data_source_base* pCurrentDataSource; - void* pRunningFramesOut = pFramesOut; - ma_uint64 totalFramesProcessed = 0; - ma_format format; - ma_uint32 channels; - ma_uint32 emptyLoopCounter = 0; /* Keeps track of how many times 0 frames have been read. For infinite loop detection of sounds with no audio data. */ - ma_bool32 loop; - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pDataSourceBase == NULL) { - return MA_INVALID_ARGS; - } - - loop = ma_data_source_is_looping(pDataSource); - - /* - We need to know the data format so we can advance the output buffer as we read frames. If this - fails, chaining will not work and we'll just read as much as we can from the current source. - */ - if (ma_data_source_get_data_format(pDataSource, &format, &channels, NULL, NULL, 0) != MA_SUCCESS) { - result = ma_data_source_resolve_current(pDataSource, (ma_data_source**)&pCurrentDataSource); - if (result != MA_SUCCESS) { - return result; - } - - return ma_data_source_read_pcm_frames_within_range(pCurrentDataSource, pFramesOut, frameCount, pFramesRead); - } - - /* - Looping is a bit of a special case. When the `loop` argument is true, chaining will not work and - only the current data source will be read from. - */ - - /* Keep reading until we've read as many frames as possible. */ - while (totalFramesProcessed < frameCount) { - ma_uint64 framesProcessed; - ma_uint64 framesRemaining = frameCount - totalFramesProcessed; - - /* We need to resolve the data source that we'll actually be reading from. */ - result = ma_data_source_resolve_current(pDataSource, (ma_data_source**)&pCurrentDataSource); - if (result != MA_SUCCESS) { - break; - } - - if (pCurrentDataSource == NULL) { - break; - } - - result = ma_data_source_read_pcm_frames_within_range(pCurrentDataSource, pRunningFramesOut, framesRemaining, &framesProcessed); - totalFramesProcessed += framesProcessed; - - /* - If we encounted an error from the read callback, make sure it's propagated to the caller. The caller may need to know whether or not MA_BUSY is returned which is - not necessarily considered an error. - */ - if (result != MA_SUCCESS && result != MA_AT_END) { - break; - } - - /* - We can determine if we've reached the end by checking if ma_data_source_read_pcm_frames_within_range() returned - MA_AT_END. To loop back to the start, all we need to do is seek back to the first frame. - */ - if (result == MA_AT_END) { - /* - The result needs to be reset back to MA_SUCCESS (from MA_AT_END) so that we don't - accidentally return MA_AT_END when data has been read in prior loop iterations. at the - end of this function, the result will be checked for MA_SUCCESS, and if the total - number of frames processed is 0, will be explicitly set to MA_AT_END. - */ - result = MA_SUCCESS; - - /* - We reached the end. If we're looping, we just loop back to the start of the current - data source. If we're not looping we need to check if we have another in the chain, and - if so, switch to it. - */ - if (loop) { - if (framesProcessed == 0) { - emptyLoopCounter += 1; - if (emptyLoopCounter > 1) { - break; /* Infinite loop detected. Get out. */ - } - } else { - emptyLoopCounter = 0; - } - - result = ma_data_source_seek_to_pcm_frame(pCurrentDataSource, pCurrentDataSource->loopBegInFrames); - if (result != MA_SUCCESS) { - break; /* Failed to loop. Abort. */ - } - - /* Don't return MA_AT_END for looping sounds. */ - result = MA_SUCCESS; - } else { - if (pCurrentDataSource->pNext != NULL) { - pDataSourceBase->pCurrent = pCurrentDataSource->pNext; - } else if (pCurrentDataSource->onGetNext != NULL) { - pDataSourceBase->pCurrent = pCurrentDataSource->onGetNext(pCurrentDataSource); - if (pDataSourceBase->pCurrent == NULL) { - break; /* Our callback did not return a next data source. We're done. */ - } - } else { - /* Reached the end of the chain. We're done. */ - break; - } - - /* The next data source needs to be rewound to ensure data is read in looping scenarios. */ - result = ma_data_source_seek_to_pcm_frame(pDataSourceBase->pCurrent, 0); - if (result != MA_SUCCESS) { - break; - } - } - } - - if (pRunningFramesOut != NULL) { - pRunningFramesOut = ma_offset_ptr(pRunningFramesOut, framesProcessed * ma_get_bytes_per_frame(format, channels)); - } - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesProcessed; - } - - MA_ASSERT(!(result == MA_AT_END && totalFramesProcessed > 0)); /* We should never be returning MA_AT_END if we read some data. */ - - if (result == MA_SUCCESS && totalFramesProcessed == 0) { - result = MA_AT_END; - } - - return result; -} - -MA_API ma_result ma_data_source_seek_pcm_frames(ma_data_source* pDataSource, ma_uint64 frameCount, ma_uint64* pFramesSeeked) -{ - return ma_data_source_read_pcm_frames(pDataSource, NULL, frameCount, pFramesSeeked); -} - -MA_API ma_result ma_data_source_seek_to_pcm_frame(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSourceBase == NULL) { - return MA_SUCCESS; - } - - if (pDataSourceBase->vtable->onSeek == NULL) { - return MA_NOT_IMPLEMENTED; - } - - if (frameIndex > pDataSourceBase->rangeEndInFrames) { - return MA_INVALID_OPERATION; /* Trying to seek to far forward. */ - } - - return pDataSourceBase->vtable->onSeek(pDataSource, pDataSourceBase->rangeBegInFrames + frameIndex); -} - -MA_API ma_result ma_data_source_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - ma_result result; - ma_format format; - ma_uint32 channels; - ma_uint32 sampleRate; - - /* Initialize to defaults for safety just in case the data source does not implement this callback. */ - if (pFormat != NULL) { - *pFormat = ma_format_unknown; - } - if (pChannels != NULL) { - *pChannels = 0; - } - if (pSampleRate != NULL) { - *pSampleRate = 0; - } - if (pChannelMap != NULL) { - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channelMapCap); - } - - if (pDataSourceBase == NULL) { - return MA_INVALID_ARGS; - } - - if (pDataSourceBase->vtable->onGetDataFormat == NULL) { - return MA_NOT_IMPLEMENTED; - } - - result = pDataSourceBase->vtable->onGetDataFormat(pDataSource, &format, &channels, &sampleRate, pChannelMap, channelMapCap); - if (result != MA_SUCCESS) { - return result; - } - - if (pFormat != NULL) { - *pFormat = format; - } - if (pChannels != NULL) { - *pChannels = channels; - } - if (pSampleRate != NULL) { - *pSampleRate = sampleRate; - } - - /* Channel map was passed in directly to the callback. This is safe due to the channelMapCap parameter. */ - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_source_get_cursor_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - ma_result result; - ma_uint64 cursor; - - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - if (pDataSourceBase == NULL) { - return MA_SUCCESS; - } - - if (pDataSourceBase->vtable->onGetCursor == NULL) { - return MA_NOT_IMPLEMENTED; - } - - result = pDataSourceBase->vtable->onGetCursor(pDataSourceBase, &cursor); - if (result != MA_SUCCESS) { - return result; - } - - /* The cursor needs to be made relative to the start of the range. */ - if (cursor < pDataSourceBase->rangeBegInFrames) { /* Safety check so we don't return some huge number. */ - *pCursor = 0; - } else { - *pCursor = cursor - pDataSourceBase->rangeBegInFrames; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_source_get_length_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pLength) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; - - if (pDataSourceBase == NULL) { - return MA_INVALID_ARGS; - } - - /* - If we have a range defined we'll use that to determine the length. This is one of rare times - where we'll actually trust the caller. If they've set the range, I think it's mostly safe to - assume they've set it based on some higher level knowledge of the structure of the sound bank. - */ - if (pDataSourceBase->rangeEndInFrames != ~((ma_uint64)0)) { - *pLength = pDataSourceBase->rangeEndInFrames - pDataSourceBase->rangeBegInFrames; - return MA_SUCCESS; - } - - /* - Getting here means a range is not defined so we'll need to get the data source itself to tell - us the length. - */ - if (pDataSourceBase->vtable->onGetLength == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pDataSourceBase->vtable->onGetLength(pDataSource, pLength); -} - -MA_API ma_result ma_data_source_get_cursor_in_seconds(ma_data_source* pDataSource, float* pCursor) -{ - ma_result result; - ma_uint64 cursorInPCMFrames; - ma_uint32 sampleRate; - - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - result = ma_data_source_get_cursor_in_pcm_frames(pDataSource, &cursorInPCMFrames); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_data_source_get_data_format(pDataSource, NULL, NULL, &sampleRate, NULL, 0); - if (result != MA_SUCCESS) { - return result; - } - - /* VC6 does not support division of unsigned 64-bit integers with floating point numbers. Need to use a signed number. This shouldn't effect anything in practice. */ - *pCursor = (ma_int64)cursorInPCMFrames / (float)sampleRate; - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_source_get_length_in_seconds(ma_data_source* pDataSource, float* pLength) -{ - ma_result result; - ma_uint64 lengthInPCMFrames; - ma_uint32 sampleRate; - - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; - - result = ma_data_source_get_length_in_pcm_frames(pDataSource, &lengthInPCMFrames); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_data_source_get_data_format(pDataSource, NULL, NULL, &sampleRate, NULL, 0); - if (result != MA_SUCCESS) { - return result; - } - - /* VC6 does not support division of unsigned 64-bit integers with floating point numbers. Need to use a signed number. This shouldn't effect anything in practice. */ - *pLength = (ma_int64)lengthInPCMFrames / (float)sampleRate; - - return MA_SUCCESS; -} - -MA_API ma_result ma_data_source_set_looping(ma_data_source* pDataSource, ma_bool32 isLooping) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - c89atomic_exchange_32(&pDataSourceBase->isLooping, isLooping); - - /* If there's no callback for this just treat it as a successful no-op. */ - if (pDataSourceBase->vtable->onSetLooping == NULL) { - return MA_SUCCESS; - } - - return pDataSourceBase->vtable->onSetLooping(pDataSource, isLooping); -} - -MA_API ma_bool32 ma_data_source_is_looping(const ma_data_source* pDataSource) -{ - const ma_data_source_base* pDataSourceBase = (const ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_FALSE; - } - - return c89atomic_load_32(&pDataSourceBase->isLooping); -} - -MA_API ma_result ma_data_source_set_range_in_pcm_frames(ma_data_source* pDataSource, ma_uint64 rangeBegInFrames, ma_uint64 rangeEndInFrames) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - ma_result result; - ma_uint64 relativeCursor; - ma_uint64 absoluteCursor; - ma_bool32 doSeekAdjustment = MA_FALSE; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if (rangeEndInFrames < rangeBegInFrames) { - return MA_INVALID_ARGS; /* The end of the range must come after the beginning. */ - } - - /* - We may need to adjust the position of the cursor to ensure it's clamped to the range. Grab it now - so we can calculate it's absolute position before we change the range. - */ - result = ma_data_source_get_cursor_in_pcm_frames(pDataSource, &relativeCursor); - if (result == MA_SUCCESS) { - doSeekAdjustment = MA_TRUE; - absoluteCursor = relativeCursor + pDataSourceBase->rangeBegInFrames; - } else { - /* - We couldn't get the position of the cursor. It probably means the data source has no notion - of a cursor. We'll just leave it at position 0. Don't treat this as an error. - */ - doSeekAdjustment = MA_FALSE; - relativeCursor = 0; - absoluteCursor = 0; - } - - pDataSourceBase->rangeBegInFrames = rangeBegInFrames; - pDataSourceBase->rangeEndInFrames = rangeEndInFrames; - - /* - The commented out logic below was intended to maintain loop points in response to a change in the - range. However, this is not useful because it results in the sound breaking when you move the range - outside of the old loop points. I'm simplifying this by simply resetting the loop points. The - caller is expected to update their loop points if they change the range. - - In practice this should be mostly a non-issue because the majority of the time the range will be - set once right after initialization. - */ - pDataSourceBase->loopBegInFrames = 0; - pDataSourceBase->loopEndInFrames = ~((ma_uint64)0); - - - /* - Seek to within range. Note that our seek positions here are relative to the new range. We don't want - do do this if we failed to retrieve the cursor earlier on because it probably means the data source - has no notion of a cursor. In practice the seek would probably fail (which we silently ignore), but - I'm just not even going to attempt it. - */ - if (doSeekAdjustment) { - if (absoluteCursor < rangeBegInFrames) { - ma_data_source_seek_to_pcm_frame(pDataSource, 0); - } else if (absoluteCursor > rangeEndInFrames) { - ma_data_source_seek_to_pcm_frame(pDataSource, rangeEndInFrames - rangeBegInFrames); - } - } - - return MA_SUCCESS; -} - -MA_API void ma_data_source_get_range_in_pcm_frames(const ma_data_source* pDataSource, ma_uint64* pRangeBegInFrames, ma_uint64* pRangeEndInFrames) -{ - const ma_data_source_base* pDataSourceBase = (const ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return; - } - - if (pRangeBegInFrames != NULL) { - *pRangeBegInFrames = pDataSourceBase->rangeBegInFrames; - } - - if (pRangeEndInFrames != NULL) { - *pRangeEndInFrames = pDataSourceBase->rangeEndInFrames; - } -} - -MA_API ma_result ma_data_source_set_loop_point_in_pcm_frames(ma_data_source* pDataSource, ma_uint64 loopBegInFrames, ma_uint64 loopEndInFrames) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if (loopEndInFrames < loopBegInFrames) { - return MA_INVALID_ARGS; /* The end of the loop point must come after the beginning. */ - } - - if (loopEndInFrames > pDataSourceBase->rangeEndInFrames && loopEndInFrames != ~((ma_uint64)0)) { - return MA_INVALID_ARGS; /* The end of the loop point must not go beyond the range. */ - } - - pDataSourceBase->loopBegInFrames = loopBegInFrames; - pDataSourceBase->loopEndInFrames = loopEndInFrames; - - /* The end cannot exceed the range. */ - if (pDataSourceBase->loopEndInFrames > (pDataSourceBase->rangeEndInFrames - pDataSourceBase->rangeBegInFrames) && pDataSourceBase->loopEndInFrames != ~((ma_uint64)0)) { - pDataSourceBase->loopEndInFrames = (pDataSourceBase->rangeEndInFrames - pDataSourceBase->rangeBegInFrames); - } - - return MA_SUCCESS; -} - -MA_API void ma_data_source_get_loop_point_in_pcm_frames(const ma_data_source* pDataSource, ma_uint64* pLoopBegInFrames, ma_uint64* pLoopEndInFrames) -{ - const ma_data_source_base* pDataSourceBase = (const ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return; - } - - if (pLoopBegInFrames != NULL) { - *pLoopBegInFrames = pDataSourceBase->loopBegInFrames; - } - - if (pLoopEndInFrames != NULL) { - *pLoopEndInFrames = pDataSourceBase->loopEndInFrames; - } -} - -MA_API ma_result ma_data_source_set_current(ma_data_source* pDataSource, ma_data_source* pCurrentDataSource) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - pDataSourceBase->pCurrent = pCurrentDataSource; - - return MA_SUCCESS; -} - -MA_API ma_data_source* ma_data_source_get_current(const ma_data_source* pDataSource) -{ - const ma_data_source_base* pDataSourceBase = (const ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return NULL; - } - - return pDataSourceBase->pCurrent; -} - -MA_API ma_result ma_data_source_set_next(ma_data_source* pDataSource, ma_data_source* pNextDataSource) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - pDataSourceBase->pNext = pNextDataSource; - - return MA_SUCCESS; -} - -MA_API ma_data_source* ma_data_source_get_next(const ma_data_source* pDataSource) -{ - const ma_data_source_base* pDataSourceBase = (const ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return NULL; - } - - return pDataSourceBase->pNext; -} - -MA_API ma_result ma_data_source_set_next_callback(ma_data_source* pDataSource, ma_data_source_get_next_proc onGetNext) -{ - ma_data_source_base* pDataSourceBase = (ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - pDataSourceBase->onGetNext = onGetNext; - - return MA_SUCCESS; -} - -MA_API ma_data_source_get_next_proc ma_data_source_get_next_callback(const ma_data_source* pDataSource) -{ - const ma_data_source_base* pDataSourceBase = (const ma_data_source_base*)pDataSource; - - if (pDataSource == NULL) { - return NULL; - } - - return pDataSourceBase->onGetNext; -} - - -static ma_result ma_audio_buffer_ref__data_source_on_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_audio_buffer_ref* pAudioBufferRef = (ma_audio_buffer_ref*)pDataSource; - ma_uint64 framesRead = ma_audio_buffer_ref_read_pcm_frames(pAudioBufferRef, pFramesOut, frameCount, MA_FALSE); - - if (pFramesRead != NULL) { - *pFramesRead = framesRead; - } - - if (framesRead < frameCount || framesRead == 0) { - return MA_AT_END; - } - - return MA_SUCCESS; -} - -static ma_result ma_audio_buffer_ref__data_source_on_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_audio_buffer_ref_seek_to_pcm_frame((ma_audio_buffer_ref*)pDataSource, frameIndex); -} - -static ma_result ma_audio_buffer_ref__data_source_on_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - ma_audio_buffer_ref* pAudioBufferRef = (ma_audio_buffer_ref*)pDataSource; - - *pFormat = pAudioBufferRef->format; - *pChannels = pAudioBufferRef->channels; - *pSampleRate = pAudioBufferRef->sampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pAudioBufferRef->channels); - - return MA_SUCCESS; -} - -static ma_result ma_audio_buffer_ref__data_source_on_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - ma_audio_buffer_ref* pAudioBufferRef = (ma_audio_buffer_ref*)pDataSource; - - *pCursor = pAudioBufferRef->cursor; - - return MA_SUCCESS; -} - -static ma_result ma_audio_buffer_ref__data_source_on_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - ma_audio_buffer_ref* pAudioBufferRef = (ma_audio_buffer_ref*)pDataSource; - - *pLength = pAudioBufferRef->sizeInFrames; - - return MA_SUCCESS; -} - -static ma_data_source_vtable g_ma_audio_buffer_ref_data_source_vtable = -{ - ma_audio_buffer_ref__data_source_on_read, - ma_audio_buffer_ref__data_source_on_seek, - ma_audio_buffer_ref__data_source_on_get_data_format, - ma_audio_buffer_ref__data_source_on_get_cursor, - ma_audio_buffer_ref__data_source_on_get_length, - NULL, /* onSetLooping */ - 0 -}; - -MA_API ma_result ma_audio_buffer_ref_init(ma_format format, ma_uint32 channels, const void* pData, ma_uint64 sizeInFrames, ma_audio_buffer_ref* pAudioBufferRef) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pAudioBufferRef); - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_audio_buffer_ref_data_source_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pAudioBufferRef->ds); - if (result != MA_SUCCESS) { - return result; - } - - pAudioBufferRef->format = format; - pAudioBufferRef->channels = channels; - pAudioBufferRef->sampleRate = 0; /* TODO: Version 0.12. Set this to sampleRate. */ - pAudioBufferRef->cursor = 0; - pAudioBufferRef->sizeInFrames = sizeInFrames; - pAudioBufferRef->pData = pData; - - return MA_SUCCESS; -} - -MA_API void ma_audio_buffer_ref_uninit(ma_audio_buffer_ref* pAudioBufferRef) -{ - if (pAudioBufferRef == NULL) { - return; - } - - ma_data_source_uninit(&pAudioBufferRef->ds); -} - -MA_API ma_result ma_audio_buffer_ref_set_data(ma_audio_buffer_ref* pAudioBufferRef, const void* pData, ma_uint64 sizeInFrames) -{ - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - pAudioBufferRef->cursor = 0; - pAudioBufferRef->sizeInFrames = sizeInFrames; - pAudioBufferRef->pData = pData; - - return MA_SUCCESS; -} - -MA_API ma_uint64 ma_audio_buffer_ref_read_pcm_frames(ma_audio_buffer_ref* pAudioBufferRef, void* pFramesOut, ma_uint64 frameCount, ma_bool32 loop) -{ - ma_uint64 totalFramesRead = 0; - - if (pAudioBufferRef == NULL) { - return 0; - } - - if (frameCount == 0) { - return 0; - } - - while (totalFramesRead < frameCount) { - ma_uint64 framesAvailable = pAudioBufferRef->sizeInFrames - pAudioBufferRef->cursor; - ma_uint64 framesRemaining = frameCount - totalFramesRead; - ma_uint64 framesToRead; - - framesToRead = framesRemaining; - if (framesToRead > framesAvailable) { - framesToRead = framesAvailable; - } - - if (pFramesOut != NULL) { - ma_copy_pcm_frames(ma_offset_ptr(pFramesOut, totalFramesRead * ma_get_bytes_per_frame(pAudioBufferRef->format, pAudioBufferRef->channels)), ma_offset_ptr(pAudioBufferRef->pData, pAudioBufferRef->cursor * ma_get_bytes_per_frame(pAudioBufferRef->format, pAudioBufferRef->channels)), framesToRead, pAudioBufferRef->format, pAudioBufferRef->channels); - } - - totalFramesRead += framesToRead; - - pAudioBufferRef->cursor += framesToRead; - if (pAudioBufferRef->cursor == pAudioBufferRef->sizeInFrames) { - if (loop) { - pAudioBufferRef->cursor = 0; - } else { - break; /* We've reached the end and we're not looping. Done. */ - } - } - - MA_ASSERT(pAudioBufferRef->cursor < pAudioBufferRef->sizeInFrames); - } - - return totalFramesRead; -} - -MA_API ma_result ma_audio_buffer_ref_seek_to_pcm_frame(ma_audio_buffer_ref* pAudioBufferRef, ma_uint64 frameIndex) -{ - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - if (frameIndex > pAudioBufferRef->sizeInFrames) { - return MA_INVALID_ARGS; - } - - pAudioBufferRef->cursor = (size_t)frameIndex; - - return MA_SUCCESS; -} - -MA_API ma_result ma_audio_buffer_ref_map(ma_audio_buffer_ref* pAudioBufferRef, void** ppFramesOut, ma_uint64* pFrameCount) -{ - ma_uint64 framesAvailable; - ma_uint64 frameCount = 0; - - if (ppFramesOut != NULL) { - *ppFramesOut = NULL; /* Safety. */ - } - - if (pFrameCount != NULL) { - frameCount = *pFrameCount; - *pFrameCount = 0; /* Safety. */ - } - - if (pAudioBufferRef == NULL || ppFramesOut == NULL || pFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - framesAvailable = pAudioBufferRef->sizeInFrames - pAudioBufferRef->cursor; - if (frameCount > framesAvailable) { - frameCount = framesAvailable; - } - - *ppFramesOut = ma_offset_ptr(pAudioBufferRef->pData, pAudioBufferRef->cursor * ma_get_bytes_per_frame(pAudioBufferRef->format, pAudioBufferRef->channels)); - *pFrameCount = frameCount; - - return MA_SUCCESS; -} - -MA_API ma_result ma_audio_buffer_ref_unmap(ma_audio_buffer_ref* pAudioBufferRef, ma_uint64 frameCount) -{ - ma_uint64 framesAvailable; - - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - framesAvailable = pAudioBufferRef->sizeInFrames - pAudioBufferRef->cursor; - if (frameCount > framesAvailable) { - return MA_INVALID_ARGS; /* The frame count was too big. This should never happen in an unmapping. Need to make sure the caller is aware of this. */ - } - - pAudioBufferRef->cursor += frameCount; - - if (pAudioBufferRef->cursor == pAudioBufferRef->sizeInFrames) { - return MA_AT_END; /* Successful. Need to tell the caller that the end has been reached so that it can loop if desired. */ - } else { - return MA_SUCCESS; - } -} - -MA_API ma_bool32 ma_audio_buffer_ref_at_end(const ma_audio_buffer_ref* pAudioBufferRef) -{ - if (pAudioBufferRef == NULL) { - return MA_FALSE; - } - - return pAudioBufferRef->cursor == pAudioBufferRef->sizeInFrames; -} - -MA_API ma_result ma_audio_buffer_ref_get_cursor_in_pcm_frames(const ma_audio_buffer_ref* pAudioBufferRef, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = pAudioBufferRef->cursor; - - return MA_SUCCESS; -} - -MA_API ma_result ma_audio_buffer_ref_get_length_in_pcm_frames(const ma_audio_buffer_ref* pAudioBufferRef, ma_uint64* pLength) -{ - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; - - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = pAudioBufferRef->sizeInFrames; - - return MA_SUCCESS; -} - -MA_API ma_result ma_audio_buffer_ref_get_available_frames(const ma_audio_buffer_ref* pAudioBufferRef, ma_uint64* pAvailableFrames) -{ - if (pAvailableFrames == NULL) { - return MA_INVALID_ARGS; - } - - *pAvailableFrames = 0; - - if (pAudioBufferRef == NULL) { - return MA_INVALID_ARGS; - } - - if (pAudioBufferRef->sizeInFrames <= pAudioBufferRef->cursor) { - *pAvailableFrames = 0; - } else { - *pAvailableFrames = pAudioBufferRef->sizeInFrames - pAudioBufferRef->cursor; - } - - return MA_SUCCESS; -} - - - - -MA_API ma_audio_buffer_config ma_audio_buffer_config_init(ma_format format, ma_uint32 channels, ma_uint64 sizeInFrames, const void* pData, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_audio_buffer_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = 0; /* TODO: Version 0.12. Set this to sampleRate. */ - config.sizeInFrames = sizeInFrames; - config.pData = pData; - ma_allocation_callbacks_init_copy(&config.allocationCallbacks, pAllocationCallbacks); - - return config; -} - -static ma_result ma_audio_buffer_init_ex(const ma_audio_buffer_config* pConfig, ma_bool32 doCopy, ma_audio_buffer* pAudioBuffer) -{ - ma_result result; - - if (pAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_MEMORY(pAudioBuffer, sizeof(*pAudioBuffer) - sizeof(pAudioBuffer->_pExtraData)); /* Safety. Don't overwrite the extra data. */ - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->sizeInFrames == 0) { - return MA_INVALID_ARGS; /* Not allowing buffer sizes of 0 frames. */ - } - - result = ma_audio_buffer_ref_init(pConfig->format, pConfig->channels, NULL, 0, &pAudioBuffer->ref); - if (result != MA_SUCCESS) { - return result; - } - - /* TODO: Version 0.12. Set this in ma_audio_buffer_ref_init() instead of here. */ - pAudioBuffer->ref.sampleRate = pConfig->sampleRate; - - ma_allocation_callbacks_init_copy(&pAudioBuffer->allocationCallbacks, &pConfig->allocationCallbacks); - - if (doCopy) { - ma_uint64 allocationSizeInBytes; - void* pData; - - allocationSizeInBytes = pConfig->sizeInFrames * ma_get_bytes_per_frame(pConfig->format, pConfig->channels); - if (allocationSizeInBytes > MA_SIZE_MAX) { - return MA_OUT_OF_MEMORY; /* Too big. */ - } - - pData = ma_malloc((size_t)allocationSizeInBytes, &pAudioBuffer->allocationCallbacks); /* Safe cast to size_t. */ - if (pData == NULL) { - return MA_OUT_OF_MEMORY; - } - - if (pConfig->pData != NULL) { - ma_copy_pcm_frames(pData, pConfig->pData, pConfig->sizeInFrames, pConfig->format, pConfig->channels); - } else { - ma_silence_pcm_frames(pData, pConfig->sizeInFrames, pConfig->format, pConfig->channels); - } - - ma_audio_buffer_ref_set_data(&pAudioBuffer->ref, pData, pConfig->sizeInFrames); - pAudioBuffer->ownsData = MA_TRUE; - } else { - ma_audio_buffer_ref_set_data(&pAudioBuffer->ref, pConfig->pData, pConfig->sizeInFrames); - pAudioBuffer->ownsData = MA_FALSE; - } - - return MA_SUCCESS; -} - -static void ma_audio_buffer_uninit_ex(ma_audio_buffer* pAudioBuffer, ma_bool32 doFree) -{ - if (pAudioBuffer == NULL) { - return; - } - - if (pAudioBuffer->ownsData && pAudioBuffer->ref.pData != &pAudioBuffer->_pExtraData[0]) { - ma_free((void*)pAudioBuffer->ref.pData, &pAudioBuffer->allocationCallbacks); /* Naugty const cast, but OK in this case since we've guarded it with the ownsData check. */ - } - - if (doFree) { - ma_free(pAudioBuffer, &pAudioBuffer->allocationCallbacks); - } - - ma_audio_buffer_ref_uninit(&pAudioBuffer->ref); -} - -MA_API ma_result ma_audio_buffer_init(const ma_audio_buffer_config* pConfig, ma_audio_buffer* pAudioBuffer) -{ - return ma_audio_buffer_init_ex(pConfig, MA_FALSE, pAudioBuffer); -} - -MA_API ma_result ma_audio_buffer_init_copy(const ma_audio_buffer_config* pConfig, ma_audio_buffer* pAudioBuffer) -{ - return ma_audio_buffer_init_ex(pConfig, MA_TRUE, pAudioBuffer); -} - -MA_API ma_result ma_audio_buffer_alloc_and_init(const ma_audio_buffer_config* pConfig, ma_audio_buffer** ppAudioBuffer) -{ - ma_result result; - ma_audio_buffer* pAudioBuffer; - ma_audio_buffer_config innerConfig; /* We'll be making some changes to the config, so need to make a copy. */ - ma_uint64 allocationSizeInBytes; - - if (ppAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - *ppAudioBuffer = NULL; /* Safety. */ - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - innerConfig = *pConfig; - ma_allocation_callbacks_init_copy(&innerConfig.allocationCallbacks, &pConfig->allocationCallbacks); - - allocationSizeInBytes = sizeof(*pAudioBuffer) - sizeof(pAudioBuffer->_pExtraData) + (pConfig->sizeInFrames * ma_get_bytes_per_frame(pConfig->format, pConfig->channels)); - if (allocationSizeInBytes > MA_SIZE_MAX) { - return MA_OUT_OF_MEMORY; /* Too big. */ - } - - pAudioBuffer = (ma_audio_buffer*)ma_malloc((size_t)allocationSizeInBytes, &innerConfig.allocationCallbacks); /* Safe cast to size_t. */ - if (pAudioBuffer == NULL) { - return MA_OUT_OF_MEMORY; - } - - if (pConfig->pData != NULL) { - ma_copy_pcm_frames(&pAudioBuffer->_pExtraData[0], pConfig->pData, pConfig->sizeInFrames, pConfig->format, pConfig->channels); - } else { - ma_silence_pcm_frames(&pAudioBuffer->_pExtraData[0], pConfig->sizeInFrames, pConfig->format, pConfig->channels); - } - - innerConfig.pData = &pAudioBuffer->_pExtraData[0]; - - result = ma_audio_buffer_init_ex(&innerConfig, MA_FALSE, pAudioBuffer); - if (result != MA_SUCCESS) { - ma_free(pAudioBuffer, &innerConfig.allocationCallbacks); - return result; - } - - *ppAudioBuffer = pAudioBuffer; - - return MA_SUCCESS; -} - -MA_API void ma_audio_buffer_uninit(ma_audio_buffer* pAudioBuffer) -{ - ma_audio_buffer_uninit_ex(pAudioBuffer, MA_FALSE); -} - -MA_API void ma_audio_buffer_uninit_and_free(ma_audio_buffer* pAudioBuffer) -{ - ma_audio_buffer_uninit_ex(pAudioBuffer, MA_TRUE); -} - -MA_API ma_uint64 ma_audio_buffer_read_pcm_frames(ma_audio_buffer* pAudioBuffer, void* pFramesOut, ma_uint64 frameCount, ma_bool32 loop) -{ - if (pAudioBuffer == NULL) { - return 0; - } - - return ma_audio_buffer_ref_read_pcm_frames(&pAudioBuffer->ref, pFramesOut, frameCount, loop); -} - -MA_API ma_result ma_audio_buffer_seek_to_pcm_frame(ma_audio_buffer* pAudioBuffer, ma_uint64 frameIndex) -{ - if (pAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_audio_buffer_ref_seek_to_pcm_frame(&pAudioBuffer->ref, frameIndex); -} - -MA_API ma_result ma_audio_buffer_map(ma_audio_buffer* pAudioBuffer, void** ppFramesOut, ma_uint64* pFrameCount) -{ - if (ppFramesOut != NULL) { - *ppFramesOut = NULL; /* Safety. */ - } - - if (pAudioBuffer == NULL) { - if (pFrameCount != NULL) { - *pFrameCount = 0; - } - - return MA_INVALID_ARGS; - } - - return ma_audio_buffer_ref_map(&pAudioBuffer->ref, ppFramesOut, pFrameCount); -} - -MA_API ma_result ma_audio_buffer_unmap(ma_audio_buffer* pAudioBuffer, ma_uint64 frameCount) -{ - if (pAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_audio_buffer_ref_unmap(&pAudioBuffer->ref, frameCount); -} - -MA_API ma_bool32 ma_audio_buffer_at_end(const ma_audio_buffer* pAudioBuffer) -{ - if (pAudioBuffer == NULL) { - return MA_FALSE; - } - - return ma_audio_buffer_ref_at_end(&pAudioBuffer->ref); -} - -MA_API ma_result ma_audio_buffer_get_cursor_in_pcm_frames(const ma_audio_buffer* pAudioBuffer, ma_uint64* pCursor) -{ - if (pAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_audio_buffer_ref_get_cursor_in_pcm_frames(&pAudioBuffer->ref, pCursor); -} - -MA_API ma_result ma_audio_buffer_get_length_in_pcm_frames(const ma_audio_buffer* pAudioBuffer, ma_uint64* pLength) -{ - if (pAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_audio_buffer_ref_get_length_in_pcm_frames(&pAudioBuffer->ref, pLength); -} - -MA_API ma_result ma_audio_buffer_get_available_frames(const ma_audio_buffer* pAudioBuffer, ma_uint64* pAvailableFrames) -{ - if (pAvailableFrames == NULL) { - return MA_INVALID_ARGS; - } - - *pAvailableFrames = 0; - - if (pAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - return ma_audio_buffer_ref_get_available_frames(&pAudioBuffer->ref, pAvailableFrames); -} - - - - - -MA_API ma_result ma_paged_audio_buffer_data_init(ma_format format, ma_uint32 channels, ma_paged_audio_buffer_data* pData) -{ - if (pData == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pData); - - pData->format = format; - pData->channels = channels; - pData->pTail = &pData->head; - - return MA_SUCCESS; -} - -MA_API void ma_paged_audio_buffer_data_uninit(ma_paged_audio_buffer_data* pData, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_paged_audio_buffer_page* pPage; - - if (pData == NULL) { - return; - } - - /* All pages need to be freed. */ - pPage = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pData->head.pNext); - while (pPage != NULL) { - ma_paged_audio_buffer_page* pNext = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pPage->pNext); - - ma_free(pPage, pAllocationCallbacks); - pPage = pNext; - } -} - -MA_API ma_paged_audio_buffer_page* ma_paged_audio_buffer_data_get_head(ma_paged_audio_buffer_data* pData) -{ - if (pData == NULL) { - return NULL; - } - - return &pData->head; -} - -MA_API ma_paged_audio_buffer_page* ma_paged_audio_buffer_data_get_tail(ma_paged_audio_buffer_data* pData) -{ - if (pData == NULL) { - return NULL; - } - - return pData->pTail; -} - -MA_API ma_result ma_paged_audio_buffer_data_get_length_in_pcm_frames(ma_paged_audio_buffer_data* pData, ma_uint64* pLength) -{ - ma_paged_audio_buffer_page* pPage; - - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; - - if (pData == NULL) { - return MA_INVALID_ARGS; - } - - /* Calculate the length from the linked list. */ - for (pPage = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pData->head.pNext); pPage != NULL; pPage = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pPage->pNext)) { - *pLength += pPage->sizeInFrames; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_paged_audio_buffer_data_allocate_page(ma_paged_audio_buffer_data* pData, ma_uint64 pageSizeInFrames, const void* pInitialData, const ma_allocation_callbacks* pAllocationCallbacks, ma_paged_audio_buffer_page** ppPage) -{ - ma_paged_audio_buffer_page* pPage; - ma_uint64 allocationSize; - - if (ppPage == NULL) { - return MA_INVALID_ARGS; - } - - *ppPage = NULL; - - if (pData == NULL) { - return MA_INVALID_ARGS; - } - - allocationSize = sizeof(*pPage) + (pageSizeInFrames * ma_get_bytes_per_frame(pData->format, pData->channels)); - if (allocationSize > MA_SIZE_MAX) { - return MA_OUT_OF_MEMORY; /* Too big. */ - } - - pPage = (ma_paged_audio_buffer_page*)ma_malloc((size_t)allocationSize, pAllocationCallbacks); /* Safe cast to size_t. */ - if (pPage == NULL) { - return MA_OUT_OF_MEMORY; - } - - pPage->pNext = NULL; - pPage->sizeInFrames = pageSizeInFrames; - - if (pInitialData != NULL) { - ma_copy_pcm_frames(pPage->pAudioData, pInitialData, pageSizeInFrames, pData->format, pData->channels); - } - - *ppPage = pPage; - - return MA_SUCCESS; -} - -MA_API ma_result ma_paged_audio_buffer_data_free_page(ma_paged_audio_buffer_data* pData, ma_paged_audio_buffer_page* pPage, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pData == NULL || pPage == NULL) { - return MA_INVALID_ARGS; - } - - /* It's assumed the page is not attached to the list. */ - ma_free(pPage, pAllocationCallbacks); - - return MA_SUCCESS; -} - -MA_API ma_result ma_paged_audio_buffer_data_append_page(ma_paged_audio_buffer_data* pData, ma_paged_audio_buffer_page* pPage) -{ - if (pData == NULL || pPage == NULL) { - return MA_INVALID_ARGS; - } - - /* This function assumes the page has been filled with audio data by this point. As soon as we append, the page will be available for reading. */ - - /* First thing to do is update the tail. */ - for (;;) { - ma_paged_audio_buffer_page* pOldTail = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pData->pTail); - ma_paged_audio_buffer_page* pNewTail = pPage; - - if (c89atomic_compare_exchange_weak_ptr((volatile void**)&pData->pTail, (void**)&pOldTail, pNewTail)) { - /* Here is where we append the page to the list. After this, the page is attached to the list and ready to be read from. */ - c89atomic_exchange_ptr(&pOldTail->pNext, pPage); - break; /* Done. */ - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_paged_audio_buffer_data_allocate_and_append_page(ma_paged_audio_buffer_data* pData, ma_uint32 pageSizeInFrames, const void* pInitialData, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_result result; - ma_paged_audio_buffer_page* pPage; - - result = ma_paged_audio_buffer_data_allocate_page(pData, pageSizeInFrames, pInitialData, pAllocationCallbacks, &pPage); - if (result != MA_SUCCESS) { - return result; - } - - return ma_paged_audio_buffer_data_append_page(pData, pPage); /* <-- Should never fail. */ -} - - -MA_API ma_paged_audio_buffer_config ma_paged_audio_buffer_config_init(ma_paged_audio_buffer_data* pData) -{ - ma_paged_audio_buffer_config config; - - MA_ZERO_OBJECT(&config); - config.pData = pData; - - return config; -} - - -static ma_result ma_paged_audio_buffer__data_source_on_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_paged_audio_buffer_read_pcm_frames((ma_paged_audio_buffer*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_paged_audio_buffer__data_source_on_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_paged_audio_buffer_seek_to_pcm_frame((ma_paged_audio_buffer*)pDataSource, frameIndex); -} - -static ma_result ma_paged_audio_buffer__data_source_on_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - ma_paged_audio_buffer* pPagedAudioBuffer = (ma_paged_audio_buffer*)pDataSource; - - *pFormat = pPagedAudioBuffer->pData->format; - *pChannels = pPagedAudioBuffer->pData->channels; - *pSampleRate = 0; /* There is no notion of a sample rate with audio buffers. */ - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pPagedAudioBuffer->pData->channels); - - return MA_SUCCESS; -} - -static ma_result ma_paged_audio_buffer__data_source_on_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_paged_audio_buffer_get_cursor_in_pcm_frames((ma_paged_audio_buffer*)pDataSource, pCursor); -} - -static ma_result ma_paged_audio_buffer__data_source_on_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_paged_audio_buffer_get_length_in_pcm_frames((ma_paged_audio_buffer*)pDataSource, pLength); -} - -static ma_data_source_vtable g_ma_paged_audio_buffer_data_source_vtable = -{ - ma_paged_audio_buffer__data_source_on_read, - ma_paged_audio_buffer__data_source_on_seek, - ma_paged_audio_buffer__data_source_on_get_data_format, - ma_paged_audio_buffer__data_source_on_get_cursor, - ma_paged_audio_buffer__data_source_on_get_length, - NULL, /* onSetLooping */ - 0 -}; - -MA_API ma_result ma_paged_audio_buffer_init(const ma_paged_audio_buffer_config* pConfig, ma_paged_audio_buffer* pPagedAudioBuffer) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - if (pPagedAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pPagedAudioBuffer); - - /* A config is required for the format and channel count. */ - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->pData == NULL) { - return MA_INVALID_ARGS; /* No underlying data specified. */ - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_paged_audio_buffer_data_source_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pPagedAudioBuffer->ds); - if (result != MA_SUCCESS) { - return result; - } - - pPagedAudioBuffer->pData = pConfig->pData; - pPagedAudioBuffer->pCurrent = ma_paged_audio_buffer_data_get_head(pConfig->pData); - pPagedAudioBuffer->relativeCursor = 0; - pPagedAudioBuffer->absoluteCursor = 0; - - return MA_SUCCESS; -} - -MA_API void ma_paged_audio_buffer_uninit(ma_paged_audio_buffer* pPagedAudioBuffer) -{ - if (pPagedAudioBuffer == NULL) { - return; - } - - /* Nothing to do. The data needs to be deleted separately. */ -} - -MA_API ma_result ma_paged_audio_buffer_read_pcm_frames(ma_paged_audio_buffer* pPagedAudioBuffer, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint64 totalFramesRead = 0; - ma_format format; - ma_uint32 channels; - - if (pPagedAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - format = pPagedAudioBuffer->pData->format; - channels = pPagedAudioBuffer->pData->channels; - - while (totalFramesRead < frameCount) { - /* Read from the current page. The buffer should never be in a state where this is NULL. */ - ma_uint64 framesRemainingInCurrentPage; - ma_uint64 framesRemainingToRead = frameCount - totalFramesRead; - ma_uint64 framesToReadThisIteration; - - MA_ASSERT(pPagedAudioBuffer->pCurrent != NULL); - - framesRemainingInCurrentPage = pPagedAudioBuffer->pCurrent->sizeInFrames - pPagedAudioBuffer->relativeCursor; - - framesToReadThisIteration = ma_min(framesRemainingInCurrentPage, framesRemainingToRead); - ma_copy_pcm_frames(ma_offset_pcm_frames_ptr(pFramesOut, totalFramesRead, format, channels), ma_offset_pcm_frames_ptr(pPagedAudioBuffer->pCurrent->pAudioData, pPagedAudioBuffer->relativeCursor, format, channels), framesToReadThisIteration, format, channels); - totalFramesRead += framesToReadThisIteration; - - pPagedAudioBuffer->absoluteCursor += framesToReadThisIteration; - pPagedAudioBuffer->relativeCursor += framesToReadThisIteration; - - /* Move to the next page if necessary. If there's no more pages, we need to return MA_AT_END. */ - MA_ASSERT(pPagedAudioBuffer->relativeCursor <= pPagedAudioBuffer->pCurrent->sizeInFrames); - - if (pPagedAudioBuffer->relativeCursor == pPagedAudioBuffer->pCurrent->sizeInFrames) { - /* We reached the end of the page. Need to move to the next. If there's no more pages, we're done. */ - ma_paged_audio_buffer_page* pNext = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pPagedAudioBuffer->pCurrent->pNext); - if (pNext == NULL) { - result = MA_AT_END; - break; /* We've reached the end. */ - } else { - pPagedAudioBuffer->pCurrent = pNext; - pPagedAudioBuffer->relativeCursor = 0; - } - } - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - return result; -} - -MA_API ma_result ma_paged_audio_buffer_seek_to_pcm_frame(ma_paged_audio_buffer* pPagedAudioBuffer, ma_uint64 frameIndex) -{ - if (pPagedAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - if (frameIndex == pPagedAudioBuffer->absoluteCursor) { - return MA_SUCCESS; /* Nothing to do. */ - } - - if (frameIndex < pPagedAudioBuffer->absoluteCursor) { - /* Moving backwards. Need to move the cursor back to the start, and then move forward. */ - pPagedAudioBuffer->pCurrent = ma_paged_audio_buffer_data_get_head(pPagedAudioBuffer->pData); - pPagedAudioBuffer->absoluteCursor = 0; - pPagedAudioBuffer->relativeCursor = 0; - - /* Fall through to the forward seeking section below. */ - } - - if (frameIndex > pPagedAudioBuffer->absoluteCursor) { - /* Moving forward. */ - ma_paged_audio_buffer_page* pPage; - ma_uint64 runningCursor = 0; - - for (pPage = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&ma_paged_audio_buffer_data_get_head(pPagedAudioBuffer->pData)->pNext); pPage != NULL; pPage = (ma_paged_audio_buffer_page*)c89atomic_load_ptr(&pPage->pNext)) { - ma_uint64 pageRangeBeg = runningCursor; - ma_uint64 pageRangeEnd = pageRangeBeg + pPage->sizeInFrames; - - if (frameIndex >= pageRangeBeg) { - if (frameIndex < pageRangeEnd || (frameIndex == pageRangeEnd && pPage == (ma_paged_audio_buffer_page*)c89atomic_load_ptr(ma_paged_audio_buffer_data_get_tail(pPagedAudioBuffer->pData)))) { /* A small edge case - allow seeking to the very end of the buffer. */ - /* We found the page. */ - pPagedAudioBuffer->pCurrent = pPage; - pPagedAudioBuffer->absoluteCursor = frameIndex; - pPagedAudioBuffer->relativeCursor = frameIndex - pageRangeBeg; - return MA_SUCCESS; - } - } - - runningCursor = pageRangeEnd; - } - - /* Getting here means we tried seeking too far forward. Don't change any state. */ - return MA_BAD_SEEK; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_paged_audio_buffer_get_cursor_in_pcm_frames(ma_paged_audio_buffer* pPagedAudioBuffer, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; /* Safety. */ - - if (pPagedAudioBuffer == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = pPagedAudioBuffer->absoluteCursor; - - return MA_SUCCESS; -} - -MA_API ma_result ma_paged_audio_buffer_get_length_in_pcm_frames(ma_paged_audio_buffer* pPagedAudioBuffer, ma_uint64* pLength) -{ - return ma_paged_audio_buffer_data_get_length_in_pcm_frames(pPagedAudioBuffer->pData, pLength); -} - - - -/************************************************************************************************************************************************************** - -VFS - -**************************************************************************************************************************************************************/ -MA_API ma_result ma_vfs_open(ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pFile == NULL) { - return MA_INVALID_ARGS; - } - - *pFile = NULL; - - if (pVFS == NULL || pFilePath == NULL || openMode == 0) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onOpen == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onOpen(pVFS, pFilePath, openMode, pFile); -} - -MA_API ma_result ma_vfs_open_w(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pFile == NULL) { - return MA_INVALID_ARGS; - } - - *pFile = NULL; - - if (pVFS == NULL || pFilePath == NULL || openMode == 0) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onOpenW == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onOpenW(pVFS, pFilePath, openMode, pFile); -} - -MA_API ma_result ma_vfs_close(ma_vfs* pVFS, ma_vfs_file file) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pVFS == NULL || file == NULL) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onClose == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onClose(pVFS, file); -} - -MA_API ma_result ma_vfs_read(ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - ma_result result; - size_t bytesRead; - - if (pBytesRead != NULL) { - *pBytesRead = 0; - } - - if (pVFS == NULL || file == NULL || pDst == NULL) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onRead == NULL) { - return MA_NOT_IMPLEMENTED; - } - - result = pCallbacks->onRead(pVFS, file, pDst, sizeInBytes, &bytesRead); - - if (pBytesRead != NULL) { - *pBytesRead = bytesRead; - } - - if (result == MA_SUCCESS && bytesRead == 0 && sizeInBytes > 0) { - result = MA_AT_END; - } - - return result; -} - -MA_API ma_result ma_vfs_write(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pBytesWritten != NULL) { - *pBytesWritten = 0; - } - - if (pVFS == NULL || file == NULL || pSrc == NULL) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onWrite == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onWrite(pVFS, file, pSrc, sizeInBytes, pBytesWritten); -} - -MA_API ma_result ma_vfs_seek(ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pVFS == NULL || file == NULL) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onSeek == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onSeek(pVFS, file, offset, origin); -} - -MA_API ma_result ma_vfs_tell(ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - if (pVFS == NULL || file == NULL) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onTell == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onTell(pVFS, file, pCursor); -} - -MA_API ma_result ma_vfs_info(ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo) -{ - ma_vfs_callbacks* pCallbacks = (ma_vfs_callbacks*)pVFS; - - if (pInfo == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pInfo); - - if (pVFS == NULL || file == NULL) { - return MA_INVALID_ARGS; - } - - if (pCallbacks->onInfo == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pCallbacks->onInfo(pVFS, file, pInfo); -} - - -static ma_result ma_vfs_open_and_read_file_ex(ma_vfs* pVFS, const char* pFilePath, const wchar_t* pFilePathW, void** ppData, size_t* pSize, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_result result; - ma_vfs_file file; - ma_file_info info; - void* pData; - size_t bytesRead; - - if (ppData != NULL) { - *ppData = NULL; - } - if (pSize != NULL) { - *pSize = 0; - } - - if (ppData == NULL) { - return MA_INVALID_ARGS; - } - - if (pFilePath != NULL) { - result = ma_vfs_open(pVFS, pFilePath, MA_OPEN_MODE_READ, &file); - } else { - result = ma_vfs_open_w(pVFS, pFilePathW, MA_OPEN_MODE_READ, &file); - } - if (result != MA_SUCCESS) { - return result; - } - - result = ma_vfs_info(pVFS, file, &info); - if (result != MA_SUCCESS) { - ma_vfs_close(pVFS, file); - return result; - } - - if (info.sizeInBytes > MA_SIZE_MAX) { - ma_vfs_close(pVFS, file); - return MA_TOO_BIG; - } - - pData = ma_malloc((size_t)info.sizeInBytes, pAllocationCallbacks); /* Safe cast. */ - if (pData == NULL) { - ma_vfs_close(pVFS, file); - return result; - } - - result = ma_vfs_read(pVFS, file, pData, (size_t)info.sizeInBytes, &bytesRead); /* Safe cast. */ - ma_vfs_close(pVFS, file); - - if (result != MA_SUCCESS) { - ma_free(pData, pAllocationCallbacks); - return result; - } - - if (pSize != NULL) { - *pSize = bytesRead; - } - - MA_ASSERT(ppData != NULL); - *ppData = pData; - - return MA_SUCCESS; -} - -MA_API ma_result ma_vfs_open_and_read_file(ma_vfs* pVFS, const char* pFilePath, void** ppData, size_t* pSize, const ma_allocation_callbacks* pAllocationCallbacks) -{ - return ma_vfs_open_and_read_file_ex(pVFS, pFilePath, NULL, ppData, pSize, pAllocationCallbacks); -} - -MA_API ma_result ma_vfs_open_and_read_file_w(ma_vfs* pVFS, const wchar_t* pFilePath, void** ppData, size_t* pSize, const ma_allocation_callbacks* pAllocationCallbacks) -{ - return ma_vfs_open_and_read_file_ex(pVFS, NULL, pFilePath, ppData, pSize, pAllocationCallbacks); -} - - -#if !defined(MA_USE_WIN32_FILEIO) && (defined(MA_WIN32) && defined(MA_WIN32_DESKTOP) && !defined(MA_NO_WIN32_FILEIO) && !defined(MA_POSIX)) - #define MA_USE_WIN32_FILEIO -#endif - -#if defined(MA_USE_WIN32_FILEIO) -static void ma_default_vfs__get_open_settings_win32(ma_uint32 openMode, DWORD* pDesiredAccess, DWORD* pShareMode, DWORD* pCreationDisposition) -{ - *pDesiredAccess = 0; - if ((openMode & MA_OPEN_MODE_READ) != 0) { - *pDesiredAccess |= GENERIC_READ; - } - if ((openMode & MA_OPEN_MODE_WRITE) != 0) { - *pDesiredAccess |= GENERIC_WRITE; - } - - *pShareMode = 0; - if ((openMode & MA_OPEN_MODE_READ) != 0) { - *pShareMode |= FILE_SHARE_READ; - } - - if ((openMode & MA_OPEN_MODE_WRITE) != 0) { - *pCreationDisposition = CREATE_ALWAYS; /* Opening in write mode. Truncate. */ - } else { - *pCreationDisposition = OPEN_EXISTING; /* Opening in read mode. File must exist. */ - } -} - -static ma_result ma_default_vfs_open__win32(ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - HANDLE hFile; - DWORD dwDesiredAccess; - DWORD dwShareMode; - DWORD dwCreationDisposition; - - (void)pVFS; - - ma_default_vfs__get_open_settings_win32(openMode, &dwDesiredAccess, &dwShareMode, &dwCreationDisposition); - - hFile = CreateFileA(pFilePath, dwDesiredAccess, dwShareMode, NULL, dwCreationDisposition, FILE_ATTRIBUTE_NORMAL, NULL); - if (hFile == INVALID_HANDLE_VALUE) { - return ma_result_from_GetLastError(GetLastError()); - } - - *pFile = hFile; - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_open_w__win32(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - HANDLE hFile; - DWORD dwDesiredAccess; - DWORD dwShareMode; - DWORD dwCreationDisposition; - - (void)pVFS; - - ma_default_vfs__get_open_settings_win32(openMode, &dwDesiredAccess, &dwShareMode, &dwCreationDisposition); - - hFile = CreateFileW(pFilePath, dwDesiredAccess, dwShareMode, NULL, dwCreationDisposition, FILE_ATTRIBUTE_NORMAL, NULL); - if (hFile == INVALID_HANDLE_VALUE) { - return ma_result_from_GetLastError(GetLastError()); - } - - *pFile = hFile; - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_close__win32(ma_vfs* pVFS, ma_vfs_file file) -{ - (void)pVFS; - - if (CloseHandle((HANDLE)file) == 0) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - - -static ma_result ma_default_vfs_read__win32(ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead) -{ - ma_result result = MA_SUCCESS; - size_t totalBytesRead; - - (void)pVFS; - - totalBytesRead = 0; - while (totalBytesRead < sizeInBytes) { - size_t bytesRemaining; - DWORD bytesToRead; - DWORD bytesRead; - BOOL readResult; - - bytesRemaining = sizeInBytes - totalBytesRead; - if (bytesRemaining >= 0xFFFFFFFF) { - bytesToRead = 0xFFFFFFFF; - } else { - bytesToRead = (DWORD)bytesRemaining; - } - - readResult = ReadFile((HANDLE)file, ma_offset_ptr(pDst, totalBytesRead), bytesToRead, &bytesRead, NULL); - if (readResult == 1 && bytesRead == 0) { - result = MA_AT_END; - break; /* EOF */ - } - - totalBytesRead += bytesRead; - - if (bytesRead < bytesToRead) { - break; /* EOF */ - } - - if (readResult == 0) { - result = ma_result_from_GetLastError(GetLastError()); - break; - } - } - - if (pBytesRead != NULL) { - *pBytesRead = totalBytesRead; - } - - return result; -} - -static ma_result ma_default_vfs_write__win32(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten) -{ - ma_result result = MA_SUCCESS; - size_t totalBytesWritten; - - (void)pVFS; - - totalBytesWritten = 0; - while (totalBytesWritten < sizeInBytes) { - size_t bytesRemaining; - DWORD bytesToWrite; - DWORD bytesWritten; - BOOL writeResult; - - bytesRemaining = sizeInBytes - totalBytesWritten; - if (bytesRemaining >= 0xFFFFFFFF) { - bytesToWrite = 0xFFFFFFFF; - } else { - bytesToWrite = (DWORD)bytesRemaining; - } - - writeResult = WriteFile((HANDLE)file, ma_offset_ptr(pSrc, totalBytesWritten), bytesToWrite, &bytesWritten, NULL); - totalBytesWritten += bytesWritten; - - if (writeResult == 0) { - result = ma_result_from_GetLastError(GetLastError()); - break; - } - } - - if (pBytesWritten != NULL) { - *pBytesWritten = totalBytesWritten; - } - - return result; -} - - -static ma_result ma_default_vfs_seek__win32(ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin) -{ - LARGE_INTEGER liDistanceToMove; - DWORD dwMoveMethod; - BOOL result; - - (void)pVFS; - - liDistanceToMove.QuadPart = offset; - - /* */ if (origin == ma_seek_origin_current) { - dwMoveMethod = FILE_CURRENT; - } else if (origin == ma_seek_origin_end) { - dwMoveMethod = FILE_END; - } else { - dwMoveMethod = FILE_BEGIN; - } - -#if (defined(_MSC_VER) && _MSC_VER <= 1200) || defined(__DMC__) - /* No SetFilePointerEx() so restrict to 31 bits. */ - if (origin > 0x7FFFFFFF) { - return MA_OUT_OF_RANGE; - } - - result = SetFilePointer((HANDLE)file, (LONG)liDistanceToMove.QuadPart, NULL, dwMoveMethod); -#else - result = SetFilePointerEx((HANDLE)file, liDistanceToMove, NULL, dwMoveMethod); -#endif - if (result == 0) { - return ma_result_from_GetLastError(GetLastError()); - } - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_tell__win32(ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor) -{ - LARGE_INTEGER liZero; - LARGE_INTEGER liTell; - BOOL result; -#if (defined(_MSC_VER) && _MSC_VER <= 1200) || defined(__DMC__) - LONG tell; -#endif - - (void)pVFS; - - liZero.QuadPart = 0; - -#if (defined(_MSC_VER) && _MSC_VER <= 1200) || defined(__DMC__) - result = SetFilePointer((HANDLE)file, (LONG)liZero.QuadPart, &tell, FILE_CURRENT); - liTell.QuadPart = tell; -#else - result = SetFilePointerEx((HANDLE)file, liZero, &liTell, FILE_CURRENT); -#endif - if (result == 0) { - return ma_result_from_GetLastError(GetLastError()); - } - - if (pCursor != NULL) { - *pCursor = liTell.QuadPart; - } - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_info__win32(ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo) -{ - BY_HANDLE_FILE_INFORMATION fi; - BOOL result; - - (void)pVFS; - - result = GetFileInformationByHandle((HANDLE)file, &fi); - if (result == 0) { - return ma_result_from_GetLastError(GetLastError()); - } - - pInfo->sizeInBytes = ((ma_uint64)fi.nFileSizeHigh << 32) | ((ma_uint64)fi.nFileSizeLow); - - return MA_SUCCESS; -} -#else -static ma_result ma_default_vfs_open__stdio(ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - ma_result result; - FILE* pFileStd; - const char* pOpenModeStr; - - MA_ASSERT(pFilePath != NULL); - MA_ASSERT(openMode != 0); - MA_ASSERT(pFile != NULL); - - (void)pVFS; - - if ((openMode & MA_OPEN_MODE_READ) != 0) { - if ((openMode & MA_OPEN_MODE_WRITE) != 0) { - pOpenModeStr = "r+"; - } else { - pOpenModeStr = "rb"; - } - } else { - pOpenModeStr = "wb"; - } - - result = ma_fopen(&pFileStd, pFilePath, pOpenModeStr); - if (result != MA_SUCCESS) { - return result; - } - - *pFile = pFileStd; - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_open_w__stdio(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - ma_result result; - FILE* pFileStd; - const wchar_t* pOpenModeStr; - - MA_ASSERT(pFilePath != NULL); - MA_ASSERT(openMode != 0); - MA_ASSERT(pFile != NULL); - - (void)pVFS; - - if ((openMode & MA_OPEN_MODE_READ) != 0) { - if ((openMode & MA_OPEN_MODE_WRITE) != 0) { - pOpenModeStr = L"r+"; - } else { - pOpenModeStr = L"rb"; - } - } else { - pOpenModeStr = L"wb"; - } - - result = ma_wfopen(&pFileStd, pFilePath, pOpenModeStr, (pVFS != NULL) ? &((ma_default_vfs*)pVFS)->allocationCallbacks : NULL); - if (result != MA_SUCCESS) { - return result; - } - - *pFile = pFileStd; - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_close__stdio(ma_vfs* pVFS, ma_vfs_file file) -{ - MA_ASSERT(file != NULL); - - (void)pVFS; - - fclose((FILE*)file); - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_read__stdio(ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead) -{ - size_t result; - - MA_ASSERT(file != NULL); - MA_ASSERT(pDst != NULL); - - (void)pVFS; - - result = fread(pDst, 1, sizeInBytes, (FILE*)file); - - if (pBytesRead != NULL) { - *pBytesRead = result; - } - - if (result != sizeInBytes) { - if (result == 0 && feof((FILE*)file)) { - return MA_AT_END; - } else { - return ma_result_from_errno(ferror((FILE*)file)); - } - } - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_write__stdio(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten) -{ - size_t result; - - MA_ASSERT(file != NULL); - MA_ASSERT(pSrc != NULL); - - (void)pVFS; - - result = fwrite(pSrc, 1, sizeInBytes, (FILE*)file); - - if (pBytesWritten != NULL) { - *pBytesWritten = result; - } - - if (result != sizeInBytes) { - return ma_result_from_errno(ferror((FILE*)file)); - } - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_seek__stdio(ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin) -{ - int result; - int whence; - - MA_ASSERT(file != NULL); - - (void)pVFS; - - if (origin == ma_seek_origin_start) { - whence = SEEK_SET; - } else if (origin == ma_seek_origin_end) { - whence = SEEK_END; - } else { - whence = SEEK_CUR; - } - -#if defined(_WIN32) - #if defined(_MSC_VER) && _MSC_VER > 1200 - result = _fseeki64((FILE*)file, offset, whence); - #else - /* No _fseeki64() so restrict to 31 bits. */ - if (origin > 0x7FFFFFFF) { - return MA_OUT_OF_RANGE; - } - - result = fseek((FILE*)file, (int)offset, whence); - #endif -#else - result = fseek((FILE*)file, (long int)offset, whence); -#endif - if (result != 0) { - return MA_ERROR; - } - - return MA_SUCCESS; -} - -static ma_result ma_default_vfs_tell__stdio(ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor) -{ - ma_int64 result; - - MA_ASSERT(file != NULL); - MA_ASSERT(pCursor != NULL); - - (void)pVFS; - -#if defined(_WIN32) - #if defined(_MSC_VER) && _MSC_VER > 1200 - result = _ftelli64((FILE*)file); - #else - result = ftell((FILE*)file); - #endif -#else - result = ftell((FILE*)file); -#endif - - *pCursor = result; - - return MA_SUCCESS; -} - -#if !defined(_MSC_VER) && !((defined(_POSIX_C_SOURCE) && _POSIX_C_SOURCE >= 1) || defined(_XOPEN_SOURCE) || defined(_POSIX_SOURCE)) && !defined(MA_BSD) -int fileno(FILE *stream); -#endif - -static ma_result ma_default_vfs_info__stdio(ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo) -{ - int fd; - struct stat info; - - MA_ASSERT(file != NULL); - MA_ASSERT(pInfo != NULL); - - (void)pVFS; - -#if defined(_MSC_VER) - fd = _fileno((FILE*)file); -#else - fd = fileno((FILE*)file); -#endif - - if (fstat(fd, &info) != 0) { - return ma_result_from_errno(errno); - } - - pInfo->sizeInBytes = info.st_size; - - return MA_SUCCESS; -} -#endif - - -static ma_result ma_default_vfs_open(ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - if (pFile == NULL) { - return MA_INVALID_ARGS; - } - - *pFile = NULL; - - if (pFilePath == NULL || openMode == 0) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_open__win32(pVFS, pFilePath, openMode, pFile); -#else - return ma_default_vfs_open__stdio(pVFS, pFilePath, openMode, pFile); -#endif -} - -static ma_result ma_default_vfs_open_w(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - if (pFile == NULL) { - return MA_INVALID_ARGS; - } - - *pFile = NULL; - - if (pFilePath == NULL || openMode == 0) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_open_w__win32(pVFS, pFilePath, openMode, pFile); -#else - return ma_default_vfs_open_w__stdio(pVFS, pFilePath, openMode, pFile); -#endif -} - -static ma_result ma_default_vfs_close(ma_vfs* pVFS, ma_vfs_file file) -{ - if (file == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_close__win32(pVFS, file); -#else - return ma_default_vfs_close__stdio(pVFS, file); -#endif -} - -static ma_result ma_default_vfs_read(ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead) -{ - if (pBytesRead != NULL) { - *pBytesRead = 0; - } - - if (file == NULL || pDst == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_read__win32(pVFS, file, pDst, sizeInBytes, pBytesRead); -#else - return ma_default_vfs_read__stdio(pVFS, file, pDst, sizeInBytes, pBytesRead); -#endif -} - -static ma_result ma_default_vfs_write(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten) -{ - if (pBytesWritten != NULL) { - *pBytesWritten = 0; - } - - if (file == NULL || pSrc == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_write__win32(pVFS, file, pSrc, sizeInBytes, pBytesWritten); -#else - return ma_default_vfs_write__stdio(pVFS, file, pSrc, sizeInBytes, pBytesWritten); -#endif -} - -static ma_result ma_default_vfs_seek(ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin) -{ - if (file == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_seek__win32(pVFS, file, offset, origin); -#else - return ma_default_vfs_seek__stdio(pVFS, file, offset, origin); -#endif -} - -static ma_result ma_default_vfs_tell(ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - if (file == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_tell__win32(pVFS, file, pCursor); -#else - return ma_default_vfs_tell__stdio(pVFS, file, pCursor); -#endif -} - -static ma_result ma_default_vfs_info(ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo) -{ - if (pInfo == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pInfo); - - if (file == NULL) { - return MA_INVALID_ARGS; - } - -#if defined(MA_USE_WIN32_FILEIO) - return ma_default_vfs_info__win32(pVFS, file, pInfo); -#else - return ma_default_vfs_info__stdio(pVFS, file, pInfo); -#endif -} - - -MA_API ma_result ma_default_vfs_init(ma_default_vfs* pVFS, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pVFS == NULL) { - return MA_INVALID_ARGS; - } - - pVFS->cb.onOpen = ma_default_vfs_open; - pVFS->cb.onOpenW = ma_default_vfs_open_w; - pVFS->cb.onClose = ma_default_vfs_close; - pVFS->cb.onRead = ma_default_vfs_read; - pVFS->cb.onWrite = ma_default_vfs_write; - pVFS->cb.onSeek = ma_default_vfs_seek; - pVFS->cb.onTell = ma_default_vfs_tell; - pVFS->cb.onInfo = ma_default_vfs_info; - ma_allocation_callbacks_init_copy(&pVFS->allocationCallbacks, pAllocationCallbacks); - - return MA_SUCCESS; -} - - -MA_API ma_result ma_vfs_or_default_open(ma_vfs* pVFS, const char* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - if (pVFS != NULL) { - return ma_vfs_open(pVFS, pFilePath, openMode, pFile); - } else { - return ma_default_vfs_open(pVFS, pFilePath, openMode, pFile); - } -} - -MA_API ma_result ma_vfs_or_default_open_w(ma_vfs* pVFS, const wchar_t* pFilePath, ma_uint32 openMode, ma_vfs_file* pFile) -{ - if (pVFS != NULL) { - return ma_vfs_open_w(pVFS, pFilePath, openMode, pFile); - } else { - return ma_default_vfs_open_w(pVFS, pFilePath, openMode, pFile); - } -} - -MA_API ma_result ma_vfs_or_default_close(ma_vfs* pVFS, ma_vfs_file file) -{ - if (pVFS != NULL) { - return ma_vfs_close(pVFS, file); - } else { - return ma_default_vfs_close(pVFS, file); - } -} - -MA_API ma_result ma_vfs_or_default_read(ma_vfs* pVFS, ma_vfs_file file, void* pDst, size_t sizeInBytes, size_t* pBytesRead) -{ - if (pVFS != NULL) { - return ma_vfs_read(pVFS, file, pDst, sizeInBytes, pBytesRead); - } else { - return ma_default_vfs_read(pVFS, file, pDst, sizeInBytes, pBytesRead); - } -} - -MA_API ma_result ma_vfs_or_default_write(ma_vfs* pVFS, ma_vfs_file file, const void* pSrc, size_t sizeInBytes, size_t* pBytesWritten) -{ - if (pVFS != NULL) { - return ma_vfs_write(pVFS, file, pSrc, sizeInBytes, pBytesWritten); - } else { - return ma_default_vfs_write(pVFS, file, pSrc, sizeInBytes, pBytesWritten); - } -} - -MA_API ma_result ma_vfs_or_default_seek(ma_vfs* pVFS, ma_vfs_file file, ma_int64 offset, ma_seek_origin origin) -{ - if (pVFS != NULL) { - return ma_vfs_seek(pVFS, file, offset, origin); - } else { - return ma_default_vfs_seek(pVFS, file, offset, origin); - } -} - -MA_API ma_result ma_vfs_or_default_tell(ma_vfs* pVFS, ma_vfs_file file, ma_int64* pCursor) -{ - if (pVFS != NULL) { - return ma_vfs_tell(pVFS, file, pCursor); - } else { - return ma_default_vfs_tell(pVFS, file, pCursor); - } -} - -MA_API ma_result ma_vfs_or_default_info(ma_vfs* pVFS, ma_vfs_file file, ma_file_info* pInfo) -{ - if (pVFS != NULL) { - return ma_vfs_info(pVFS, file, pInfo); - } else { - return ma_default_vfs_info(pVFS, file, pInfo); - } -} - - - -/************************************************************************************************************************************************************** - -Decoding and Encoding Headers. These are auto-generated from a tool. - -**************************************************************************************************************************************************************/ -#if !defined(MA_NO_WAV) && (!defined(MA_NO_DECODING) || !defined(MA_NO_ENCODING)) -/* dr_wav_h begin */ -#ifndef dr_wav_h -#define dr_wav_h -#ifdef __cplusplus -extern "C" { -#endif -#define DRWAV_STRINGIFY(x) #x -#define DRWAV_XSTRINGIFY(x) DRWAV_STRINGIFY(x) -#define DRWAV_VERSION_MAJOR 0 -#define DRWAV_VERSION_MINOR 13 -#define DRWAV_VERSION_REVISION 8 -#define DRWAV_VERSION_STRING DRWAV_XSTRINGIFY(DRWAV_VERSION_MAJOR) "." DRWAV_XSTRINGIFY(DRWAV_VERSION_MINOR) "." DRWAV_XSTRINGIFY(DRWAV_VERSION_REVISION) -#include -typedef signed char drwav_int8; -typedef unsigned char drwav_uint8; -typedef signed short drwav_int16; -typedef unsigned short drwav_uint16; -typedef signed int drwav_int32; -typedef unsigned int drwav_uint32; -#if defined(_MSC_VER) && !defined(__clang__) - typedef signed __int64 drwav_int64; - typedef unsigned __int64 drwav_uint64; -#else - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wlong-long" - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc++11-long-long" - #endif - #endif - typedef signed long long drwav_int64; - typedef unsigned long long drwav_uint64; - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop - #endif -#endif -#if defined(__LP64__) || defined(_WIN64) || (defined(__x86_64__) && !defined(__ILP32__)) || defined(_M_X64) || defined(__ia64) || defined (_M_IA64) || defined(__aarch64__) || defined(_M_ARM64) || defined(__powerpc64__) - typedef drwav_uint64 drwav_uintptr; -#else - typedef drwav_uint32 drwav_uintptr; -#endif -typedef drwav_uint8 drwav_bool8; -typedef drwav_uint32 drwav_bool32; -#define DRWAV_TRUE 1 -#define DRWAV_FALSE 0 -#if !defined(DRWAV_API) - #if defined(DRWAV_DLL) - #if defined(_WIN32) - #define DRWAV_DLL_IMPORT __declspec(dllimport) - #define DRWAV_DLL_EXPORT __declspec(dllexport) - #define DRWAV_DLL_PRIVATE static - #else - #if defined(__GNUC__) && __GNUC__ >= 4 - #define DRWAV_DLL_IMPORT __attribute__((visibility("default"))) - #define DRWAV_DLL_EXPORT __attribute__((visibility("default"))) - #define DRWAV_DLL_PRIVATE __attribute__((visibility("hidden"))) - #else - #define DRWAV_DLL_IMPORT - #define DRWAV_DLL_EXPORT - #define DRWAV_DLL_PRIVATE static - #endif - #endif - #if defined(DR_WAV_IMPLEMENTATION) || defined(DRWAV_IMPLEMENTATION) - #define DRWAV_API DRWAV_DLL_EXPORT - #else - #define DRWAV_API DRWAV_DLL_IMPORT - #endif - #define DRWAV_PRIVATE DRWAV_DLL_PRIVATE - #else - #define DRWAV_API extern - #define DRWAV_PRIVATE static - #endif -#endif -typedef drwav_int32 drwav_result; -#define DRWAV_SUCCESS 0 -#define DRWAV_ERROR -1 -#define DRWAV_INVALID_ARGS -2 -#define DRWAV_INVALID_OPERATION -3 -#define DRWAV_OUT_OF_MEMORY -4 -#define DRWAV_OUT_OF_RANGE -5 -#define DRWAV_ACCESS_DENIED -6 -#define DRWAV_DOES_NOT_EXIST -7 -#define DRWAV_ALREADY_EXISTS -8 -#define DRWAV_TOO_MANY_OPEN_FILES -9 -#define DRWAV_INVALID_FILE -10 -#define DRWAV_TOO_BIG -11 -#define DRWAV_PATH_TOO_LONG -12 -#define DRWAV_NAME_TOO_LONG -13 -#define DRWAV_NOT_DIRECTORY -14 -#define DRWAV_IS_DIRECTORY -15 -#define DRWAV_DIRECTORY_NOT_EMPTY -16 -#define DRWAV_END_OF_FILE -17 -#define DRWAV_NO_SPACE -18 -#define DRWAV_BUSY -19 -#define DRWAV_IO_ERROR -20 -#define DRWAV_INTERRUPT -21 -#define DRWAV_UNAVAILABLE -22 -#define DRWAV_ALREADY_IN_USE -23 -#define DRWAV_BAD_ADDRESS -24 -#define DRWAV_BAD_SEEK -25 -#define DRWAV_BAD_PIPE -26 -#define DRWAV_DEADLOCK -27 -#define DRWAV_TOO_MANY_LINKS -28 -#define DRWAV_NOT_IMPLEMENTED -29 -#define DRWAV_NO_MESSAGE -30 -#define DRWAV_BAD_MESSAGE -31 -#define DRWAV_NO_DATA_AVAILABLE -32 -#define DRWAV_INVALID_DATA -33 -#define DRWAV_TIMEOUT -34 -#define DRWAV_NO_NETWORK -35 -#define DRWAV_NOT_UNIQUE -36 -#define DRWAV_NOT_SOCKET -37 -#define DRWAV_NO_ADDRESS -38 -#define DRWAV_BAD_PROTOCOL -39 -#define DRWAV_PROTOCOL_UNAVAILABLE -40 -#define DRWAV_PROTOCOL_NOT_SUPPORTED -41 -#define DRWAV_PROTOCOL_FAMILY_NOT_SUPPORTED -42 -#define DRWAV_ADDRESS_FAMILY_NOT_SUPPORTED -43 -#define DRWAV_SOCKET_NOT_SUPPORTED -44 -#define DRWAV_CONNECTION_RESET -45 -#define DRWAV_ALREADY_CONNECTED -46 -#define DRWAV_NOT_CONNECTED -47 -#define DRWAV_CONNECTION_REFUSED -48 -#define DRWAV_NO_HOST -49 -#define DRWAV_IN_PROGRESS -50 -#define DRWAV_CANCELLED -51 -#define DRWAV_MEMORY_ALREADY_MAPPED -52 -#define DRWAV_AT_END -53 -#define DR_WAVE_FORMAT_PCM 0x1 -#define DR_WAVE_FORMAT_ADPCM 0x2 -#define DR_WAVE_FORMAT_IEEE_FLOAT 0x3 -#define DR_WAVE_FORMAT_ALAW 0x6 -#define DR_WAVE_FORMAT_MULAW 0x7 -#define DR_WAVE_FORMAT_DVI_ADPCM 0x11 -#define DR_WAVE_FORMAT_EXTENSIBLE 0xFFFE -#define DRWAV_SEQUENTIAL 0x00000001 -DRWAV_API void drwav_version(drwav_uint32* pMajor, drwav_uint32* pMinor, drwav_uint32* pRevision); -DRWAV_API const char* drwav_version_string(void); -typedef enum -{ - drwav_seek_origin_start, - drwav_seek_origin_current -} drwav_seek_origin; -typedef enum -{ - drwav_container_riff, - drwav_container_w64, - drwav_container_rf64 -} drwav_container; -typedef struct -{ - union - { - drwav_uint8 fourcc[4]; - drwav_uint8 guid[16]; - } id; - drwav_uint64 sizeInBytes; - unsigned int paddingSize; -} drwav_chunk_header; -typedef struct -{ - drwav_uint16 formatTag; - drwav_uint16 channels; - drwav_uint32 sampleRate; - drwav_uint32 avgBytesPerSec; - drwav_uint16 blockAlign; - drwav_uint16 bitsPerSample; - drwav_uint16 extendedSize; - drwav_uint16 validBitsPerSample; - drwav_uint32 channelMask; - drwav_uint8 subFormat[16]; -} drwav_fmt; -DRWAV_API drwav_uint16 drwav_fmt_get_format(const drwav_fmt* pFMT); -typedef size_t (* drwav_read_proc)(void* pUserData, void* pBufferOut, size_t bytesToRead); -typedef size_t (* drwav_write_proc)(void* pUserData, const void* pData, size_t bytesToWrite); -typedef drwav_bool32 (* drwav_seek_proc)(void* pUserData, int offset, drwav_seek_origin origin); -typedef drwav_uint64 (* drwav_chunk_proc)(void* pChunkUserData, drwav_read_proc onRead, drwav_seek_proc onSeek, void* pReadSeekUserData, const drwav_chunk_header* pChunkHeader, drwav_container container, const drwav_fmt* pFMT); -typedef struct -{ - void* pUserData; - void* (* onMalloc)(size_t sz, void* pUserData); - void* (* onRealloc)(void* p, size_t sz, void* pUserData); - void (* onFree)(void* p, void* pUserData); -} drwav_allocation_callbacks; -typedef struct -{ - const drwav_uint8* data; - size_t dataSize; - size_t currentReadPos; -} drwav__memory_stream; -typedef struct -{ - void** ppData; - size_t* pDataSize; - size_t dataSize; - size_t dataCapacity; - size_t currentWritePos; -} drwav__memory_stream_write; -typedef struct -{ - drwav_container container; - drwav_uint32 format; - drwav_uint32 channels; - drwav_uint32 sampleRate; - drwav_uint32 bitsPerSample; -} drwav_data_format; -typedef enum -{ - drwav_metadata_type_none = 0, - drwav_metadata_type_unknown = 1 << 0, - drwav_metadata_type_smpl = 1 << 1, - drwav_metadata_type_inst = 1 << 2, - drwav_metadata_type_cue = 1 << 3, - drwav_metadata_type_acid = 1 << 4, - drwav_metadata_type_bext = 1 << 5, - drwav_metadata_type_list_label = 1 << 6, - drwav_metadata_type_list_note = 1 << 7, - drwav_metadata_type_list_labelled_cue_region = 1 << 8, - drwav_metadata_type_list_info_software = 1 << 9, - drwav_metadata_type_list_info_copyright = 1 << 10, - drwav_metadata_type_list_info_title = 1 << 11, - drwav_metadata_type_list_info_artist = 1 << 12, - drwav_metadata_type_list_info_comment = 1 << 13, - drwav_metadata_type_list_info_date = 1 << 14, - drwav_metadata_type_list_info_genre = 1 << 15, - drwav_metadata_type_list_info_album = 1 << 16, - drwav_metadata_type_list_info_tracknumber = 1 << 17, - drwav_metadata_type_list_all_info_strings = drwav_metadata_type_list_info_software - | drwav_metadata_type_list_info_copyright - | drwav_metadata_type_list_info_title - | drwav_metadata_type_list_info_artist - | drwav_metadata_type_list_info_comment - | drwav_metadata_type_list_info_date - | drwav_metadata_type_list_info_genre - | drwav_metadata_type_list_info_album - | drwav_metadata_type_list_info_tracknumber, - drwav_metadata_type_list_all_adtl = drwav_metadata_type_list_label - | drwav_metadata_type_list_note - | drwav_metadata_type_list_labelled_cue_region, - drwav_metadata_type_all = -2, - drwav_metadata_type_all_including_unknown = -1 -} drwav_metadata_type; -typedef enum -{ - drwav_smpl_loop_type_forward = 0, - drwav_smpl_loop_type_pingpong = 1, - drwav_smpl_loop_type_backward = 2 -} drwav_smpl_loop_type; -typedef struct -{ - drwav_uint32 cuePointId; - drwav_uint32 type; - drwav_uint32 firstSampleByteOffset; - drwav_uint32 lastSampleByteOffset; - drwav_uint32 sampleFraction; - drwav_uint32 playCount; -} drwav_smpl_loop; -typedef struct -{ - drwav_uint32 manufacturerId; - drwav_uint32 productId; - drwav_uint32 samplePeriodNanoseconds; - drwav_uint32 midiUnityNote; - drwav_uint32 midiPitchFraction; - drwav_uint32 smpteFormat; - drwav_uint32 smpteOffset; - drwav_uint32 sampleLoopCount; - drwav_uint32 samplerSpecificDataSizeInBytes; - drwav_smpl_loop* pLoops; - drwav_uint8* pSamplerSpecificData; -} drwav_smpl; -typedef struct -{ - drwav_int8 midiUnityNote; - drwav_int8 fineTuneCents; - drwav_int8 gainDecibels; - drwav_int8 lowNote; - drwav_int8 highNote; - drwav_int8 lowVelocity; - drwav_int8 highVelocity; -} drwav_inst; -typedef struct -{ - drwav_uint32 id; - drwav_uint32 playOrderPosition; - drwav_uint8 dataChunkId[4]; - drwav_uint32 chunkStart; - drwav_uint32 blockStart; - drwav_uint32 sampleByteOffset; -} drwav_cue_point; -typedef struct -{ - drwav_uint32 cuePointCount; - drwav_cue_point *pCuePoints; -} drwav_cue; -typedef enum -{ - drwav_acid_flag_one_shot = 1, - drwav_acid_flag_root_note_set = 2, - drwav_acid_flag_stretch = 4, - drwav_acid_flag_disk_based = 8, - drwav_acid_flag_acidizer = 16 -} drwav_acid_flag; -typedef struct -{ - drwav_uint32 flags; - drwav_uint16 midiUnityNote; - drwav_uint16 reserved1; - float reserved2; - drwav_uint32 numBeats; - drwav_uint16 meterDenominator; - drwav_uint16 meterNumerator; - float tempo; -} drwav_acid; -typedef struct -{ - drwav_uint32 cuePointId; - drwav_uint32 stringLength; - char* pString; -} drwav_list_label_or_note; -typedef struct -{ - char* pDescription; - char* pOriginatorName; - char* pOriginatorReference; - char pOriginationDate[10]; - char pOriginationTime[8]; - drwav_uint64 timeReference; - drwav_uint16 version; - char* pCodingHistory; - drwav_uint32 codingHistorySize; - drwav_uint8* pUMID; - drwav_uint16 loudnessValue; - drwav_uint16 loudnessRange; - drwav_uint16 maxTruePeakLevel; - drwav_uint16 maxMomentaryLoudness; - drwav_uint16 maxShortTermLoudness; -} drwav_bext; -typedef struct -{ - drwav_uint32 stringLength; - char* pString; -} drwav_list_info_text; -typedef struct -{ - drwav_uint32 cuePointId; - drwav_uint32 sampleLength; - drwav_uint8 purposeId[4]; - drwav_uint16 country; - drwav_uint16 language; - drwav_uint16 dialect; - drwav_uint16 codePage; - drwav_uint32 stringLength; - char* pString; -} drwav_list_labelled_cue_region; -typedef enum -{ - drwav_metadata_location_invalid, - drwav_metadata_location_top_level, - drwav_metadata_location_inside_info_list, - drwav_metadata_location_inside_adtl_list -} drwav_metadata_location; -typedef struct -{ - drwav_uint8 id[4]; - drwav_metadata_location chunkLocation; - drwav_uint32 dataSizeInBytes; - drwav_uint8* pData; -} drwav_unknown_metadata; -typedef struct -{ - drwav_metadata_type type; - union - { - drwav_cue cue; - drwav_smpl smpl; - drwav_acid acid; - drwav_inst inst; - drwav_bext bext; - drwav_list_label_or_note labelOrNote; - drwav_list_labelled_cue_region labelledCueRegion; - drwav_list_info_text infoText; - drwav_unknown_metadata unknown; - } data; -} drwav_metadata; -typedef struct -{ - drwav_read_proc onRead; - drwav_write_proc onWrite; - drwav_seek_proc onSeek; - void* pUserData; - drwav_allocation_callbacks allocationCallbacks; - drwav_container container; - drwav_fmt fmt; - drwav_uint32 sampleRate; - drwav_uint16 channels; - drwav_uint16 bitsPerSample; - drwav_uint16 translatedFormatTag; - drwav_uint64 totalPCMFrameCount; - drwav_uint64 dataChunkDataSize; - drwav_uint64 dataChunkDataPos; - drwav_uint64 bytesRemaining; - drwav_uint64 readCursorInPCMFrames; - drwav_uint64 dataChunkDataSizeTargetWrite; - drwav_bool32 isSequentialWrite; - drwav_metadata_type allowedMetadataTypes; - drwav_metadata* pMetadata; - drwav_uint32 metadataCount; - drwav__memory_stream memoryStream; - drwav__memory_stream_write memoryStreamWrite; - struct - { - drwav_uint32 bytesRemainingInBlock; - drwav_uint16 predictor[2]; - drwav_int32 delta[2]; - drwav_int32 cachedFrames[4]; - drwav_uint32 cachedFrameCount; - drwav_int32 prevFrames[2][2]; - } msadpcm; - struct - { - drwav_uint32 bytesRemainingInBlock; - drwav_int32 predictor[2]; - drwav_int32 stepIndex[2]; - drwav_int32 cachedFrames[16]; - drwav_uint32 cachedFrameCount; - } ima; -} drwav; -DRWAV_API drwav_bool32 drwav_init(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_ex(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, drwav_chunk_proc onChunk, void* pReadSeekUserData, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_with_metadata(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_write(drwav* pWav, const drwav_data_format* pFormat, drwav_write_proc onWrite, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_write_sequential(drwav* pWav, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, drwav_write_proc onWrite, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_write_sequential_pcm_frames(drwav* pWav, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, drwav_write_proc onWrite, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_write_with_metadata(drwav* pWav, const drwav_data_format* pFormat, drwav_write_proc onWrite, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks, drwav_metadata* pMetadata, drwav_uint32 metadataCount); -DRWAV_API drwav_uint64 drwav_target_write_size_bytes(const drwav_data_format* pFormat, drwav_uint64 totalFrameCount, drwav_metadata* pMetadata, drwav_uint32 metadataCount); -DRWAV_API drwav_metadata* drwav_take_ownership_of_metadata(drwav* pWav); -DRWAV_API drwav_result drwav_uninit(drwav* pWav); -DRWAV_API size_t drwav_read_raw(drwav* pWav, size_t bytesToRead, void* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames(drwav* pWav, drwav_uint64 framesToRead, void* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_le(drwav* pWav, drwav_uint64 framesToRead, void* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_be(drwav* pWav, drwav_uint64 framesToRead, void* pBufferOut); -DRWAV_API drwav_bool32 drwav_seek_to_pcm_frame(drwav* pWav, drwav_uint64 targetFrameIndex); -DRWAV_API drwav_result drwav_get_cursor_in_pcm_frames(drwav* pWav, drwav_uint64* pCursor); -DRWAV_API drwav_result drwav_get_length_in_pcm_frames(drwav* pWav, drwav_uint64* pLength); -DRWAV_API size_t drwav_write_raw(drwav* pWav, size_t bytesToWrite, const void* pData); -DRWAV_API drwav_uint64 drwav_write_pcm_frames(drwav* pWav, drwav_uint64 framesToWrite, const void* pData); -DRWAV_API drwav_uint64 drwav_write_pcm_frames_le(drwav* pWav, drwav_uint64 framesToWrite, const void* pData); -DRWAV_API drwav_uint64 drwav_write_pcm_frames_be(drwav* pWav, drwav_uint64 framesToWrite, const void* pData); -#ifndef DR_WAV_NO_CONVERSION_API -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s16(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s16le(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s16be(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut); -DRWAV_API void drwav_u8_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_s24_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_s32_to_s16(drwav_int16* pOut, const drwav_int32* pIn, size_t sampleCount); -DRWAV_API void drwav_f32_to_s16(drwav_int16* pOut, const float* pIn, size_t sampleCount); -DRWAV_API void drwav_f64_to_s16(drwav_int16* pOut, const double* pIn, size_t sampleCount); -DRWAV_API void drwav_alaw_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_mulaw_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_f32(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_f32le(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_f32be(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut); -DRWAV_API void drwav_u8_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_s16_to_f32(float* pOut, const drwav_int16* pIn, size_t sampleCount); -DRWAV_API void drwav_s24_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_s32_to_f32(float* pOut, const drwav_int32* pIn, size_t sampleCount); -DRWAV_API void drwav_f64_to_f32(float* pOut, const double* pIn, size_t sampleCount); -DRWAV_API void drwav_alaw_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_mulaw_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s32(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s32le(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut); -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s32be(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut); -DRWAV_API void drwav_u8_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_s16_to_s32(drwav_int32* pOut, const drwav_int16* pIn, size_t sampleCount); -DRWAV_API void drwav_s24_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_f32_to_s32(drwav_int32* pOut, const float* pIn, size_t sampleCount); -DRWAV_API void drwav_f64_to_s32(drwav_int32* pOut, const double* pIn, size_t sampleCount); -DRWAV_API void drwav_alaw_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount); -DRWAV_API void drwav_mulaw_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount); -#endif -#ifndef DR_WAV_NO_STDIO -DRWAV_API drwav_bool32 drwav_init_file(drwav* pWav, const char* filename, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_ex(drwav* pWav, const char* filename, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_w(drwav* pWav, const wchar_t* filename, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_ex_w(drwav* pWav, const wchar_t* filename, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_with_metadata(drwav* pWav, const char* filename, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_with_metadata_w(drwav* pWav, const wchar_t* filename, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_write(drwav* pWav, const char* filename, const drwav_data_format* pFormat, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_write_sequential(drwav* pWav, const char* filename, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_write_sequential_pcm_frames(drwav* pWav, const char* filename, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_write_w(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_write_sequential_w(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_file_write_sequential_pcm_frames_w(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, const drwav_allocation_callbacks* pAllocationCallbacks); -#endif -DRWAV_API drwav_bool32 drwav_init_memory(drwav* pWav, const void* data, size_t dataSize, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_memory_ex(drwav* pWav, const void* data, size_t dataSize, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_memory_with_metadata(drwav* pWav, const void* data, size_t dataSize, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_memory_write(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_memory_write_sequential(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_bool32 drwav_init_memory_write_sequential_pcm_frames(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, const drwav_allocation_callbacks* pAllocationCallbacks); -#ifndef DR_WAV_NO_CONVERSION_API -DRWAV_API drwav_int16* drwav_open_and_read_pcm_frames_s16(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API float* drwav_open_and_read_pcm_frames_f32(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_int32* drwav_open_and_read_pcm_frames_s32(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -#ifndef DR_WAV_NO_STDIO -DRWAV_API drwav_int16* drwav_open_file_and_read_pcm_frames_s16(const char* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API float* drwav_open_file_and_read_pcm_frames_f32(const char* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_int32* drwav_open_file_and_read_pcm_frames_s32(const char* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_int16* drwav_open_file_and_read_pcm_frames_s16_w(const wchar_t* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API float* drwav_open_file_and_read_pcm_frames_f32_w(const wchar_t* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_int32* drwav_open_file_and_read_pcm_frames_s32_w(const wchar_t* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -#endif -DRWAV_API drwav_int16* drwav_open_memory_and_read_pcm_frames_s16(const void* data, size_t dataSize, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API float* drwav_open_memory_and_read_pcm_frames_f32(const void* data, size_t dataSize, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_int32* drwav_open_memory_and_read_pcm_frames_s32(const void* data, size_t dataSize, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks); -#endif -DRWAV_API void drwav_free(void* p, const drwav_allocation_callbacks* pAllocationCallbacks); -DRWAV_API drwav_uint16 drwav_bytes_to_u16(const drwav_uint8* data); -DRWAV_API drwav_int16 drwav_bytes_to_s16(const drwav_uint8* data); -DRWAV_API drwav_uint32 drwav_bytes_to_u32(const drwav_uint8* data); -DRWAV_API drwav_int32 drwav_bytes_to_s32(const drwav_uint8* data); -DRWAV_API drwav_uint64 drwav_bytes_to_u64(const drwav_uint8* data); -DRWAV_API drwav_int64 drwav_bytes_to_s64(const drwav_uint8* data); -DRWAV_API float drwav_bytes_to_f32(const drwav_uint8* data); -DRWAV_API drwav_bool32 drwav_guid_equal(const drwav_uint8 a[16], const drwav_uint8 b[16]); -DRWAV_API drwav_bool32 drwav_fourcc_equal(const drwav_uint8* a, const char* b); -#ifdef __cplusplus -} -#endif -#endif -/* dr_wav_h end */ -#endif /* MA_NO_WAV */ - -#if !defined(MA_NO_FLAC) && !defined(MA_NO_DECODING) -/* dr_flac_h begin */ -#ifndef dr_flac_h -#define dr_flac_h -#ifdef __cplusplus -extern "C" { -#endif -#define DRFLAC_STRINGIFY(x) #x -#define DRFLAC_XSTRINGIFY(x) DRFLAC_STRINGIFY(x) -#define DRFLAC_VERSION_MAJOR 0 -#define DRFLAC_VERSION_MINOR 12 -#define DRFLAC_VERSION_REVISION 39 -#define DRFLAC_VERSION_STRING DRFLAC_XSTRINGIFY(DRFLAC_VERSION_MAJOR) "." DRFLAC_XSTRINGIFY(DRFLAC_VERSION_MINOR) "." DRFLAC_XSTRINGIFY(DRFLAC_VERSION_REVISION) -#include -typedef signed char drflac_int8; -typedef unsigned char drflac_uint8; -typedef signed short drflac_int16; -typedef unsigned short drflac_uint16; -typedef signed int drflac_int32; -typedef unsigned int drflac_uint32; -#if defined(_MSC_VER) && !defined(__clang__) - typedef signed __int64 drflac_int64; - typedef unsigned __int64 drflac_uint64; -#else - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wlong-long" - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc++11-long-long" - #endif - #endif - typedef signed long long drflac_int64; - typedef unsigned long long drflac_uint64; - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop - #endif -#endif -#if defined(__LP64__) || defined(_WIN64) || (defined(__x86_64__) && !defined(__ILP32__)) || defined(_M_X64) || defined(__ia64) || defined(_M_IA64) || defined(__aarch64__) || defined(_M_ARM64) || defined(__powerpc64__) - typedef drflac_uint64 drflac_uintptr; -#else - typedef drflac_uint32 drflac_uintptr; -#endif -typedef drflac_uint8 drflac_bool8; -typedef drflac_uint32 drflac_bool32; -#define DRFLAC_TRUE 1 -#define DRFLAC_FALSE 0 -#if !defined(DRFLAC_API) - #if defined(DRFLAC_DLL) - #if defined(_WIN32) - #define DRFLAC_DLL_IMPORT __declspec(dllimport) - #define DRFLAC_DLL_EXPORT __declspec(dllexport) - #define DRFLAC_DLL_PRIVATE static - #else - #if defined(__GNUC__) && __GNUC__ >= 4 - #define DRFLAC_DLL_IMPORT __attribute__((visibility("default"))) - #define DRFLAC_DLL_EXPORT __attribute__((visibility("default"))) - #define DRFLAC_DLL_PRIVATE __attribute__((visibility("hidden"))) - #else - #define DRFLAC_DLL_IMPORT - #define DRFLAC_DLL_EXPORT - #define DRFLAC_DLL_PRIVATE static - #endif - #endif - #if defined(DR_FLAC_IMPLEMENTATION) || defined(DRFLAC_IMPLEMENTATION) - #define DRFLAC_API DRFLAC_DLL_EXPORT - #else - #define DRFLAC_API DRFLAC_DLL_IMPORT - #endif - #define DRFLAC_PRIVATE DRFLAC_DLL_PRIVATE - #else - #define DRFLAC_API extern - #define DRFLAC_PRIVATE static - #endif -#endif -#if defined(_MSC_VER) && _MSC_VER >= 1700 - #define DRFLAC_DEPRECATED __declspec(deprecated) -#elif (defined(__GNUC__) && __GNUC__ >= 4) - #define DRFLAC_DEPRECATED __attribute__((deprecated)) -#elif defined(__has_feature) - #if __has_feature(attribute_deprecated) - #define DRFLAC_DEPRECATED __attribute__((deprecated)) - #else - #define DRFLAC_DEPRECATED - #endif -#else - #define DRFLAC_DEPRECATED -#endif -DRFLAC_API void drflac_version(drflac_uint32* pMajor, drflac_uint32* pMinor, drflac_uint32* pRevision); -DRFLAC_API const char* drflac_version_string(void); -#ifndef DR_FLAC_BUFFER_SIZE -#define DR_FLAC_BUFFER_SIZE 4096 -#endif -#if defined(_WIN64) || defined(_LP64) || defined(__LP64__) -#define DRFLAC_64BIT -#endif -#ifdef DRFLAC_64BIT -typedef drflac_uint64 drflac_cache_t; -#else -typedef drflac_uint32 drflac_cache_t; -#endif -#define DRFLAC_METADATA_BLOCK_TYPE_STREAMINFO 0 -#define DRFLAC_METADATA_BLOCK_TYPE_PADDING 1 -#define DRFLAC_METADATA_BLOCK_TYPE_APPLICATION 2 -#define DRFLAC_METADATA_BLOCK_TYPE_SEEKTABLE 3 -#define DRFLAC_METADATA_BLOCK_TYPE_VORBIS_COMMENT 4 -#define DRFLAC_METADATA_BLOCK_TYPE_CUESHEET 5 -#define DRFLAC_METADATA_BLOCK_TYPE_PICTURE 6 -#define DRFLAC_METADATA_BLOCK_TYPE_INVALID 127 -#define DRFLAC_PICTURE_TYPE_OTHER 0 -#define DRFLAC_PICTURE_TYPE_FILE_ICON 1 -#define DRFLAC_PICTURE_TYPE_OTHER_FILE_ICON 2 -#define DRFLAC_PICTURE_TYPE_COVER_FRONT 3 -#define DRFLAC_PICTURE_TYPE_COVER_BACK 4 -#define DRFLAC_PICTURE_TYPE_LEAFLET_PAGE 5 -#define DRFLAC_PICTURE_TYPE_MEDIA 6 -#define DRFLAC_PICTURE_TYPE_LEAD_ARTIST 7 -#define DRFLAC_PICTURE_TYPE_ARTIST 8 -#define DRFLAC_PICTURE_TYPE_CONDUCTOR 9 -#define DRFLAC_PICTURE_TYPE_BAND 10 -#define DRFLAC_PICTURE_TYPE_COMPOSER 11 -#define DRFLAC_PICTURE_TYPE_LYRICIST 12 -#define DRFLAC_PICTURE_TYPE_RECORDING_LOCATION 13 -#define DRFLAC_PICTURE_TYPE_DURING_RECORDING 14 -#define DRFLAC_PICTURE_TYPE_DURING_PERFORMANCE 15 -#define DRFLAC_PICTURE_TYPE_SCREEN_CAPTURE 16 -#define DRFLAC_PICTURE_TYPE_BRIGHT_COLORED_FISH 17 -#define DRFLAC_PICTURE_TYPE_ILLUSTRATION 18 -#define DRFLAC_PICTURE_TYPE_BAND_LOGOTYPE 19 -#define DRFLAC_PICTURE_TYPE_PUBLISHER_LOGOTYPE 20 -typedef enum -{ - drflac_container_native, - drflac_container_ogg, - drflac_container_unknown -} drflac_container; -typedef enum -{ - drflac_seek_origin_start, - drflac_seek_origin_current -} drflac_seek_origin; -typedef struct -{ - drflac_uint64 firstPCMFrame; - drflac_uint64 flacFrameOffset; - drflac_uint16 pcmFrameCount; -} drflac_seekpoint; -typedef struct -{ - drflac_uint16 minBlockSizeInPCMFrames; - drflac_uint16 maxBlockSizeInPCMFrames; - drflac_uint32 minFrameSizeInPCMFrames; - drflac_uint32 maxFrameSizeInPCMFrames; - drflac_uint32 sampleRate; - drflac_uint8 channels; - drflac_uint8 bitsPerSample; - drflac_uint64 totalPCMFrameCount; - drflac_uint8 md5[16]; -} drflac_streaminfo; -typedef struct -{ - drflac_uint32 type; - const void* pRawData; - drflac_uint32 rawDataSize; - union - { - drflac_streaminfo streaminfo; - struct - { - int unused; - } padding; - struct - { - drflac_uint32 id; - const void* pData; - drflac_uint32 dataSize; - } application; - struct - { - drflac_uint32 seekpointCount; - const drflac_seekpoint* pSeekpoints; - } seektable; - struct - { - drflac_uint32 vendorLength; - const char* vendor; - drflac_uint32 commentCount; - const void* pComments; - } vorbis_comment; - struct - { - char catalog[128]; - drflac_uint64 leadInSampleCount; - drflac_bool32 isCD; - drflac_uint8 trackCount; - const void* pTrackData; - } cuesheet; - struct - { - drflac_uint32 type; - drflac_uint32 mimeLength; - const char* mime; - drflac_uint32 descriptionLength; - const char* description; - drflac_uint32 width; - drflac_uint32 height; - drflac_uint32 colorDepth; - drflac_uint32 indexColorCount; - drflac_uint32 pictureDataSize; - const drflac_uint8* pPictureData; - } picture; - } data; -} drflac_metadata; -typedef size_t (* drflac_read_proc)(void* pUserData, void* pBufferOut, size_t bytesToRead); -typedef drflac_bool32 (* drflac_seek_proc)(void* pUserData, int offset, drflac_seek_origin origin); -typedef void (* drflac_meta_proc)(void* pUserData, drflac_metadata* pMetadata); -typedef struct -{ - void* pUserData; - void* (* onMalloc)(size_t sz, void* pUserData); - void* (* onRealloc)(void* p, size_t sz, void* pUserData); - void (* onFree)(void* p, void* pUserData); -} drflac_allocation_callbacks; -typedef struct -{ - const drflac_uint8* data; - size_t dataSize; - size_t currentReadPos; -} drflac__memory_stream; -typedef struct -{ - drflac_read_proc onRead; - drflac_seek_proc onSeek; - void* pUserData; - size_t unalignedByteCount; - drflac_cache_t unalignedCache; - drflac_uint32 nextL2Line; - drflac_uint32 consumedBits; - drflac_cache_t cacheL2[DR_FLAC_BUFFER_SIZE/sizeof(drflac_cache_t)]; - drflac_cache_t cache; - drflac_uint16 crc16; - drflac_cache_t crc16Cache; - drflac_uint32 crc16CacheIgnoredBytes; -} drflac_bs; -typedef struct -{ - drflac_uint8 subframeType; - drflac_uint8 wastedBitsPerSample; - drflac_uint8 lpcOrder; - drflac_int32* pSamplesS32; -} drflac_subframe; -typedef struct -{ - drflac_uint64 pcmFrameNumber; - drflac_uint32 flacFrameNumber; - drflac_uint32 sampleRate; - drflac_uint16 blockSizeInPCMFrames; - drflac_uint8 channelAssignment; - drflac_uint8 bitsPerSample; - drflac_uint8 crc8; -} drflac_frame_header; -typedef struct -{ - drflac_frame_header header; - drflac_uint32 pcmFramesRemaining; - drflac_subframe subframes[8]; -} drflac_frame; -typedef struct -{ - drflac_meta_proc onMeta; - void* pUserDataMD; - drflac_allocation_callbacks allocationCallbacks; - drflac_uint32 sampleRate; - drflac_uint8 channels; - drflac_uint8 bitsPerSample; - drflac_uint16 maxBlockSizeInPCMFrames; - drflac_uint64 totalPCMFrameCount; - drflac_container container; - drflac_uint32 seekpointCount; - drflac_frame currentFLACFrame; - drflac_uint64 currentPCMFrame; - drflac_uint64 firstFLACFramePosInBytes; - drflac__memory_stream memoryStream; - drflac_int32* pDecodedSamples; - drflac_seekpoint* pSeekpoints; - void* _oggbs; - drflac_bool32 _noSeekTableSeek : 1; - drflac_bool32 _noBinarySearchSeek : 1; - drflac_bool32 _noBruteForceSeek : 1; - drflac_bs bs; - drflac_uint8 pExtraData[1]; -} drflac; -DRFLAC_API drflac* drflac_open(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_relaxed(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_container container, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_with_metadata(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_with_metadata_relaxed(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, drflac_container container, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API void drflac_close(drflac* pFlac); -DRFLAC_API drflac_uint64 drflac_read_pcm_frames_s32(drflac* pFlac, drflac_uint64 framesToRead, drflac_int32* pBufferOut); -DRFLAC_API drflac_uint64 drflac_read_pcm_frames_s16(drflac* pFlac, drflac_uint64 framesToRead, drflac_int16* pBufferOut); -DRFLAC_API drflac_uint64 drflac_read_pcm_frames_f32(drflac* pFlac, drflac_uint64 framesToRead, float* pBufferOut); -DRFLAC_API drflac_bool32 drflac_seek_to_pcm_frame(drflac* pFlac, drflac_uint64 pcmFrameIndex); -#ifndef DR_FLAC_NO_STDIO -DRFLAC_API drflac* drflac_open_file(const char* pFileName, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_file_w(const wchar_t* pFileName, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_file_with_metadata(const char* pFileName, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_file_with_metadata_w(const wchar_t* pFileName, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -#endif -DRFLAC_API drflac* drflac_open_memory(const void* pData, size_t dataSize, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac* drflac_open_memory_with_metadata(const void* pData, size_t dataSize, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac_int32* drflac_open_and_read_pcm_frames_s32(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac_int16* drflac_open_and_read_pcm_frames_s16(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API float* drflac_open_and_read_pcm_frames_f32(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -#ifndef DR_FLAC_NO_STDIO -DRFLAC_API drflac_int32* drflac_open_file_and_read_pcm_frames_s32(const char* filename, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac_int16* drflac_open_file_and_read_pcm_frames_s16(const char* filename, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API float* drflac_open_file_and_read_pcm_frames_f32(const char* filename, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -#endif -DRFLAC_API drflac_int32* drflac_open_memory_and_read_pcm_frames_s32(const void* data, size_t dataSize, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API drflac_int16* drflac_open_memory_and_read_pcm_frames_s16(const void* data, size_t dataSize, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API float* drflac_open_memory_and_read_pcm_frames_f32(const void* data, size_t dataSize, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks); -DRFLAC_API void drflac_free(void* p, const drflac_allocation_callbacks* pAllocationCallbacks); -typedef struct -{ - drflac_uint32 countRemaining; - const char* pRunningData; -} drflac_vorbis_comment_iterator; -DRFLAC_API void drflac_init_vorbis_comment_iterator(drflac_vorbis_comment_iterator* pIter, drflac_uint32 commentCount, const void* pComments); -DRFLAC_API const char* drflac_next_vorbis_comment(drflac_vorbis_comment_iterator* pIter, drflac_uint32* pCommentLengthOut); -typedef struct -{ - drflac_uint32 countRemaining; - const char* pRunningData; -} drflac_cuesheet_track_iterator; -typedef struct -{ - drflac_uint64 offset; - drflac_uint8 index; - drflac_uint8 reserved[3]; -} drflac_cuesheet_track_index; -typedef struct -{ - drflac_uint64 offset; - drflac_uint8 trackNumber; - char ISRC[12]; - drflac_bool8 isAudio; - drflac_bool8 preEmphasis; - drflac_uint8 indexCount; - const drflac_cuesheet_track_index* pIndexPoints; -} drflac_cuesheet_track; -DRFLAC_API void drflac_init_cuesheet_track_iterator(drflac_cuesheet_track_iterator* pIter, drflac_uint32 trackCount, const void* pTrackData); -DRFLAC_API drflac_bool32 drflac_next_cuesheet_track(drflac_cuesheet_track_iterator* pIter, drflac_cuesheet_track* pCuesheetTrack); -#ifdef __cplusplus -} -#endif -#endif -/* dr_flac_h end */ -#endif /* MA_NO_FLAC */ - -#if !defined(MA_NO_MP3) && !defined(MA_NO_DECODING) -/* dr_mp3_h begin */ -#ifndef dr_mp3_h -#define dr_mp3_h -#ifdef __cplusplus -extern "C" { -#endif -#define DRMP3_STRINGIFY(x) #x -#define DRMP3_XSTRINGIFY(x) DRMP3_STRINGIFY(x) -#define DRMP3_VERSION_MAJOR 0 -#define DRMP3_VERSION_MINOR 6 -#define DRMP3_VERSION_REVISION 34 -#define DRMP3_VERSION_STRING DRMP3_XSTRINGIFY(DRMP3_VERSION_MAJOR) "." DRMP3_XSTRINGIFY(DRMP3_VERSION_MINOR) "." DRMP3_XSTRINGIFY(DRMP3_VERSION_REVISION) -#include -typedef signed char drmp3_int8; -typedef unsigned char drmp3_uint8; -typedef signed short drmp3_int16; -typedef unsigned short drmp3_uint16; -typedef signed int drmp3_int32; -typedef unsigned int drmp3_uint32; -#if defined(_MSC_VER) && !defined(__clang__) - typedef signed __int64 drmp3_int64; - typedef unsigned __int64 drmp3_uint64; -#else - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #pragma GCC diagnostic ignored "-Wlong-long" - #if defined(__clang__) - #pragma GCC diagnostic ignored "-Wc++11-long-long" - #endif - #endif - typedef signed long long drmp3_int64; - typedef unsigned long long drmp3_uint64; - #if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop - #endif -#endif -#if defined(__LP64__) || defined(_WIN64) || (defined(__x86_64__) && !defined(__ILP32__)) || defined(_M_X64) || defined(__ia64) || defined (_M_IA64) || defined(__aarch64__) || defined(_M_ARM64) || defined(__powerpc64__) - typedef drmp3_uint64 drmp3_uintptr; -#else - typedef drmp3_uint32 drmp3_uintptr; -#endif -typedef drmp3_uint8 drmp3_bool8; -typedef drmp3_uint32 drmp3_bool32; -#define DRMP3_TRUE 1 -#define DRMP3_FALSE 0 -#if !defined(DRMP3_API) - #if defined(DRMP3_DLL) - #if defined(_WIN32) - #define DRMP3_DLL_IMPORT __declspec(dllimport) - #define DRMP3_DLL_EXPORT __declspec(dllexport) - #define DRMP3_DLL_PRIVATE static - #else - #if defined(__GNUC__) && __GNUC__ >= 4 - #define DRMP3_DLL_IMPORT __attribute__((visibility("default"))) - #define DRMP3_DLL_EXPORT __attribute__((visibility("default"))) - #define DRMP3_DLL_PRIVATE __attribute__((visibility("hidden"))) - #else - #define DRMP3_DLL_IMPORT - #define DRMP3_DLL_EXPORT - #define DRMP3_DLL_PRIVATE static - #endif - #endif - #if defined(DR_MP3_IMPLEMENTATION) || defined(DRMP3_IMPLEMENTATION) - #define DRMP3_API DRMP3_DLL_EXPORT - #else - #define DRMP3_API DRMP3_DLL_IMPORT - #endif - #define DRMP3_PRIVATE DRMP3_DLL_PRIVATE - #else - #define DRMP3_API extern - #define DRMP3_PRIVATE static - #endif -#endif -typedef drmp3_int32 drmp3_result; -#define DRMP3_SUCCESS 0 -#define DRMP3_ERROR -1 -#define DRMP3_INVALID_ARGS -2 -#define DRMP3_INVALID_OPERATION -3 -#define DRMP3_OUT_OF_MEMORY -4 -#define DRMP3_OUT_OF_RANGE -5 -#define DRMP3_ACCESS_DENIED -6 -#define DRMP3_DOES_NOT_EXIST -7 -#define DRMP3_ALREADY_EXISTS -8 -#define DRMP3_TOO_MANY_OPEN_FILES -9 -#define DRMP3_INVALID_FILE -10 -#define DRMP3_TOO_BIG -11 -#define DRMP3_PATH_TOO_LONG -12 -#define DRMP3_NAME_TOO_LONG -13 -#define DRMP3_NOT_DIRECTORY -14 -#define DRMP3_IS_DIRECTORY -15 -#define DRMP3_DIRECTORY_NOT_EMPTY -16 -#define DRMP3_END_OF_FILE -17 -#define DRMP3_NO_SPACE -18 -#define DRMP3_BUSY -19 -#define DRMP3_IO_ERROR -20 -#define DRMP3_INTERRUPT -21 -#define DRMP3_UNAVAILABLE -22 -#define DRMP3_ALREADY_IN_USE -23 -#define DRMP3_BAD_ADDRESS -24 -#define DRMP3_BAD_SEEK -25 -#define DRMP3_BAD_PIPE -26 -#define DRMP3_DEADLOCK -27 -#define DRMP3_TOO_MANY_LINKS -28 -#define DRMP3_NOT_IMPLEMENTED -29 -#define DRMP3_NO_MESSAGE -30 -#define DRMP3_BAD_MESSAGE -31 -#define DRMP3_NO_DATA_AVAILABLE -32 -#define DRMP3_INVALID_DATA -33 -#define DRMP3_TIMEOUT -34 -#define DRMP3_NO_NETWORK -35 -#define DRMP3_NOT_UNIQUE -36 -#define DRMP3_NOT_SOCKET -37 -#define DRMP3_NO_ADDRESS -38 -#define DRMP3_BAD_PROTOCOL -39 -#define DRMP3_PROTOCOL_UNAVAILABLE -40 -#define DRMP3_PROTOCOL_NOT_SUPPORTED -41 -#define DRMP3_PROTOCOL_FAMILY_NOT_SUPPORTED -42 -#define DRMP3_ADDRESS_FAMILY_NOT_SUPPORTED -43 -#define DRMP3_SOCKET_NOT_SUPPORTED -44 -#define DRMP3_CONNECTION_RESET -45 -#define DRMP3_ALREADY_CONNECTED -46 -#define DRMP3_NOT_CONNECTED -47 -#define DRMP3_CONNECTION_REFUSED -48 -#define DRMP3_NO_HOST -49 -#define DRMP3_IN_PROGRESS -50 -#define DRMP3_CANCELLED -51 -#define DRMP3_MEMORY_ALREADY_MAPPED -52 -#define DRMP3_AT_END -53 -#define DRMP3_MAX_PCM_FRAMES_PER_MP3_FRAME 1152 -#define DRMP3_MAX_SAMPLES_PER_FRAME (DRMP3_MAX_PCM_FRAMES_PER_MP3_FRAME*2) -#ifdef _MSC_VER - #define DRMP3_INLINE __forceinline -#elif defined(__GNUC__) - #if defined(__STRICT_ANSI__) - #define DRMP3_GNUC_INLINE_HINT __inline__ - #else - #define DRMP3_GNUC_INLINE_HINT inline - #endif - #if (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 2)) || defined(__clang__) - #define DRMP3_INLINE DRMP3_GNUC_INLINE_HINT __attribute__((always_inline)) - #else - #define DRMP3_INLINE DRMP3_GNUC_INLINE_HINT - #endif -#elif defined(__WATCOMC__) - #define DRMP3_INLINE __inline -#else - #define DRMP3_INLINE -#endif -DRMP3_API void drmp3_version(drmp3_uint32* pMajor, drmp3_uint32* pMinor, drmp3_uint32* pRevision); -DRMP3_API const char* drmp3_version_string(void); -typedef struct -{ - int frame_bytes, channels, hz, layer, bitrate_kbps; -} drmp3dec_frame_info; -typedef struct -{ - float mdct_overlap[2][9*32], qmf_state[15*2*32]; - int reserv, free_format_bytes; - drmp3_uint8 header[4], reserv_buf[511]; -} drmp3dec; -DRMP3_API void drmp3dec_init(drmp3dec *dec); -DRMP3_API int drmp3dec_decode_frame(drmp3dec *dec, const drmp3_uint8 *mp3, int mp3_bytes, void *pcm, drmp3dec_frame_info *info); -DRMP3_API void drmp3dec_f32_to_s16(const float *in, drmp3_int16 *out, size_t num_samples); -typedef enum -{ - drmp3_seek_origin_start, - drmp3_seek_origin_current -} drmp3_seek_origin; -typedef struct -{ - drmp3_uint64 seekPosInBytes; - drmp3_uint64 pcmFrameIndex; - drmp3_uint16 mp3FramesToDiscard; - drmp3_uint16 pcmFramesToDiscard; -} drmp3_seek_point; -typedef size_t (* drmp3_read_proc)(void* pUserData, void* pBufferOut, size_t bytesToRead); -typedef drmp3_bool32 (* drmp3_seek_proc)(void* pUserData, int offset, drmp3_seek_origin origin); -typedef struct -{ - void* pUserData; - void* (* onMalloc)(size_t sz, void* pUserData); - void* (* onRealloc)(void* p, size_t sz, void* pUserData); - void (* onFree)(void* p, void* pUserData); -} drmp3_allocation_callbacks; -typedef struct -{ - drmp3_uint32 channels; - drmp3_uint32 sampleRate; -} drmp3_config; -typedef struct -{ - drmp3dec decoder; - drmp3_uint32 channels; - drmp3_uint32 sampleRate; - drmp3_read_proc onRead; - drmp3_seek_proc onSeek; - void* pUserData; - drmp3_allocation_callbacks allocationCallbacks; - drmp3_uint32 mp3FrameChannels; - drmp3_uint32 mp3FrameSampleRate; - drmp3_uint32 pcmFramesConsumedInMP3Frame; - drmp3_uint32 pcmFramesRemainingInMP3Frame; - drmp3_uint8 pcmFrames[sizeof(float)*DRMP3_MAX_SAMPLES_PER_FRAME]; - drmp3_uint64 currentPCMFrame; - drmp3_uint64 streamCursor; - drmp3_seek_point* pSeekPoints; - drmp3_uint32 seekPointCount; - size_t dataSize; - size_t dataCapacity; - size_t dataConsumed; - drmp3_uint8* pData; - drmp3_bool32 atEnd : 1; - struct - { - const drmp3_uint8* pData; - size_t dataSize; - size_t currentReadPos; - } memory; -} drmp3; -DRMP3_API drmp3_bool32 drmp3_init(drmp3* pMP3, drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API drmp3_bool32 drmp3_init_memory(drmp3* pMP3, const void* pData, size_t dataSize, const drmp3_allocation_callbacks* pAllocationCallbacks); -#ifndef DR_MP3_NO_STDIO -DRMP3_API drmp3_bool32 drmp3_init_file(drmp3* pMP3, const char* pFilePath, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API drmp3_bool32 drmp3_init_file_w(drmp3* pMP3, const wchar_t* pFilePath, const drmp3_allocation_callbacks* pAllocationCallbacks); -#endif -DRMP3_API void drmp3_uninit(drmp3* pMP3); -DRMP3_API drmp3_uint64 drmp3_read_pcm_frames_f32(drmp3* pMP3, drmp3_uint64 framesToRead, float* pBufferOut); -DRMP3_API drmp3_uint64 drmp3_read_pcm_frames_s16(drmp3* pMP3, drmp3_uint64 framesToRead, drmp3_int16* pBufferOut); -DRMP3_API drmp3_bool32 drmp3_seek_to_pcm_frame(drmp3* pMP3, drmp3_uint64 frameIndex); -DRMP3_API drmp3_uint64 drmp3_get_pcm_frame_count(drmp3* pMP3); -DRMP3_API drmp3_uint64 drmp3_get_mp3_frame_count(drmp3* pMP3); -DRMP3_API drmp3_bool32 drmp3_get_mp3_and_pcm_frame_count(drmp3* pMP3, drmp3_uint64* pMP3FrameCount, drmp3_uint64* pPCMFrameCount); -DRMP3_API drmp3_bool32 drmp3_calculate_seek_points(drmp3* pMP3, drmp3_uint32* pSeekPointCount, drmp3_seek_point* pSeekPoints); -DRMP3_API drmp3_bool32 drmp3_bind_seek_table(drmp3* pMP3, drmp3_uint32 seekPointCount, drmp3_seek_point* pSeekPoints); -DRMP3_API float* drmp3_open_and_read_pcm_frames_f32(drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API drmp3_int16* drmp3_open_and_read_pcm_frames_s16(drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API float* drmp3_open_memory_and_read_pcm_frames_f32(const void* pData, size_t dataSize, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API drmp3_int16* drmp3_open_memory_and_read_pcm_frames_s16(const void* pData, size_t dataSize, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks); -#ifndef DR_MP3_NO_STDIO -DRMP3_API float* drmp3_open_file_and_read_pcm_frames_f32(const char* filePath, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API drmp3_int16* drmp3_open_file_and_read_pcm_frames_s16(const char* filePath, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks); -#endif -DRMP3_API void* drmp3_malloc(size_t sz, const drmp3_allocation_callbacks* pAllocationCallbacks); -DRMP3_API void drmp3_free(void* p, const drmp3_allocation_callbacks* pAllocationCallbacks); -#ifdef __cplusplus -} -#endif -#endif -/* dr_mp3_h end */ -#endif /* MA_NO_MP3 */ - - -/************************************************************************************************************************************************************** - -Decoding - -**************************************************************************************************************************************************************/ -#ifndef MA_NO_DECODING - -static ma_result ma_decoder_read_bytes(ma_decoder* pDecoder, void* pBufferOut, size_t bytesToRead, size_t* pBytesRead) -{ - MA_ASSERT(pDecoder != NULL); - - return pDecoder->onRead(pDecoder, pBufferOut, bytesToRead, pBytesRead); -} - -static ma_result ma_decoder_seek_bytes(ma_decoder* pDecoder, ma_int64 byteOffset, ma_seek_origin origin) -{ - MA_ASSERT(pDecoder != NULL); - - return pDecoder->onSeek(pDecoder, byteOffset, origin); -} - -static ma_result ma_decoder_tell_bytes(ma_decoder* pDecoder, ma_int64* pCursor) -{ - MA_ASSERT(pDecoder != NULL); - - if (pDecoder->onTell == NULL) { - return MA_NOT_IMPLEMENTED; - } - - return pDecoder->onTell(pDecoder, pCursor); -} - - -MA_API ma_decoding_backend_config ma_decoding_backend_config_init(ma_format preferredFormat, ma_uint32 seekPointCount) -{ - ma_decoding_backend_config config; - - MA_ZERO_OBJECT(&config); - config.preferredFormat = preferredFormat; - config.seekPointCount = seekPointCount; - - return config; -} - - -MA_API ma_decoder_config ma_decoder_config_init(ma_format outputFormat, ma_uint32 outputChannels, ma_uint32 outputSampleRate) -{ - ma_decoder_config config; - MA_ZERO_OBJECT(&config); - config.format = outputFormat; - config.channels = outputChannels; - config.sampleRate = outputSampleRate; - config.resampling = ma_resampler_config_init(ma_format_unknown, 0, 0, 0, ma_resample_algorithm_linear); /* Format/channels/rate doesn't matter here. */ - config.encodingFormat = ma_encoding_format_unknown; - - /* Note that we are intentionally leaving the channel map empty here which will cause the default channel map to be used. */ - - return config; -} - -MA_API ma_decoder_config ma_decoder_config_init_default() -{ - return ma_decoder_config_init(ma_format_unknown, 0, 0); -} - -MA_API ma_decoder_config ma_decoder_config_init_copy(const ma_decoder_config* pConfig) -{ - ma_decoder_config config; - if (pConfig != NULL) { - config = *pConfig; - } else { - MA_ZERO_OBJECT(&config); - } - - return config; -} - -static ma_result ma_decoder__init_data_converter(ma_decoder* pDecoder, const ma_decoder_config* pConfig) -{ - ma_result result; - ma_data_converter_config converterConfig; - ma_format internalFormat; - ma_uint32 internalChannels; - ma_uint32 internalSampleRate; - ma_channel internalChannelMap[MA_MAX_CHANNELS]; - - MA_ASSERT(pDecoder != NULL); - MA_ASSERT(pConfig != NULL); - - result = ma_data_source_get_data_format(pDecoder->pBackend, &internalFormat, &internalChannels, &internalSampleRate, internalChannelMap, ma_countof(internalChannelMap)); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the internal data format. */ - } - - - /* Make sure we're not asking for too many channels. */ - if (pConfig->channels > MA_MAX_CHANNELS) { - return MA_INVALID_ARGS; - } - - /* The internal channels should have already been validated at a higher level, but we'll do it again explicitly here for safety. */ - if (internalChannels > MA_MAX_CHANNELS) { - return MA_INVALID_ARGS; - } - - - /* Output format. */ - if (pConfig->format == ma_format_unknown) { - pDecoder->outputFormat = internalFormat; - } else { - pDecoder->outputFormat = pConfig->format; - } - - if (pConfig->channels == 0) { - pDecoder->outputChannels = internalChannels; - } else { - pDecoder->outputChannels = pConfig->channels; - } - - if (pConfig->sampleRate == 0) { - pDecoder->outputSampleRate = internalSampleRate; - } else { - pDecoder->outputSampleRate = pConfig->sampleRate; - } - - converterConfig = ma_data_converter_config_init( - internalFormat, pDecoder->outputFormat, - internalChannels, pDecoder->outputChannels, - internalSampleRate, pDecoder->outputSampleRate - ); - converterConfig.pChannelMapIn = internalChannelMap; - converterConfig.pChannelMapOut = pConfig->pChannelMap; - converterConfig.channelMixMode = pConfig->channelMixMode; - converterConfig.ditherMode = pConfig->ditherMode; - converterConfig.allowDynamicSampleRate = MA_FALSE; /* Never allow dynamic sample rate conversion. Setting this to true will disable passthrough optimizations. */ - converterConfig.resampling = pConfig->resampling; - - result = ma_data_converter_init(&converterConfig, &pDecoder->allocationCallbacks, &pDecoder->converter); - if (result != MA_SUCCESS) { - return result; - } - - /* - Now that we have the decoder we need to determine whether or not we need a heap-allocated cache. We'll - need this if the data converter does not support calculation of the required input frame count. To - determine support for this we'll just run a test. - */ - { - ma_uint64 unused; - - result = ma_data_converter_get_required_input_frame_count(&pDecoder->converter, 1, &unused); - if (result != MA_SUCCESS) { - /* - We were unable to calculate the required input frame count which means we'll need to use - a heap-allocated cache. - */ - ma_uint64 inputCacheCapSizeInBytes; - - pDecoder->inputCacheCap = MA_DATA_CONVERTER_STACK_BUFFER_SIZE / ma_get_bytes_per_frame(internalFormat, internalChannels); - - /* Not strictly necessary, but keeping here for safety in case we change the default value of pDecoder->inputCacheCap. */ - inputCacheCapSizeInBytes = pDecoder->inputCacheCap * ma_get_bytes_per_frame(internalFormat, internalChannels); - if (inputCacheCapSizeInBytes > MA_SIZE_MAX) { - ma_data_converter_uninit(&pDecoder->converter, &pDecoder->allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - pDecoder->pInputCache = ma_malloc((size_t)inputCacheCapSizeInBytes, &pDecoder->allocationCallbacks); /* Safe cast to size_t. */ - if (pDecoder->pInputCache == NULL) { - ma_data_converter_uninit(&pDecoder->converter, &pDecoder->allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - } - } - - return MA_SUCCESS; -} - - - -static ma_result ma_decoder_internal_on_read__custom(void* pUserData, void* pBufferOut, size_t bytesToRead, size_t* pBytesRead) -{ - ma_decoder* pDecoder = (ma_decoder*)pUserData; - MA_ASSERT(pDecoder != NULL); - - return ma_decoder_read_bytes(pDecoder, pBufferOut, bytesToRead, pBytesRead); -} - -static ma_result ma_decoder_internal_on_seek__custom(void* pUserData, ma_int64 offset, ma_seek_origin origin) -{ - ma_decoder* pDecoder = (ma_decoder*)pUserData; - MA_ASSERT(pDecoder != NULL); - - return ma_decoder_seek_bytes(pDecoder, offset, origin); -} - -static ma_result ma_decoder_internal_on_tell__custom(void* pUserData, ma_int64* pCursor) -{ - ma_decoder* pDecoder = (ma_decoder*)pUserData; - MA_ASSERT(pDecoder != NULL); - - return ma_decoder_tell_bytes(pDecoder, pCursor); -} - - -static ma_result ma_decoder_init_from_vtable(const ma_decoding_backend_vtable* pVTable, void* pVTableUserData, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - ma_decoding_backend_config backendConfig; - ma_data_source* pBackend; - - MA_ASSERT(pVTable != NULL); - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pDecoder != NULL); - - if (pVTable->onInit == NULL) { - return MA_NOT_IMPLEMENTED; - } - - backendConfig = ma_decoding_backend_config_init(pConfig->format, pConfig->seekPointCount); - - result = pVTable->onInit(pVTableUserData, ma_decoder_internal_on_read__custom, ma_decoder_internal_on_seek__custom, ma_decoder_internal_on_tell__custom, pDecoder, &backendConfig, &pDecoder->allocationCallbacks, &pBackend); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the backend from this vtable. */ - } - - /* Getting here means we were able to initialize the backend so we can now initialize the decoder. */ - pDecoder->pBackend = pBackend; - pDecoder->pBackendVTable = pVTable; - pDecoder->pBackendUserData = pConfig->pCustomBackendUserData; - - return MA_SUCCESS; -} - - - -static ma_result ma_decoder_init_custom__internal(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result = MA_NO_BACKEND; - size_t ivtable; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pDecoder != NULL); - - if (pConfig->ppCustomBackendVTables == NULL) { - return MA_NO_BACKEND; - } - - /* The order each backend is listed is what defines the priority. */ - for (ivtable = 0; ivtable < pConfig->customBackendCount; ivtable += 1) { - const ma_decoding_backend_vtable* pVTable = pConfig->ppCustomBackendVTables[ivtable]; - if (pVTable != NULL && pVTable->onInit != NULL) { - result = ma_decoder_init_from_vtable(pVTable, pConfig->pCustomBackendUserData, pConfig, pDecoder); - if (result == MA_SUCCESS) { - return MA_SUCCESS; - } else { - /* Initialization failed. Move on to the next one, but seek back to the start first so the next vtable starts from the first byte of the file. */ - result = ma_decoder_seek_bytes(pDecoder, 0, ma_seek_origin_start); - if (result != MA_SUCCESS) { - return result; /* Failed to seek back to the start. */ - } - } - } else { - /* No vtable. */ - } - } - - /* Getting here means we couldn't find a backend. */ - return MA_NO_BACKEND; -} - - -/* WAV */ -#ifdef dr_wav_h -#define MA_HAS_WAV - -typedef struct -{ - ma_data_source_base ds; - ma_read_proc onRead; - ma_seek_proc onSeek; - ma_tell_proc onTell; - void* pReadSeekTellUserData; - ma_format format; /* Can be f32, s16 or s32. */ -#if !defined(MA_NO_WAV) - drwav dr; -#endif -} ma_wav; - -MA_API ma_result ma_wav_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav); -MA_API ma_result ma_wav_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav); -MA_API ma_result ma_wav_init_file_w(const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav); -MA_API ma_result ma_wav_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav); -MA_API void ma_wav_uninit(ma_wav* pWav, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_wav_read_pcm_frames(ma_wav* pWav, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_wav_seek_to_pcm_frame(ma_wav* pWav, ma_uint64 frameIndex); -MA_API ma_result ma_wav_get_data_format(ma_wav* pWav, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_wav_get_cursor_in_pcm_frames(ma_wav* pWav, ma_uint64* pCursor); -MA_API ma_result ma_wav_get_length_in_pcm_frames(ma_wav* pWav, ma_uint64* pLength); - - -static ma_result ma_wav_ds_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_wav_read_pcm_frames((ma_wav*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_wav_ds_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_wav_seek_to_pcm_frame((ma_wav*)pDataSource, frameIndex); -} - -static ma_result ma_wav_ds_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_wav_get_data_format((ma_wav*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_wav_ds_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_wav_get_cursor_in_pcm_frames((ma_wav*)pDataSource, pCursor); -} - -static ma_result ma_wav_ds_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_wav_get_length_in_pcm_frames((ma_wav*)pDataSource, pLength); -} - -static ma_data_source_vtable g_ma_wav_ds_vtable = -{ - ma_wav_ds_read, - ma_wav_ds_seek, - ma_wav_ds_get_data_format, - ma_wav_ds_get_cursor, - ma_wav_ds_get_length, - NULL, /* onSetLooping */ - 0 -}; - - -#if !defined(MA_NO_WAV) -static drwav_allocation_callbacks drwav_allocation_callbacks_from_miniaudio(const ma_allocation_callbacks* pAllocationCallbacks) -{ - drwav_allocation_callbacks callbacks; - - if (pAllocationCallbacks != NULL) { - callbacks.onMalloc = pAllocationCallbacks->onMalloc; - callbacks.onRealloc = pAllocationCallbacks->onRealloc; - callbacks.onFree = pAllocationCallbacks->onFree; - callbacks.pUserData = pAllocationCallbacks->pUserData; - } else { - callbacks.onMalloc = ma__malloc_default; - callbacks.onRealloc = ma__realloc_default; - callbacks.onFree = ma__free_default; - callbacks.pUserData = NULL; - } - - return callbacks; -} - -static size_t ma_wav_dr_callback__read(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - ma_wav* pWav = (ma_wav*)pUserData; - ma_result result; - size_t bytesRead; - - MA_ASSERT(pWav != NULL); - - result = pWav->onRead(pWav->pReadSeekTellUserData, pBufferOut, bytesToRead, &bytesRead); - (void)result; - - return bytesRead; -} - -static drwav_bool32 ma_wav_dr_callback__seek(void* pUserData, int offset, drwav_seek_origin origin) -{ - ma_wav* pWav = (ma_wav*)pUserData; - ma_result result; - ma_seek_origin maSeekOrigin; - - MA_ASSERT(pWav != NULL); - - maSeekOrigin = ma_seek_origin_start; - if (origin == drwav_seek_origin_current) { - maSeekOrigin = ma_seek_origin_current; - } - - result = pWav->onSeek(pWav->pReadSeekTellUserData, offset, maSeekOrigin); - if (result != MA_SUCCESS) { - return MA_FALSE; - } - - return MA_TRUE; -} -#endif - -static ma_result ma_wav_init_internal(const ma_decoding_backend_config* pConfig, ma_wav* pWav) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - if (pWav == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pWav); - pWav->format = ma_format_unknown; /* Use closest match to source file by default. */ - - if (pConfig != NULL && (pConfig->preferredFormat == ma_format_f32 || pConfig->preferredFormat == ma_format_s16 || pConfig->preferredFormat == ma_format_s32)) { - pWav->format = pConfig->preferredFormat; - } else { - /* Getting here means something other than f32 and s16 was specified. Just leave this unset to use the default format. */ - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_wav_ds_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pWav->ds); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the base data source. */ - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_wav_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav) -{ - ma_result result; - - result = ma_wav_init_internal(pConfig, pWav); - if (result != MA_SUCCESS) { - return result; - } - - if (onRead == NULL || onSeek == NULL) { - return MA_INVALID_ARGS; /* onRead and onSeek are mandatory. */ - } - - pWav->onRead = onRead; - pWav->onSeek = onSeek; - pWav->onTell = onTell; - pWav->pReadSeekTellUserData = pReadSeekTellUserData; - - #if !defined(MA_NO_WAV) - { - drwav_allocation_callbacks wavAllocationCallbacks = drwav_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drwav_bool32 wavResult; - - wavResult = drwav_init(&pWav->dr, ma_wav_dr_callback__read, ma_wav_dr_callback__seek, pWav, &wavAllocationCallbacks); - if (wavResult != MA_TRUE) { - return MA_INVALID_FILE; - } - - /* - If an explicit format was not specified, try picking the closest match based on the internal - format. The format needs to be supported by miniaudio. - */ - if (pWav->format == ma_format_unknown) { - switch (pWav->dr.translatedFormatTag) - { - case DR_WAVE_FORMAT_PCM: - { - if (pWav->dr.bitsPerSample == 8) { - pWav->format = ma_format_u8; - } else if (pWav->dr.bitsPerSample == 16) { - pWav->format = ma_format_s16; - } else if (pWav->dr.bitsPerSample == 24) { - pWav->format = ma_format_s24; - } else if (pWav->dr.bitsPerSample == 32) { - pWav->format = ma_format_s32; - } - } break; - - case DR_WAVE_FORMAT_IEEE_FLOAT: - { - if (pWav->dr.bitsPerSample == 32) { - pWav->format = ma_format_f32; - } - } break; - - default: break; - } - - /* Fall back to f32 if we couldn't find anything. */ - if (pWav->format == ma_format_unknown) { - pWav->format = ma_format_f32; - } - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. */ - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav) -{ - ma_result result; - - result = ma_wav_init_internal(pConfig, pWav); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_WAV) - { - drwav_allocation_callbacks wavAllocationCallbacks = drwav_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drwav_bool32 wavResult; - - wavResult = drwav_init_file(&pWav->dr, pFilePath, &wavAllocationCallbacks); - if (wavResult != MA_TRUE) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_init_file_w(const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav) -{ - ma_result result; - - result = ma_wav_init_internal(pConfig, pWav); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_WAV) - { - drwav_allocation_callbacks wavAllocationCallbacks = drwav_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drwav_bool32 wavResult; - - wavResult = drwav_init_file_w(&pWav->dr, pFilePath, &wavAllocationCallbacks); - if (wavResult != MA_TRUE) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_wav* pWav) -{ - ma_result result; - - result = ma_wav_init_internal(pConfig, pWav); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_WAV) - { - drwav_allocation_callbacks wavAllocationCallbacks = drwav_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drwav_bool32 wavResult; - - wavResult = drwav_init_memory(&pWav->dr, pData, dataSize, &wavAllocationCallbacks); - if (wavResult != MA_TRUE) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. */ - (void)pData; - (void)dataSize; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API void ma_wav_uninit(ma_wav* pWav, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pWav == NULL) { - return; - } - - (void)pAllocationCallbacks; - - #if !defined(MA_NO_WAV) - { - drwav_uninit(&pWav->dr); - } - #else - { - /* wav is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - } - #endif - - ma_data_source_uninit(&pWav->ds); -} - -MA_API ma_result ma_wav_read_pcm_frames(ma_wav* pWav, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pWav == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_WAV) - { - /* We always use floating point format. */ - ma_result result = MA_SUCCESS; /* Must be initialized to MA_SUCCESS. */ - ma_uint64 totalFramesRead = 0; - ma_format format; - - ma_wav_get_data_format(pWav, &format, NULL, NULL, NULL, 0); - - switch (format) - { - case ma_format_f32: - { - totalFramesRead = drwav_read_pcm_frames_f32(&pWav->dr, frameCount, (float*)pFramesOut); - } break; - - case ma_format_s16: - { - totalFramesRead = drwav_read_pcm_frames_s16(&pWav->dr, frameCount, (drwav_int16*)pFramesOut); - } break; - - case ma_format_s32: - { - totalFramesRead = drwav_read_pcm_frames_s32(&pWav->dr, frameCount, (drwav_int32*)pFramesOut); - } break; - - /* Fallback to a raw read. */ - case ma_format_unknown: return MA_INVALID_OPERATION; /* <-- this should never be hit because initialization would just fall back to a supported format. */ - default: - { - totalFramesRead = drwav_read_pcm_frames(&pWav->dr, frameCount, pFramesOut); - } break; - } - - /* In the future we'll update dr_wav to return MA_AT_END for us. */ - if (totalFramesRead == 0) { - result = MA_AT_END; - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - if (result == MA_SUCCESS && totalFramesRead == 0) { - result = MA_AT_END; - } - - return result; - } - #else - { - /* wav is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)pFramesOut; - (void)frameCount; - (void)pFramesRead; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_seek_to_pcm_frame(ma_wav* pWav, ma_uint64 frameIndex) -{ - if (pWav == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_WAV) - { - drwav_bool32 wavResult; - - wavResult = drwav_seek_to_pcm_frame(&pWav->dr, frameIndex); - if (wavResult != DRWAV_TRUE) { - return MA_ERROR; - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)frameIndex; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_get_data_format(ma_wav* pWav, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - /* Defaults for safety. */ - if (pFormat != NULL) { - *pFormat = ma_format_unknown; - } - if (pChannels != NULL) { - *pChannels = 0; - } - if (pSampleRate != NULL) { - *pSampleRate = 0; - } - if (pChannelMap != NULL) { - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channelMapCap); - } - - if (pWav == NULL) { - return MA_INVALID_OPERATION; - } - - if (pFormat != NULL) { - *pFormat = pWav->format; - } - - #if !defined(MA_NO_WAV) - { - if (pChannels != NULL) { - *pChannels = pWav->dr.channels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pWav->dr.sampleRate; - } - - if (pChannelMap != NULL) { - ma_channel_map_init_standard(ma_standard_channel_map_microsoft, pChannelMap, channelMapCap, pWav->dr.channels); - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_get_cursor_in_pcm_frames(ma_wav* pWav, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; /* Safety. */ - - if (pWav == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_WAV) - { - drwav_result wavResult = drwav_get_cursor_in_pcm_frames(&pWav->dr, pCursor); - if (wavResult != DRWAV_SUCCESS) { - return (ma_result)wavResult; /* dr_wav result codes map to miniaudio's. */ - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_wav_get_length_in_pcm_frames(ma_wav* pWav, ma_uint64* pLength) -{ - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; /* Safety. */ - - if (pWav == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_WAV) - { - drwav_result wavResult = drwav_get_length_in_pcm_frames(&pWav->dr, pLength); - if (wavResult != DRWAV_SUCCESS) { - return (ma_result)wavResult; /* dr_wav result codes map to miniaudio's. */ - } - - return MA_SUCCESS; - } - #else - { - /* wav is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - - -static ma_result ma_decoding_backend_init__wav(void* pUserData, ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_wav* pWav; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pWav = (ma_wav*)ma_malloc(sizeof(*pWav), pAllocationCallbacks); - if (pWav == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_wav_init(onRead, onSeek, onTell, pReadSeekTellUserData, pConfig, pAllocationCallbacks, pWav); - if (result != MA_SUCCESS) { - ma_free(pWav, pAllocationCallbacks); - return result; - } - - *ppBackend = pWav; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file__wav(void* pUserData, const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_wav* pWav; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pWav = (ma_wav*)ma_malloc(sizeof(*pWav), pAllocationCallbacks); - if (pWav == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_wav_init_file(pFilePath, pConfig, pAllocationCallbacks, pWav); - if (result != MA_SUCCESS) { - ma_free(pWav, pAllocationCallbacks); - return result; - } - - *ppBackend = pWav; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file_w__wav(void* pUserData, const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_wav* pWav; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pWav = (ma_wav*)ma_malloc(sizeof(*pWav), pAllocationCallbacks); - if (pWav == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_wav_init_file_w(pFilePath, pConfig, pAllocationCallbacks, pWav); - if (result != MA_SUCCESS) { - ma_free(pWav, pAllocationCallbacks); - return result; - } - - *ppBackend = pWav; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_memory__wav(void* pUserData, const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_wav* pWav; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pWav = (ma_wav*)ma_malloc(sizeof(*pWav), pAllocationCallbacks); - if (pWav == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_wav_init_memory(pData, dataSize, pConfig, pAllocationCallbacks, pWav); - if (result != MA_SUCCESS) { - ma_free(pWav, pAllocationCallbacks); - return result; - } - - *ppBackend = pWav; - - return MA_SUCCESS; -} - -static void ma_decoding_backend_uninit__wav(void* pUserData, ma_data_source* pBackend, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_wav* pWav = (ma_wav*)pBackend; - - (void)pUserData; - - ma_wav_uninit(pWav, pAllocationCallbacks); - ma_free(pWav, pAllocationCallbacks); -} - -static ma_decoding_backend_vtable g_ma_decoding_backend_vtable_wav = -{ - ma_decoding_backend_init__wav, - ma_decoding_backend_init_file__wav, - ma_decoding_backend_init_file_w__wav, - ma_decoding_backend_init_memory__wav, - ma_decoding_backend_uninit__wav -}; - -static ma_result ma_decoder_init_wav__internal(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - return ma_decoder_init_from_vtable(&g_ma_decoding_backend_vtable_wav, NULL, pConfig, pDecoder); -} -#endif /* dr_wav_h */ - -/* FLAC */ -#ifdef dr_flac_h -#define MA_HAS_FLAC - -typedef struct -{ - ma_data_source_base ds; - ma_read_proc onRead; - ma_seek_proc onSeek; - ma_tell_proc onTell; - void* pReadSeekTellUserData; - ma_format format; /* Can be f32, s16 or s32. */ -#if !defined(MA_NO_FLAC) - drflac* dr; -#endif -} ma_flac; - -MA_API ma_result ma_flac_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac); -MA_API ma_result ma_flac_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac); -MA_API ma_result ma_flac_init_file_w(const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac); -MA_API ma_result ma_flac_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac); -MA_API void ma_flac_uninit(ma_flac* pFlac, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_flac_read_pcm_frames(ma_flac* pFlac, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_flac_seek_to_pcm_frame(ma_flac* pFlac, ma_uint64 frameIndex); -MA_API ma_result ma_flac_get_data_format(ma_flac* pFlac, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_flac_get_cursor_in_pcm_frames(ma_flac* pFlac, ma_uint64* pCursor); -MA_API ma_result ma_flac_get_length_in_pcm_frames(ma_flac* pFlac, ma_uint64* pLength); - - -static ma_result ma_flac_ds_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_flac_read_pcm_frames((ma_flac*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_flac_ds_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_flac_seek_to_pcm_frame((ma_flac*)pDataSource, frameIndex); -} - -static ma_result ma_flac_ds_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_flac_get_data_format((ma_flac*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_flac_ds_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_flac_get_cursor_in_pcm_frames((ma_flac*)pDataSource, pCursor); -} - -static ma_result ma_flac_ds_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_flac_get_length_in_pcm_frames((ma_flac*)pDataSource, pLength); -} - -static ma_data_source_vtable g_ma_flac_ds_vtable = -{ - ma_flac_ds_read, - ma_flac_ds_seek, - ma_flac_ds_get_data_format, - ma_flac_ds_get_cursor, - ma_flac_ds_get_length, - NULL, /* onSetLooping */ - 0 -}; - - -#if !defined(MA_NO_FLAC) -static drflac_allocation_callbacks drflac_allocation_callbacks_from_miniaudio(const ma_allocation_callbacks* pAllocationCallbacks) -{ - drflac_allocation_callbacks callbacks; - - if (pAllocationCallbacks != NULL) { - callbacks.onMalloc = pAllocationCallbacks->onMalloc; - callbacks.onRealloc = pAllocationCallbacks->onRealloc; - callbacks.onFree = pAllocationCallbacks->onFree; - callbacks.pUserData = pAllocationCallbacks->pUserData; - } else { - callbacks.onMalloc = ma__malloc_default; - callbacks.onRealloc = ma__realloc_default; - callbacks.onFree = ma__free_default; - callbacks.pUserData = NULL; - } - - return callbacks; -} - -static size_t ma_flac_dr_callback__read(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - ma_flac* pFlac = (ma_flac*)pUserData; - ma_result result; - size_t bytesRead; - - MA_ASSERT(pFlac != NULL); - - result = pFlac->onRead(pFlac->pReadSeekTellUserData, pBufferOut, bytesToRead, &bytesRead); - (void)result; - - return bytesRead; -} - -static drflac_bool32 ma_flac_dr_callback__seek(void* pUserData, int offset, drflac_seek_origin origin) -{ - ma_flac* pFlac = (ma_flac*)pUserData; - ma_result result; - ma_seek_origin maSeekOrigin; - - MA_ASSERT(pFlac != NULL); - - maSeekOrigin = ma_seek_origin_start; - if (origin == drflac_seek_origin_current) { - maSeekOrigin = ma_seek_origin_current; - } - - result = pFlac->onSeek(pFlac->pReadSeekTellUserData, offset, maSeekOrigin); - if (result != MA_SUCCESS) { - return MA_FALSE; - } - - return MA_TRUE; -} -#endif - -static ma_result ma_flac_init_internal(const ma_decoding_backend_config* pConfig, ma_flac* pFlac) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - if (pFlac == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pFlac); - pFlac->format = ma_format_f32; /* f32 by default. */ - - if (pConfig != NULL && (pConfig->preferredFormat == ma_format_f32 || pConfig->preferredFormat == ma_format_s16 || pConfig->preferredFormat == ma_format_s32)) { - pFlac->format = pConfig->preferredFormat; - } else { - /* Getting here means something other than f32 and s16 was specified. Just leave this unset to use the default format. */ - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_flac_ds_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pFlac->ds); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the base data source. */ - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_flac_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac) -{ - ma_result result; - - result = ma_flac_init_internal(pConfig, pFlac); - if (result != MA_SUCCESS) { - return result; - } - - if (onRead == NULL || onSeek == NULL) { - return MA_INVALID_ARGS; /* onRead and onSeek are mandatory. */ - } - - pFlac->onRead = onRead; - pFlac->onSeek = onSeek; - pFlac->onTell = onTell; - pFlac->pReadSeekTellUserData = pReadSeekTellUserData; - - #if !defined(MA_NO_FLAC) - { - drflac_allocation_callbacks flacAllocationCallbacks = drflac_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - - pFlac->dr = drflac_open(ma_flac_dr_callback__read, ma_flac_dr_callback__seek, pFlac, &flacAllocationCallbacks); - if (pFlac->dr == NULL) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. */ - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac) -{ - ma_result result; - - result = ma_flac_init_internal(pConfig, pFlac); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_FLAC) - { - drflac_allocation_callbacks flacAllocationCallbacks = drflac_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - - pFlac->dr = drflac_open_file(pFilePath, &flacAllocationCallbacks); - if (pFlac->dr == NULL) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_init_file_w(const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac) -{ - ma_result result; - - result = ma_flac_init_internal(pConfig, pFlac); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_FLAC) - { - drflac_allocation_callbacks flacAllocationCallbacks = drflac_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - - pFlac->dr = drflac_open_file_w(pFilePath, &flacAllocationCallbacks); - if (pFlac->dr == NULL) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_flac* pFlac) -{ - ma_result result; - - result = ma_flac_init_internal(pConfig, pFlac); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_FLAC) - { - drflac_allocation_callbacks flacAllocationCallbacks = drflac_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - - pFlac->dr = drflac_open_memory(pData, dataSize, &flacAllocationCallbacks); - if (pFlac->dr == NULL) { - return MA_INVALID_FILE; - } - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. */ - (void)pData; - (void)dataSize; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API void ma_flac_uninit(ma_flac* pFlac, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pFlac == NULL) { - return; - } - - (void)pAllocationCallbacks; - - #if !defined(MA_NO_FLAC) - { - drflac_close(pFlac->dr); - } - #else - { - /* flac is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - } - #endif - - ma_data_source_uninit(&pFlac->ds); -} - -MA_API ma_result ma_flac_read_pcm_frames(ma_flac* pFlac, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pFlac == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_FLAC) - { - /* We always use floating point format. */ - ma_result result = MA_SUCCESS; /* Must be initialized to MA_SUCCESS. */ - ma_uint64 totalFramesRead = 0; - ma_format format; - - ma_flac_get_data_format(pFlac, &format, NULL, NULL, NULL, 0); - - switch (format) - { - case ma_format_f32: - { - totalFramesRead = drflac_read_pcm_frames_f32(pFlac->dr, frameCount, (float*)pFramesOut); - } break; - - case ma_format_s16: - { - totalFramesRead = drflac_read_pcm_frames_s16(pFlac->dr, frameCount, (drflac_int16*)pFramesOut); - } break; - - case ma_format_s32: - { - totalFramesRead = drflac_read_pcm_frames_s32(pFlac->dr, frameCount, (drflac_int32*)pFramesOut); - } break; - - case ma_format_u8: - case ma_format_s24: - case ma_format_unknown: - default: - { - return MA_INVALID_OPERATION; - }; - } - - /* In the future we'll update dr_flac to return MA_AT_END for us. */ - if (totalFramesRead == 0) { - result = MA_AT_END; - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - if (result == MA_SUCCESS && totalFramesRead == 0) { - result = MA_AT_END; - } - - return result; - } - #else - { - /* flac is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)pFramesOut; - (void)frameCount; - (void)pFramesRead; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_seek_to_pcm_frame(ma_flac* pFlac, ma_uint64 frameIndex) -{ - if (pFlac == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_FLAC) - { - drflac_bool32 flacResult; - - flacResult = drflac_seek_to_pcm_frame(pFlac->dr, frameIndex); - if (flacResult != DRFLAC_TRUE) { - return MA_ERROR; - } - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)frameIndex; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_get_data_format(ma_flac* pFlac, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - /* Defaults for safety. */ - if (pFormat != NULL) { - *pFormat = ma_format_unknown; - } - if (pChannels != NULL) { - *pChannels = 0; - } - if (pSampleRate != NULL) { - *pSampleRate = 0; - } - if (pChannelMap != NULL) { - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channelMapCap); - } - - if (pFlac == NULL) { - return MA_INVALID_OPERATION; - } - - if (pFormat != NULL) { - *pFormat = pFlac->format; - } - - #if !defined(MA_NO_FLAC) - { - if (pChannels != NULL) { - *pChannels = pFlac->dr->channels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pFlac->dr->sampleRate; - } - - if (pChannelMap != NULL) { - ma_channel_map_init_standard(ma_standard_channel_map_microsoft, pChannelMap, channelMapCap, pFlac->dr->channels); - } - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_get_cursor_in_pcm_frames(ma_flac* pFlac, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; /* Safety. */ - - if (pFlac == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_FLAC) - { - *pCursor = pFlac->dr->currentPCMFrame; - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_flac_get_length_in_pcm_frames(ma_flac* pFlac, ma_uint64* pLength) -{ - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; /* Safety. */ - - if (pFlac == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_FLAC) - { - *pLength = pFlac->dr->totalPCMFrameCount; - - return MA_SUCCESS; - } - #else - { - /* flac is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - - -static ma_result ma_decoding_backend_init__flac(void* pUserData, ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_flac* pFlac; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pFlac = (ma_flac*)ma_malloc(sizeof(*pFlac), pAllocationCallbacks); - if (pFlac == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_flac_init(onRead, onSeek, onTell, pReadSeekTellUserData, pConfig, pAllocationCallbacks, pFlac); - if (result != MA_SUCCESS) { - ma_free(pFlac, pAllocationCallbacks); - return result; - } - - *ppBackend = pFlac; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file__flac(void* pUserData, const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_flac* pFlac; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pFlac = (ma_flac*)ma_malloc(sizeof(*pFlac), pAllocationCallbacks); - if (pFlac == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_flac_init_file(pFilePath, pConfig, pAllocationCallbacks, pFlac); - if (result != MA_SUCCESS) { - ma_free(pFlac, pAllocationCallbacks); - return result; - } - - *ppBackend = pFlac; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file_w__flac(void* pUserData, const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_flac* pFlac; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pFlac = (ma_flac*)ma_malloc(sizeof(*pFlac), pAllocationCallbacks); - if (pFlac == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_flac_init_file_w(pFilePath, pConfig, pAllocationCallbacks, pFlac); - if (result != MA_SUCCESS) { - ma_free(pFlac, pAllocationCallbacks); - return result; - } - - *ppBackend = pFlac; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_memory__flac(void* pUserData, const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_flac* pFlac; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pFlac = (ma_flac*)ma_malloc(sizeof(*pFlac), pAllocationCallbacks); - if (pFlac == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_flac_init_memory(pData, dataSize, pConfig, pAllocationCallbacks, pFlac); - if (result != MA_SUCCESS) { - ma_free(pFlac, pAllocationCallbacks); - return result; - } - - *ppBackend = pFlac; - - return MA_SUCCESS; -} - -static void ma_decoding_backend_uninit__flac(void* pUserData, ma_data_source* pBackend, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_flac* pFlac = (ma_flac*)pBackend; - - (void)pUserData; - - ma_flac_uninit(pFlac, pAllocationCallbacks); - ma_free(pFlac, pAllocationCallbacks); -} - -static ma_decoding_backend_vtable g_ma_decoding_backend_vtable_flac = -{ - ma_decoding_backend_init__flac, - ma_decoding_backend_init_file__flac, - ma_decoding_backend_init_file_w__flac, - ma_decoding_backend_init_memory__flac, - ma_decoding_backend_uninit__flac -}; - -static ma_result ma_decoder_init_flac__internal(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - return ma_decoder_init_from_vtable(&g_ma_decoding_backend_vtable_flac, NULL, pConfig, pDecoder); -} -#endif /* dr_flac_h */ - -/* MP3 */ -#ifdef dr_mp3_h -#define MA_HAS_MP3 - -typedef struct -{ - ma_data_source_base ds; - ma_read_proc onRead; - ma_seek_proc onSeek; - ma_tell_proc onTell; - void* pReadSeekTellUserData; - ma_format format; /* Can be f32 or s16. */ -#if !defined(MA_NO_MP3) - drmp3 dr; - drmp3_uint32 seekPointCount; - drmp3_seek_point* pSeekPoints; /* Only used if seek table generation is used. */ -#endif -} ma_mp3; - -MA_API ma_result ma_mp3_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3); -MA_API ma_result ma_mp3_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3); -MA_API ma_result ma_mp3_init_file_w(const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3); -MA_API ma_result ma_mp3_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3); -MA_API void ma_mp3_uninit(ma_mp3* pMP3, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_mp3_read_pcm_frames(ma_mp3* pMP3, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_mp3_seek_to_pcm_frame(ma_mp3* pMP3, ma_uint64 frameIndex); -MA_API ma_result ma_mp3_get_data_format(ma_mp3* pMP3, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_mp3_get_cursor_in_pcm_frames(ma_mp3* pMP3, ma_uint64* pCursor); -MA_API ma_result ma_mp3_get_length_in_pcm_frames(ma_mp3* pMP3, ma_uint64* pLength); - - -static ma_result ma_mp3_ds_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_mp3_read_pcm_frames((ma_mp3*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_mp3_ds_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_mp3_seek_to_pcm_frame((ma_mp3*)pDataSource, frameIndex); -} - -static ma_result ma_mp3_ds_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_mp3_get_data_format((ma_mp3*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_mp3_ds_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_mp3_get_cursor_in_pcm_frames((ma_mp3*)pDataSource, pCursor); -} - -static ma_result ma_mp3_ds_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_mp3_get_length_in_pcm_frames((ma_mp3*)pDataSource, pLength); -} - -static ma_data_source_vtable g_ma_mp3_ds_vtable = -{ - ma_mp3_ds_read, - ma_mp3_ds_seek, - ma_mp3_ds_get_data_format, - ma_mp3_ds_get_cursor, - ma_mp3_ds_get_length, - NULL, /* onSetLooping */ - 0 -}; - - -#if !defined(MA_NO_MP3) -static drmp3_allocation_callbacks drmp3_allocation_callbacks_from_miniaudio(const ma_allocation_callbacks* pAllocationCallbacks) -{ - drmp3_allocation_callbacks callbacks; - - if (pAllocationCallbacks != NULL) { - callbacks.onMalloc = pAllocationCallbacks->onMalloc; - callbacks.onRealloc = pAllocationCallbacks->onRealloc; - callbacks.onFree = pAllocationCallbacks->onFree; - callbacks.pUserData = pAllocationCallbacks->pUserData; - } else { - callbacks.onMalloc = ma__malloc_default; - callbacks.onRealloc = ma__realloc_default; - callbacks.onFree = ma__free_default; - callbacks.pUserData = NULL; - } - - return callbacks; -} - -static size_t ma_mp3_dr_callback__read(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - ma_mp3* pMP3 = (ma_mp3*)pUserData; - ma_result result; - size_t bytesRead; - - MA_ASSERT(pMP3 != NULL); - - result = pMP3->onRead(pMP3->pReadSeekTellUserData, pBufferOut, bytesToRead, &bytesRead); - (void)result; - - return bytesRead; -} - -static drmp3_bool32 ma_mp3_dr_callback__seek(void* pUserData, int offset, drmp3_seek_origin origin) -{ - ma_mp3* pMP3 = (ma_mp3*)pUserData; - ma_result result; - ma_seek_origin maSeekOrigin; - - MA_ASSERT(pMP3 != NULL); - - maSeekOrigin = ma_seek_origin_start; - if (origin == drmp3_seek_origin_current) { - maSeekOrigin = ma_seek_origin_current; - } - - result = pMP3->onSeek(pMP3->pReadSeekTellUserData, offset, maSeekOrigin); - if (result != MA_SUCCESS) { - return MA_FALSE; - } - - return MA_TRUE; -} -#endif - -static ma_result ma_mp3_init_internal(const ma_decoding_backend_config* pConfig, ma_mp3* pMP3) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - if (pMP3 == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pMP3); - pMP3->format = ma_format_f32; /* f32 by default. */ - - if (pConfig != NULL && (pConfig->preferredFormat == ma_format_f32 || pConfig->preferredFormat == ma_format_s16)) { - pMP3->format = pConfig->preferredFormat; - } else { - /* Getting here means something other than f32 and s16 was specified. Just leave this unset to use the default format. */ - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_mp3_ds_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pMP3->ds); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the base data source. */ - } - - return MA_SUCCESS; -} - -static ma_result ma_mp3_generate_seek_table(ma_mp3* pMP3, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks) -{ - drmp3_bool32 mp3Result; - drmp3_uint32 seekPointCount = 0; - drmp3_seek_point* pSeekPoints = NULL; - - MA_ASSERT(pMP3 != NULL); - MA_ASSERT(pConfig != NULL); - - seekPointCount = pConfig->seekPointCount; - if (seekPointCount > 0) { - pSeekPoints = (drmp3_seek_point*)ma_malloc(sizeof(*pMP3->pSeekPoints) * seekPointCount, pAllocationCallbacks); - if (pSeekPoints == NULL) { - return MA_OUT_OF_MEMORY; - } - } - - mp3Result = drmp3_calculate_seek_points(&pMP3->dr, &seekPointCount, pSeekPoints); - if (mp3Result != MA_TRUE) { - ma_free(pSeekPoints, pAllocationCallbacks); - return MA_ERROR; - } - - mp3Result = drmp3_bind_seek_table(&pMP3->dr, seekPointCount, pSeekPoints); - if (mp3Result != MA_TRUE) { - ma_free(pSeekPoints, pAllocationCallbacks); - return MA_ERROR; - } - - pMP3->seekPointCount = seekPointCount; - pMP3->pSeekPoints = pSeekPoints; - - return MA_SUCCESS; -} - -MA_API ma_result ma_mp3_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3) -{ - ma_result result; - - result = ma_mp3_init_internal(pConfig, pMP3); - if (result != MA_SUCCESS) { - return result; - } - - if (onRead == NULL || onSeek == NULL) { - return MA_INVALID_ARGS; /* onRead and onSeek are mandatory. */ - } - - pMP3->onRead = onRead; - pMP3->onSeek = onSeek; - pMP3->onTell = onTell; - pMP3->pReadSeekTellUserData = pReadSeekTellUserData; - - #if !defined(MA_NO_MP3) - { - drmp3_allocation_callbacks mp3AllocationCallbacks = drmp3_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drmp3_bool32 mp3Result; - - mp3Result = drmp3_init(&pMP3->dr, ma_mp3_dr_callback__read, ma_mp3_dr_callback__seek, pMP3, &mp3AllocationCallbacks); - if (mp3Result != MA_TRUE) { - return MA_INVALID_FILE; - } - - ma_mp3_generate_seek_table(pMP3, pConfig, pAllocationCallbacks); - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. */ - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3) -{ - ma_result result; - - result = ma_mp3_init_internal(pConfig, pMP3); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_MP3) - { - drmp3_allocation_callbacks mp3AllocationCallbacks = drmp3_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drmp3_bool32 mp3Result; - - mp3Result = drmp3_init_file(&pMP3->dr, pFilePath, &mp3AllocationCallbacks); - if (mp3Result != MA_TRUE) { - return MA_INVALID_FILE; - } - - ma_mp3_generate_seek_table(pMP3, pConfig, pAllocationCallbacks); - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_init_file_w(const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3) -{ - ma_result result; - - result = ma_mp3_init_internal(pConfig, pMP3); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_MP3) - { - drmp3_allocation_callbacks mp3AllocationCallbacks = drmp3_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drmp3_bool32 mp3Result; - - mp3Result = drmp3_init_file_w(&pMP3->dr, pFilePath, &mp3AllocationCallbacks); - if (mp3Result != MA_TRUE) { - return MA_INVALID_FILE; - } - - ma_mp3_generate_seek_table(pMP3, pConfig, pAllocationCallbacks); - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_mp3* pMP3) -{ - ma_result result; - - result = ma_mp3_init_internal(pConfig, pMP3); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_MP3) - { - drmp3_allocation_callbacks mp3AllocationCallbacks = drmp3_allocation_callbacks_from_miniaudio(pAllocationCallbacks); - drmp3_bool32 mp3Result; - - mp3Result = drmp3_init_memory(&pMP3->dr, pData, dataSize, &mp3AllocationCallbacks); - if (mp3Result != MA_TRUE) { - return MA_INVALID_FILE; - } - - ma_mp3_generate_seek_table(pMP3, pConfig, pAllocationCallbacks); - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. */ - (void)pData; - (void)dataSize; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API void ma_mp3_uninit(ma_mp3* pMP3, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pMP3 == NULL) { - return; - } - - #if !defined(MA_NO_MP3) - { - drmp3_uninit(&pMP3->dr); - } - #else - { - /* mp3 is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - } - #endif - - /* Seek points need to be freed after the MP3 decoder has been uninitialized to ensure they're no longer being referenced. */ - ma_free(pMP3->pSeekPoints, pAllocationCallbacks); - - ma_data_source_uninit(&pMP3->ds); -} - -MA_API ma_result ma_mp3_read_pcm_frames(ma_mp3* pMP3, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pMP3 == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_MP3) - { - /* We always use floating point format. */ - ma_result result = MA_SUCCESS; /* Must be initialized to MA_SUCCESS. */ - ma_uint64 totalFramesRead = 0; - ma_format format; - - ma_mp3_get_data_format(pMP3, &format, NULL, NULL, NULL, 0); - - switch (format) - { - case ma_format_f32: - { - totalFramesRead = drmp3_read_pcm_frames_f32(&pMP3->dr, frameCount, (float*)pFramesOut); - } break; - - case ma_format_s16: - { - totalFramesRead = drmp3_read_pcm_frames_s16(&pMP3->dr, frameCount, (drmp3_int16*)pFramesOut); - } break; - - case ma_format_u8: - case ma_format_s24: - case ma_format_s32: - case ma_format_unknown: - default: - { - return MA_INVALID_OPERATION; - }; - } - - /* In the future we'll update dr_mp3 to return MA_AT_END for us. */ - if (totalFramesRead == 0) { - result = MA_AT_END; - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - return result; - } - #else - { - /* mp3 is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)pFramesOut; - (void)frameCount; - (void)pFramesRead; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_seek_to_pcm_frame(ma_mp3* pMP3, ma_uint64 frameIndex) -{ - if (pMP3 == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_MP3) - { - drmp3_bool32 mp3Result; - - mp3Result = drmp3_seek_to_pcm_frame(&pMP3->dr, frameIndex); - if (mp3Result != DRMP3_TRUE) { - return MA_ERROR; - } - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)frameIndex; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_get_data_format(ma_mp3* pMP3, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - /* Defaults for safety. */ - if (pFormat != NULL) { - *pFormat = ma_format_unknown; - } - if (pChannels != NULL) { - *pChannels = 0; - } - if (pSampleRate != NULL) { - *pSampleRate = 0; - } - if (pChannelMap != NULL) { - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channelMapCap); - } - - if (pMP3 == NULL) { - return MA_INVALID_OPERATION; - } - - if (pFormat != NULL) { - *pFormat = pMP3->format; - } - - #if !defined(MA_NO_MP3) - { - if (pChannels != NULL) { - *pChannels = pMP3->dr.channels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pMP3->dr.sampleRate; - } - - if (pChannelMap != NULL) { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pMP3->dr.channels); - } - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_get_cursor_in_pcm_frames(ma_mp3* pMP3, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; /* Safety. */ - - if (pMP3 == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_MP3) - { - *pCursor = pMP3->dr.currentPCMFrame; - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_mp3_get_length_in_pcm_frames(ma_mp3* pMP3, ma_uint64* pLength) -{ - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; /* Safety. */ - - if (pMP3 == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_MP3) - { - *pLength = drmp3_get_pcm_frame_count(&pMP3->dr); - - return MA_SUCCESS; - } - #else - { - /* mp3 is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - - -static ma_result ma_decoding_backend_init__mp3(void* pUserData, ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_mp3* pMP3; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pMP3 = (ma_mp3*)ma_malloc(sizeof(*pMP3), pAllocationCallbacks); - if (pMP3 == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_mp3_init(onRead, onSeek, onTell, pReadSeekTellUserData, pConfig, pAllocationCallbacks, pMP3); - if (result != MA_SUCCESS) { - ma_free(pMP3, pAllocationCallbacks); - return result; - } - - *ppBackend = pMP3; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file__mp3(void* pUserData, const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_mp3* pMP3; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pMP3 = (ma_mp3*)ma_malloc(sizeof(*pMP3), pAllocationCallbacks); - if (pMP3 == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_mp3_init_file(pFilePath, pConfig, pAllocationCallbacks, pMP3); - if (result != MA_SUCCESS) { - ma_free(pMP3, pAllocationCallbacks); - return result; - } - - *ppBackend = pMP3; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file_w__mp3(void* pUserData, const wchar_t* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_mp3* pMP3; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pMP3 = (ma_mp3*)ma_malloc(sizeof(*pMP3), pAllocationCallbacks); - if (pMP3 == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_mp3_init_file_w(pFilePath, pConfig, pAllocationCallbacks, pMP3); - if (result != MA_SUCCESS) { - ma_free(pMP3, pAllocationCallbacks); - return result; - } - - *ppBackend = pMP3; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_memory__mp3(void* pUserData, const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_mp3* pMP3; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pMP3 = (ma_mp3*)ma_malloc(sizeof(*pMP3), pAllocationCallbacks); - if (pMP3 == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_mp3_init_memory(pData, dataSize, pConfig, pAllocationCallbacks, pMP3); - if (result != MA_SUCCESS) { - ma_free(pMP3, pAllocationCallbacks); - return result; - } - - *ppBackend = pMP3; - - return MA_SUCCESS; -} - -static void ma_decoding_backend_uninit__mp3(void* pUserData, ma_data_source* pBackend, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_mp3* pMP3 = (ma_mp3*)pBackend; - - (void)pUserData; - - ma_mp3_uninit(pMP3, pAllocationCallbacks); - ma_free(pMP3, pAllocationCallbacks); -} - -static ma_decoding_backend_vtable g_ma_decoding_backend_vtable_mp3 = -{ - ma_decoding_backend_init__mp3, - ma_decoding_backend_init_file__mp3, - ma_decoding_backend_init_file_w__mp3, - ma_decoding_backend_init_memory__mp3, - ma_decoding_backend_uninit__mp3 -}; - -static ma_result ma_decoder_init_mp3__internal(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - return ma_decoder_init_from_vtable(&g_ma_decoding_backend_vtable_mp3, NULL, pConfig, pDecoder); -} -#endif /* dr_mp3_h */ - -/* Vorbis */ -#ifdef STB_VORBIS_INCLUDE_STB_VORBIS_H -#define MA_HAS_VORBIS - -/* The size in bytes of each chunk of data to read from the Vorbis stream. */ -#define MA_VORBIS_DATA_CHUNK_SIZE 4096 - -typedef struct -{ - ma_data_source_base ds; - ma_read_proc onRead; - ma_seek_proc onSeek; - ma_tell_proc onTell; - void* pReadSeekTellUserData; - ma_allocation_callbacks allocationCallbacks; /* Store the allocation callbacks within the structure because we may need to dynamically expand a buffer in ma_stbvorbis_read_pcm_frames() when using push mode. */ - ma_format format; /* Only f32 is allowed with stb_vorbis. */ - ma_uint32 channels; - ma_uint32 sampleRate; - ma_uint64 cursor; -#if !defined(MA_NO_VORBIS) - stb_vorbis* stb; - ma_bool32 usingPushMode; - struct - { - ma_uint8* pData; - size_t dataSize; - size_t dataCapacity; - size_t audioStartOffsetInBytes; - ma_uint32 framesConsumed; /* The number of frames consumed in ppPacketData. */ - ma_uint32 framesRemaining; /* The number of frames remaining in ppPacketData. */ - float** ppPacketData; - } push; -#endif -} ma_stbvorbis; - -MA_API ma_result ma_stbvorbis_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_stbvorbis* pVorbis); -MA_API ma_result ma_stbvorbis_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_stbvorbis* pVorbis); -MA_API ma_result ma_stbvorbis_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_stbvorbis* pVorbis); -MA_API void ma_stbvorbis_uninit(ma_stbvorbis* pVorbis, const ma_allocation_callbacks* pAllocationCallbacks); -MA_API ma_result ma_stbvorbis_read_pcm_frames(ma_stbvorbis* pVorbis, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead); -MA_API ma_result ma_stbvorbis_seek_to_pcm_frame(ma_stbvorbis* pVorbis, ma_uint64 frameIndex); -MA_API ma_result ma_stbvorbis_get_data_format(ma_stbvorbis* pVorbis, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap); -MA_API ma_result ma_stbvorbis_get_cursor_in_pcm_frames(ma_stbvorbis* pVorbis, ma_uint64* pCursor); -MA_API ma_result ma_stbvorbis_get_length_in_pcm_frames(ma_stbvorbis* pVorbis, ma_uint64* pLength); - - -static ma_result ma_stbvorbis_ds_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_stbvorbis_read_pcm_frames((ma_stbvorbis*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_stbvorbis_ds_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_stbvorbis_seek_to_pcm_frame((ma_stbvorbis*)pDataSource, frameIndex); -} - -static ma_result ma_stbvorbis_ds_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_stbvorbis_get_data_format((ma_stbvorbis*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_stbvorbis_ds_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_stbvorbis_get_cursor_in_pcm_frames((ma_stbvorbis*)pDataSource, pCursor); -} - -static ma_result ma_stbvorbis_ds_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_stbvorbis_get_length_in_pcm_frames((ma_stbvorbis*)pDataSource, pLength); -} - -static ma_data_source_vtable g_ma_stbvorbis_ds_vtable = -{ - ma_stbvorbis_ds_read, - ma_stbvorbis_ds_seek, - ma_stbvorbis_ds_get_data_format, - ma_stbvorbis_ds_get_cursor, - ma_stbvorbis_ds_get_length, - NULL, /* onSetLooping */ - 0 -}; - - -static ma_result ma_stbvorbis_init_internal(const ma_decoding_backend_config* pConfig, ma_stbvorbis* pVorbis) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - (void)pConfig; - - if (pVorbis == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pVorbis); - pVorbis->format = ma_format_f32; /* Only supporting f32. */ - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_stbvorbis_ds_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pVorbis->ds); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the base data source. */ - } - - return MA_SUCCESS; -} - -#if !defined(MA_NO_VORBIS) -static ma_result ma_stbvorbis_post_init(ma_stbvorbis* pVorbis) -{ - stb_vorbis_info info; - - MA_ASSERT(pVorbis != NULL); - - info = stb_vorbis_get_info(pVorbis->stb); - - pVorbis->channels = info.channels; - pVorbis->sampleRate = info.sample_rate; - - return MA_SUCCESS; -} - -static ma_result ma_stbvorbis_init_internal_decoder_push(ma_stbvorbis* pVorbis) -{ - ma_result result; - stb_vorbis* stb; - size_t dataSize = 0; - size_t dataCapacity = 0; - ma_uint8* pData = NULL; /* <-- Must be initialized to NULL. */ - - for (;;) { - int vorbisError; - int consumedDataSize; /* <-- Fill by stb_vorbis_open_pushdata(). */ - size_t bytesRead; - ma_uint8* pNewData; - - /* Allocate memory for the new chunk. */ - dataCapacity += MA_VORBIS_DATA_CHUNK_SIZE; - pNewData = (ma_uint8*)ma_realloc(pData, dataCapacity, &pVorbis->allocationCallbacks); - if (pNewData == NULL) { - ma_free(pData, &pVorbis->allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - pData = pNewData; - - /* Read in the next chunk. */ - result = pVorbis->onRead(pVorbis->pReadSeekTellUserData, ma_offset_ptr(pData, dataSize), (dataCapacity - dataSize), &bytesRead); - dataSize += bytesRead; - - if (result != MA_SUCCESS) { - ma_free(pData, &pVorbis->allocationCallbacks); - return result; - } - - /* We have a maximum of 31 bits with stb_vorbis. */ - if (dataSize > INT_MAX) { - ma_free(pData, &pVorbis->allocationCallbacks); - return MA_TOO_BIG; - } - - stb = stb_vorbis_open_pushdata(pData, (int)dataSize, &consumedDataSize, &vorbisError, NULL); - if (stb != NULL) { - /* - Successfully opened the Vorbis decoder. We might have some leftover unprocessed - data so we'll need to move that down to the front. - */ - dataSize -= (size_t)consumedDataSize; /* Consume the data. */ - MA_MOVE_MEMORY(pData, ma_offset_ptr(pData, consumedDataSize), dataSize); - - /* - We need to track the start point so we can seek back to the start of the audio - data when seeking. - */ - pVorbis->push.audioStartOffsetInBytes = consumedDataSize; - - break; - } else { - /* Failed to open the decoder. */ - if (vorbisError == VORBIS_need_more_data) { - continue; - } else { - ma_free(pData, &pVorbis->allocationCallbacks); - return MA_ERROR; /* Failed to open the stb_vorbis decoder. */ - } - } - } - - MA_ASSERT(stb != NULL); - pVorbis->stb = stb; - pVorbis->push.pData = pData; - pVorbis->push.dataSize = dataSize; - pVorbis->push.dataCapacity = dataCapacity; - - return MA_SUCCESS; -} -#endif - -MA_API ma_result ma_stbvorbis_init(ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_stbvorbis* pVorbis) -{ - ma_result result; - - result = ma_stbvorbis_init_internal(pConfig, pVorbis); - if (result != MA_SUCCESS) { - return result; - } - - if (onRead == NULL || onSeek == NULL) { - return MA_INVALID_ARGS; /* onRead and onSeek are mandatory. */ - } - - pVorbis->onRead = onRead; - pVorbis->onSeek = onSeek; - pVorbis->onTell = onTell; - pVorbis->pReadSeekTellUserData = pReadSeekTellUserData; - ma_allocation_callbacks_init_copy(&pVorbis->allocationCallbacks, pAllocationCallbacks); - - #if !defined(MA_NO_VORBIS) - { - /* - stb_vorbis lacks a callback based API for it's pulling API which means we're stuck with the - pushing API. In order for us to be able to successfully initialize the decoder we need to - supply it with enough data. We need to keep loading data until we have enough. - */ - result = ma_stbvorbis_init_internal_decoder_push(pVorbis); - if (result != MA_SUCCESS) { - return result; - } - - pVorbis->usingPushMode = MA_TRUE; - - result = ma_stbvorbis_post_init(pVorbis); - if (result != MA_SUCCESS) { - stb_vorbis_close(pVorbis->stb); - ma_free(pVorbis->push.pData, pAllocationCallbacks); - return result; - } - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. */ - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_stbvorbis_init_file(const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_stbvorbis* pVorbis) -{ - ma_result result; - - result = ma_stbvorbis_init_internal(pConfig, pVorbis); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_VORBIS) - { - (void)pAllocationCallbacks; /* Don't know how to make use of this with stb_vorbis. */ - - /* We can use stb_vorbis' pull mode for file based streams. */ - pVorbis->stb = stb_vorbis_open_filename(pFilePath, NULL, NULL); - if (pVorbis->stb == NULL) { - return MA_INVALID_FILE; - } - - pVorbis->usingPushMode = MA_FALSE; - - result = ma_stbvorbis_post_init(pVorbis); - if (result != MA_SUCCESS) { - stb_vorbis_close(pVorbis->stb); - return result; - } - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. */ - (void)pFilePath; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_stbvorbis_init_memory(const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_stbvorbis* pVorbis) -{ - ma_result result; - - result = ma_stbvorbis_init_internal(pConfig, pVorbis); - if (result != MA_SUCCESS) { - return result; - } - - #if !defined(MA_NO_VORBIS) - { - (void)pAllocationCallbacks; - - /* stb_vorbis uses an int as it's size specifier, restricting it to 32-bit even on 64-bit systems. *sigh*. */ - if (dataSize > INT_MAX) { - return MA_TOO_BIG; - } - - pVorbis->stb = stb_vorbis_open_memory((const unsigned char*)pData, (int)dataSize, NULL, NULL); - if (pVorbis->stb == NULL) { - return MA_INVALID_FILE; - } - - pVorbis->usingPushMode = MA_FALSE; - - result = ma_stbvorbis_post_init(pVorbis); - if (result != MA_SUCCESS) { - stb_vorbis_close(pVorbis->stb); - return result; - } - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. */ - (void)pData; - (void)dataSize; - (void)pAllocationCallbacks; - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API void ma_stbvorbis_uninit(ma_stbvorbis* pVorbis, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pVorbis == NULL) { - return; - } - - #if !defined(MA_NO_VORBIS) - { - stb_vorbis_close(pVorbis->stb); - - /* We'll have to clear some memory if we're using push mode. */ - if (pVorbis->usingPushMode) { - ma_free(pVorbis->push.pData, pAllocationCallbacks); - } - } - #else - { - /* vorbis is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - } - #endif - - ma_data_source_uninit(&pVorbis->ds); -} - -MA_API ma_result ma_stbvorbis_read_pcm_frames(ma_stbvorbis* pVorbis, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pVorbis == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_VORBIS) - { - /* We always use floating point format. */ - ma_result result = MA_SUCCESS; /* Must be initialized to MA_SUCCESS. */ - ma_uint64 totalFramesRead = 0; - ma_format format; - ma_uint32 channels; - - ma_stbvorbis_get_data_format(pVorbis, &format, &channels, NULL, NULL, 0); - - if (format == ma_format_f32) { - /* We read differently depending on whether or not we're using push mode. */ - if (pVorbis->usingPushMode) { - /* Push mode. This is the complex case. */ - float* pFramesOutF32 = (float*)pFramesOut; - - while (totalFramesRead < frameCount) { - /* The first thing to do is read from any already-cached frames. */ - ma_uint32 framesToReadFromCache = (ma_uint32)ma_min(pVorbis->push.framesRemaining, (frameCount - totalFramesRead)); /* Safe cast because pVorbis->framesRemaining is 32-bit. */ - - /* The output pointer can be null in which case we just treate it as a seek. */ - if (pFramesOut != NULL) { - ma_uint64 iFrame; - for (iFrame = 0; iFrame < framesToReadFromCache; iFrame += 1) { - ma_uint32 iChannel; - for (iChannel = 0; iChannel < pVorbis->channels; iChannel += 1) { - pFramesOutF32[iChannel] = pVorbis->push.ppPacketData[iChannel][pVorbis->push.framesConsumed + iFrame]; - } - - pFramesOutF32 += pVorbis->channels; - } - } - - /* Update pointers and counters. */ - pVorbis->push.framesConsumed += framesToReadFromCache; - pVorbis->push.framesRemaining -= framesToReadFromCache; - totalFramesRead += framesToReadFromCache; - - /* Don't bother reading any more frames right now if we've just finished loading. */ - if (totalFramesRead == frameCount) { - break; - } - - MA_ASSERT(pVorbis->push.framesRemaining == 0); - - /* Getting here means we've run out of cached frames. We'll need to load some more. */ - for (;;) { - int samplesRead = 0; - int consumedDataSize; - - /* We need to case dataSize to an int, so make sure we can do it safely. */ - if (pVorbis->push.dataSize > INT_MAX) { - break; /* Too big. */ - } - - consumedDataSize = stb_vorbis_decode_frame_pushdata(pVorbis->stb, pVorbis->push.pData, (int)pVorbis->push.dataSize, NULL, &pVorbis->push.ppPacketData, &samplesRead); - if (consumedDataSize != 0) { - /* Successfully decoded a Vorbis frame. Consume the data. */ - pVorbis->push.dataSize -= (size_t)consumedDataSize; - MA_MOVE_MEMORY(pVorbis->push.pData, ma_offset_ptr(pVorbis->push.pData, consumedDataSize), pVorbis->push.dataSize); - - pVorbis->push.framesConsumed = 0; - pVorbis->push.framesRemaining = samplesRead; - - break; - } else { - /* Not enough data. Read more. */ - size_t bytesRead; - - /* Expand the data buffer if necessary. */ - if (pVorbis->push.dataCapacity == pVorbis->push.dataSize) { - size_t newCap = pVorbis->push.dataCapacity + MA_VORBIS_DATA_CHUNK_SIZE; - ma_uint8* pNewData; - - pNewData = (ma_uint8*)ma_realloc(pVorbis->push.pData, newCap, &pVorbis->allocationCallbacks); - if (pNewData == NULL) { - result = MA_OUT_OF_MEMORY; - break; - } - - pVorbis->push.pData = pNewData; - pVorbis->push.dataCapacity = newCap; - } - - /* We should have enough room to load some data. */ - result = pVorbis->onRead(pVorbis->pReadSeekTellUserData, ma_offset_ptr(pVorbis->push.pData, pVorbis->push.dataSize), (pVorbis->push.dataCapacity - pVorbis->push.dataSize), &bytesRead); - pVorbis->push.dataSize += bytesRead; - - if (result != MA_SUCCESS) { - break; /* Failed to read any data. Get out. */ - } - } - } - - /* If we don't have a success code at this point it means we've encounted an error or the end of the file has been reached (probably the latter). */ - if (result != MA_SUCCESS) { - break; - } - } - } else { - /* Pull mode. This is the simple case, but we still need to run in a loop because stb_vorbis loves using 32-bit instead of 64-bit. */ - while (totalFramesRead < frameCount) { - ma_uint64 framesRemaining = (frameCount - totalFramesRead); - int framesRead; - - if (framesRemaining > INT_MAX) { - framesRemaining = INT_MAX; - } - - framesRead = stb_vorbis_get_samples_float_interleaved(pVorbis->stb, channels, (float*)ma_offset_pcm_frames_ptr(pFramesOut, totalFramesRead, format, channels), (int)framesRemaining * channels); /* Safe cast. */ - totalFramesRead += framesRead; - - if (framesRead < (int)framesRemaining) { - break; /* Nothing left to read. Get out. */ - } - } - } - } else { - result = MA_INVALID_ARGS; - } - - pVorbis->cursor += totalFramesRead; - - if (totalFramesRead == 0) { - result = MA_AT_END; - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - if (result == MA_SUCCESS && totalFramesRead == 0) { - result = MA_AT_END; - } - - return result; - } - #else - { - /* vorbis is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)pFramesOut; - (void)frameCount; - (void)pFramesRead; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_stbvorbis_seek_to_pcm_frame(ma_stbvorbis* pVorbis, ma_uint64 frameIndex) -{ - if (pVorbis == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_VORBIS) - { - /* Different seeking methods depending on whether or not we're using push mode. */ - if (pVorbis->usingPushMode) { - /* Push mode. This is the complex case. */ - ma_result result; - float buffer[4096]; - - /* If we're seeking backwards, we need to seek back to the start and then brute-force forward. */ - if (frameIndex < pVorbis->cursor) { - if (frameIndex > 0x7FFFFFFF) { - return MA_INVALID_ARGS; /* Trying to seek beyond the 32-bit maximum of stb_vorbis. */ - } - - /* - This is wildly inefficient due to me having trouble getting sample exact seeking working - robustly with stb_vorbis_flush_pushdata(). The only way I can think to make this work - perfectly is to reinitialize the decoder. Note that we only enter this path when seeking - backwards. This will hopefully be removed once we get our own Vorbis decoder implemented. - */ - stb_vorbis_close(pVorbis->stb); - ma_free(pVorbis->push.pData, &pVorbis->allocationCallbacks); - - MA_ZERO_OBJECT(&pVorbis->push); - - /* Seek to the start of the file. */ - result = pVorbis->onSeek(pVorbis->pReadSeekTellUserData, 0, ma_seek_origin_start); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_stbvorbis_init_internal_decoder_push(pVorbis); - if (result != MA_SUCCESS) { - return result; - } - - /* At this point we should be sitting on the first frame. */ - pVorbis->cursor = 0; - } - - /* We're just brute-forcing this for now. */ - while (pVorbis->cursor < frameIndex) { - ma_uint64 framesRead; - ma_uint64 framesToRead = ma_countof(buffer)/pVorbis->channels; - if (framesToRead > (frameIndex - pVorbis->cursor)) { - framesToRead = (frameIndex - pVorbis->cursor); - } - - result = ma_stbvorbis_read_pcm_frames(pVorbis, buffer, framesToRead, &framesRead); - pVorbis->cursor += framesRead; - - if (result != MA_SUCCESS) { - return result; - } - } - } else { - /* Pull mode. This is the simple case. */ - int vorbisResult; - - if (frameIndex > UINT_MAX) { - return MA_INVALID_ARGS; /* Trying to seek beyond the 32-bit maximum of stb_vorbis. */ - } - - vorbisResult = stb_vorbis_seek(pVorbis->stb, (unsigned int)frameIndex); /* Safe cast. */ - if (vorbisResult == 0) { - return MA_ERROR; /* See failed. */ - } - - pVorbis->cursor = frameIndex; - } - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - - (void)frameIndex; - - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_stbvorbis_get_data_format(ma_stbvorbis* pVorbis, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - /* Defaults for safety. */ - if (pFormat != NULL) { - *pFormat = ma_format_unknown; - } - if (pChannels != NULL) { - *pChannels = 0; - } - if (pSampleRate != NULL) { - *pSampleRate = 0; - } - if (pChannelMap != NULL) { - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channelMapCap); - } - - if (pVorbis == NULL) { - return MA_INVALID_OPERATION; - } - - if (pFormat != NULL) { - *pFormat = pVorbis->format; - } - - #if !defined(MA_NO_VORBIS) - { - if (pChannels != NULL) { - *pChannels = pVorbis->channels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pVorbis->sampleRate; - } - - if (pChannelMap != NULL) { - ma_channel_map_init_standard(ma_standard_channel_map_vorbis, pChannelMap, channelMapCap, pVorbis->channels); - } - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_stbvorbis_get_cursor_in_pcm_frames(ma_stbvorbis* pVorbis, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; /* Safety. */ - - if (pVorbis == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_VORBIS) - { - *pCursor = pVorbis->cursor; - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - -MA_API ma_result ma_stbvorbis_get_length_in_pcm_frames(ma_stbvorbis* pVorbis, ma_uint64* pLength) -{ - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; /* Safety. */ - - if (pVorbis == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_VORBIS) - { - if (pVorbis->usingPushMode) { - *pLength = 0; /* I don't know of a good way to determine this reliably with stb_vorbis and push mode. */ - } else { - *pLength = stb_vorbis_stream_length_in_samples(pVorbis->stb); - } - - return MA_SUCCESS; - } - #else - { - /* vorbis is disabled. Should never hit this since initialization would have failed. */ - MA_ASSERT(MA_FALSE); - return MA_NOT_IMPLEMENTED; - } - #endif -} - - -static ma_result ma_decoding_backend_init__stbvorbis(void* pUserData, ma_read_proc onRead, ma_seek_proc onSeek, ma_tell_proc onTell, void* pReadSeekTellUserData, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_stbvorbis* pVorbis; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pVorbis = (ma_stbvorbis*)ma_malloc(sizeof(*pVorbis), pAllocationCallbacks); - if (pVorbis == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_stbvorbis_init(onRead, onSeek, onTell, pReadSeekTellUserData, pConfig, pAllocationCallbacks, pVorbis); - if (result != MA_SUCCESS) { - ma_free(pVorbis, pAllocationCallbacks); - return result; - } - - *ppBackend = pVorbis; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_file__stbvorbis(void* pUserData, const char* pFilePath, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_stbvorbis* pVorbis; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pVorbis = (ma_stbvorbis*)ma_malloc(sizeof(*pVorbis), pAllocationCallbacks); - if (pVorbis == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_stbvorbis_init_file(pFilePath, pConfig, pAllocationCallbacks, pVorbis); - if (result != MA_SUCCESS) { - ma_free(pVorbis, pAllocationCallbacks); - return result; - } - - *ppBackend = pVorbis; - - return MA_SUCCESS; -} - -static ma_result ma_decoding_backend_init_memory__stbvorbis(void* pUserData, const void* pData, size_t dataSize, const ma_decoding_backend_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source** ppBackend) -{ - ma_result result; - ma_stbvorbis* pVorbis; - - (void)pUserData; /* For now not using pUserData, but once we start storing the vorbis decoder state within the ma_decoder structure this will be set to the decoder so we can avoid a malloc. */ - - /* For now we're just allocating the decoder backend on the heap. */ - pVorbis = (ma_stbvorbis*)ma_malloc(sizeof(*pVorbis), pAllocationCallbacks); - if (pVorbis == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_stbvorbis_init_memory(pData, dataSize, pConfig, pAllocationCallbacks, pVorbis); - if (result != MA_SUCCESS) { - ma_free(pVorbis, pAllocationCallbacks); - return result; - } - - *ppBackend = pVorbis; - - return MA_SUCCESS; -} - -static void ma_decoding_backend_uninit__stbvorbis(void* pUserData, ma_data_source* pBackend, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_stbvorbis* pVorbis = (ma_stbvorbis*)pBackend; - - (void)pUserData; - - ma_stbvorbis_uninit(pVorbis, pAllocationCallbacks); - ma_free(pVorbis, pAllocationCallbacks); -} - -static ma_decoding_backend_vtable g_ma_decoding_backend_vtable_stbvorbis = -{ - ma_decoding_backend_init__stbvorbis, - ma_decoding_backend_init_file__stbvorbis, - NULL, /* onInitFileW() */ - ma_decoding_backend_init_memory__stbvorbis, - ma_decoding_backend_uninit__stbvorbis -}; - -static ma_result ma_decoder_init_vorbis__internal(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - return ma_decoder_init_from_vtable(&g_ma_decoding_backend_vtable_stbvorbis, NULL, pConfig, pDecoder); -} -#endif /* STB_VORBIS_INCLUDE_STB_VORBIS_H */ - - - -static ma_result ma_decoder__init_allocation_callbacks(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - MA_ASSERT(pDecoder != NULL); - - if (pConfig != NULL) { - return ma_allocation_callbacks_init_copy(&pDecoder->allocationCallbacks, &pConfig->allocationCallbacks); - } else { - pDecoder->allocationCallbacks = ma_allocation_callbacks_init_default(); - return MA_SUCCESS; - } -} - -static ma_result ma_decoder__data_source_on_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_decoder_read_pcm_frames((ma_decoder*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_decoder__data_source_on_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_decoder_seek_to_pcm_frame((ma_decoder*)pDataSource, frameIndex); -} - -static ma_result ma_decoder__data_source_on_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_decoder_get_data_format((ma_decoder*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_decoder__data_source_on_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_decoder_get_cursor_in_pcm_frames((ma_decoder*)pDataSource, pCursor); -} - -static ma_result ma_decoder__data_source_on_get_length(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_decoder_get_length_in_pcm_frames((ma_decoder*)pDataSource, pLength); -} - -static ma_data_source_vtable g_ma_decoder_data_source_vtable = -{ - ma_decoder__data_source_on_read, - ma_decoder__data_source_on_seek, - ma_decoder__data_source_on_get_data_format, - ma_decoder__data_source_on_get_cursor, - ma_decoder__data_source_on_get_length, - NULL, /* onSetLooping */ - 0 -}; - -static ma_result ma_decoder__preinit(ma_decoder_read_proc onRead, ma_decoder_seek_proc onSeek, ma_decoder_tell_proc onTell, void* pUserData, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - MA_ASSERT(pConfig != NULL); - - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDecoder); - - if (onRead == NULL || onSeek == NULL) { - return MA_INVALID_ARGS; - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_decoder_data_source_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pDecoder->ds); - if (result != MA_SUCCESS) { - return result; - } - - pDecoder->onRead = onRead; - pDecoder->onSeek = onSeek; - pDecoder->onTell = onTell; - pDecoder->pUserData = pUserData; - - result = ma_decoder__init_allocation_callbacks(pConfig, pDecoder); - if (result != MA_SUCCESS) { - ma_data_source_uninit(&pDecoder->ds); - return result; - } - - return MA_SUCCESS; -} - -static ma_result ma_decoder__postinit(const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - - result = ma_decoder__init_data_converter(pDecoder, pConfig); - - /* If we failed post initialization we need to uninitialize the decoder before returning to prevent a memory leak. */ - if (result != MA_SUCCESS) { - ma_decoder_uninit(pDecoder); - return result; - } - - return result; -} - - -static ma_result ma_decoder_init__internal(ma_decoder_read_proc onRead, ma_decoder_seek_proc onSeek, void* pUserData, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result = MA_NO_BACKEND; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pDecoder != NULL); - - /* Silence some warnings in the case that we don't have any decoder backends enabled. */ - (void)onRead; - (void)onSeek; - (void)pUserData; - - - /* If we've specified a specific encoding type, try that first. */ - if (pConfig->encodingFormat != ma_encoding_format_unknown) { - #ifdef MA_HAS_WAV - if (pConfig->encodingFormat == ma_encoding_format_wav) { - result = ma_decoder_init_wav__internal(pConfig, pDecoder); - } - #endif - #ifdef MA_HAS_FLAC - if (pConfig->encodingFormat == ma_encoding_format_flac) { - result = ma_decoder_init_flac__internal(pConfig, pDecoder); - } - #endif - #ifdef MA_HAS_MP3 - if (pConfig->encodingFormat == ma_encoding_format_mp3) { - result = ma_decoder_init_mp3__internal(pConfig, pDecoder); - } - #endif - #ifdef MA_HAS_VORBIS - if (pConfig->encodingFormat == ma_encoding_format_vorbis) { - result = ma_decoder_init_vorbis__internal(pConfig, pDecoder); - } - #endif - - /* If we weren't able to initialize the decoder, seek back to the start to give the next attempts a clean start. */ - if (result != MA_SUCCESS) { - onSeek(pDecoder, 0, ma_seek_origin_start); - } - } - - if (result != MA_SUCCESS) { - /* Getting here means we couldn't load a specific decoding backend based on the encoding format. */ - - /* - We use trial and error to open a decoder. We prioritize custom decoders so that if they - implement the same encoding format they take priority over the built-in decoders. - */ - if (result != MA_SUCCESS) { - result = ma_decoder_init_custom__internal(pConfig, pDecoder); - if (result != MA_SUCCESS) { - onSeek(pDecoder, 0, ma_seek_origin_start); - } - } - - /* - If we get to this point and we still haven't found a decoder, and the caller has requested a - specific encoding format, there's no hope for it. Abort. - */ - if (pConfig->encodingFormat != ma_encoding_format_unknown) { - return MA_NO_BACKEND; - } - - #ifdef MA_HAS_WAV - if (result != MA_SUCCESS) { - result = ma_decoder_init_wav__internal(pConfig, pDecoder); - if (result != MA_SUCCESS) { - onSeek(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_FLAC - if (result != MA_SUCCESS) { - result = ma_decoder_init_flac__internal(pConfig, pDecoder); - if (result != MA_SUCCESS) { - onSeek(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_MP3 - if (result != MA_SUCCESS) { - result = ma_decoder_init_mp3__internal(pConfig, pDecoder); - if (result != MA_SUCCESS) { - onSeek(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_VORBIS - if (result != MA_SUCCESS) { - result = ma_decoder_init_vorbis__internal(pConfig, pDecoder); - if (result != MA_SUCCESS) { - onSeek(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - } - - if (result != MA_SUCCESS) { - return result; - } - - return ma_decoder__postinit(pConfig, pDecoder); -} - -MA_API ma_result ma_decoder_init(ma_decoder_read_proc onRead, ma_decoder_seek_proc onSeek, void* pUserData, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_decoder_config config; - ma_result result; - - config = ma_decoder_config_init_copy(pConfig); - - result = ma_decoder__preinit(onRead, onSeek, NULL, pUserData, &config, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - return ma_decoder_init__internal(onRead, onSeek, pUserData, &config, pDecoder); -} - - -static ma_result ma_decoder__on_read_memory(ma_decoder* pDecoder, void* pBufferOut, size_t bytesToRead, size_t* pBytesRead) -{ - size_t bytesRemaining; - - MA_ASSERT(pDecoder->data.memory.dataSize >= pDecoder->data.memory.currentReadPos); - - if (pBytesRead != NULL) { - *pBytesRead = 0; - } - - bytesRemaining = pDecoder->data.memory.dataSize - pDecoder->data.memory.currentReadPos; - if (bytesToRead > bytesRemaining) { - bytesToRead = bytesRemaining; - } - - if (bytesRemaining == 0) { - return MA_AT_END; - } - - if (bytesToRead > 0) { - MA_COPY_MEMORY(pBufferOut, pDecoder->data.memory.pData + pDecoder->data.memory.currentReadPos, bytesToRead); - pDecoder->data.memory.currentReadPos += bytesToRead; - } - - if (pBytesRead != NULL) { - *pBytesRead = bytesToRead; - } - - return MA_SUCCESS; -} - -static ma_result ma_decoder__on_seek_memory(ma_decoder* pDecoder, ma_int64 byteOffset, ma_seek_origin origin) -{ - if (byteOffset > 0 && (ma_uint64)byteOffset > MA_SIZE_MAX) { - return MA_BAD_SEEK; - } - - if (origin == ma_seek_origin_current) { - if (byteOffset > 0) { - if (pDecoder->data.memory.currentReadPos + byteOffset > pDecoder->data.memory.dataSize) { - byteOffset = (ma_int64)(pDecoder->data.memory.dataSize - pDecoder->data.memory.currentReadPos); /* Trying to seek too far forward. */ - } - - pDecoder->data.memory.currentReadPos += (size_t)byteOffset; - } else { - if (pDecoder->data.memory.currentReadPos < (size_t)-byteOffset) { - byteOffset = -(ma_int64)pDecoder->data.memory.currentReadPos; /* Trying to seek too far backwards. */ - } - - pDecoder->data.memory.currentReadPos -= (size_t)-byteOffset; - } - } else { - if (origin == ma_seek_origin_end) { - if (byteOffset < 0) { - byteOffset = -byteOffset; - } - - if (byteOffset > (ma_int64)pDecoder->data.memory.dataSize) { - pDecoder->data.memory.currentReadPos = 0; /* Trying to seek too far back. */ - } else { - pDecoder->data.memory.currentReadPos = pDecoder->data.memory.dataSize - (size_t)byteOffset; - } - } else { - if ((size_t)byteOffset <= pDecoder->data.memory.dataSize) { - pDecoder->data.memory.currentReadPos = (size_t)byteOffset; - } else { - pDecoder->data.memory.currentReadPos = pDecoder->data.memory.dataSize; /* Trying to seek too far forward. */ - } - } - } - - return MA_SUCCESS; -} - -static ma_result ma_decoder__on_tell_memory(ma_decoder* pDecoder, ma_int64* pCursor) -{ - MA_ASSERT(pDecoder != NULL); - MA_ASSERT(pCursor != NULL); - - *pCursor = (ma_int64)pDecoder->data.memory.currentReadPos; - - return MA_SUCCESS; -} - -static ma_result ma_decoder__preinit_memory(const void* pData, size_t dataSize, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result = ma_decoder__preinit(ma_decoder__on_read_memory, ma_decoder__on_seek_memory, ma_decoder__on_tell_memory, NULL, pConfig, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - if (pData == NULL || dataSize == 0) { - return MA_INVALID_ARGS; - } - - pDecoder->data.memory.pData = (const ma_uint8*)pData; - pDecoder->data.memory.dataSize = dataSize; - pDecoder->data.memory.currentReadPos = 0; - - (void)pConfig; - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_init_memory(const void* pData, size_t dataSize, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_decoder_config config; - ma_result result; - - config = ma_decoder_config_init_copy(pConfig); /* Make sure the config is not NULL. */ - - result = ma_decoder__preinit_memory(pData, dataSize, &config, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - return ma_decoder_init__internal(ma_decoder__on_read_memory, ma_decoder__on_seek_memory, NULL, &config, pDecoder); -} - - -#if defined(MA_HAS_WAV) || \ - defined(MA_HAS_MP3) || \ - defined(MA_HAS_FLAC) || \ - defined(MA_HAS_VORBIS) || \ - defined(MA_HAS_OPUS) -#define MA_HAS_PATH_API -#endif - -#if defined(MA_HAS_PATH_API) -static const char* ma_path_file_name(const char* path) -{ - const char* fileName; - - if (path == NULL) { - return NULL; - } - - fileName = path; - - /* We just loop through the path until we find the last slash. */ - while (path[0] != '\0') { - if (path[0] == '/' || path[0] == '\\') { - fileName = path; - } - - path += 1; - } - - /* At this point the file name is sitting on a slash, so just move forward. */ - while (fileName[0] != '\0' && (fileName[0] == '/' || fileName[0] == '\\')) { - fileName += 1; - } - - return fileName; -} - -static const wchar_t* ma_path_file_name_w(const wchar_t* path) -{ - const wchar_t* fileName; - - if (path == NULL) { - return NULL; - } - - fileName = path; - - /* We just loop through the path until we find the last slash. */ - while (path[0] != '\0') { - if (path[0] == '/' || path[0] == '\\') { - fileName = path; - } - - path += 1; - } - - /* At this point the file name is sitting on a slash, so just move forward. */ - while (fileName[0] != '\0' && (fileName[0] == '/' || fileName[0] == '\\')) { - fileName += 1; - } - - return fileName; -} - - -static const char* ma_path_extension(const char* path) -{ - const char* extension; - const char* lastOccurance; - - if (path == NULL) { - path = ""; - } - - extension = ma_path_file_name(path); - lastOccurance = NULL; - - /* Just find the last '.' and return. */ - while (extension[0] != '\0') { - if (extension[0] == '.') { - extension += 1; - lastOccurance = extension; - } - - extension += 1; - } - - return (lastOccurance != NULL) ? lastOccurance : extension; -} - -static const wchar_t* ma_path_extension_w(const wchar_t* path) -{ - const wchar_t* extension; - const wchar_t* lastOccurance; - - if (path == NULL) { - path = L""; - } - - extension = ma_path_file_name_w(path); - lastOccurance = NULL; - - /* Just find the last '.' and return. */ - while (extension[0] != '\0') { - if (extension[0] == '.') { - extension += 1; - lastOccurance = extension; - } - - extension += 1; - } - - return (lastOccurance != NULL) ? lastOccurance : extension; -} - - -static ma_bool32 ma_path_extension_equal(const char* path, const char* extension) -{ - const char* ext1; - const char* ext2; - - if (path == NULL || extension == NULL) { - return MA_FALSE; - } - - ext1 = extension; - ext2 = ma_path_extension(path); - -#if defined(_MSC_VER) || defined(__DMC__) - return _stricmp(ext1, ext2) == 0; -#else - return strcasecmp(ext1, ext2) == 0; -#endif -} - -static ma_bool32 ma_path_extension_equal_w(const wchar_t* path, const wchar_t* extension) -{ - const wchar_t* ext1; - const wchar_t* ext2; - - if (path == NULL || extension == NULL) { - return MA_FALSE; - } - - ext1 = extension; - ext2 = ma_path_extension_w(path); - -#if defined(_MSC_VER) || defined(__WATCOMC__) || defined(__DMC__) - return _wcsicmp(ext1, ext2) == 0; -#else - /* - I'm not aware of a wide character version of strcasecmp(). I'm therefore converting the extensions to multibyte strings and comparing those. This - isn't the most efficient way to do it, but it should work OK. - */ - { - char ext1MB[4096]; - char ext2MB[4096]; - const wchar_t* pext1 = ext1; - const wchar_t* pext2 = ext2; - mbstate_t mbs1; - mbstate_t mbs2; - - MA_ZERO_OBJECT(&mbs1); - MA_ZERO_OBJECT(&mbs2); - - if (wcsrtombs(ext1MB, &pext1, sizeof(ext1MB), &mbs1) == (size_t)-1) { - return MA_FALSE; - } - if (wcsrtombs(ext2MB, &pext2, sizeof(ext2MB), &mbs2) == (size_t)-1) { - return MA_FALSE; - } - - return strcasecmp(ext1MB, ext2MB) == 0; - } -#endif -} -#endif /* MA_HAS_PATH_API */ - - - -static ma_result ma_decoder__on_read_vfs(ma_decoder* pDecoder, void* pBufferOut, size_t bytesToRead, size_t* pBytesRead) -{ - MA_ASSERT(pDecoder != NULL); - MA_ASSERT(pBufferOut != NULL); - - return ma_vfs_or_default_read(pDecoder->data.vfs.pVFS, pDecoder->data.vfs.file, pBufferOut, bytesToRead, pBytesRead); -} - -static ma_result ma_decoder__on_seek_vfs(ma_decoder* pDecoder, ma_int64 offset, ma_seek_origin origin) -{ - MA_ASSERT(pDecoder != NULL); - - return ma_vfs_or_default_seek(pDecoder->data.vfs.pVFS, pDecoder->data.vfs.file, offset, origin); -} - -static ma_result ma_decoder__on_tell_vfs(ma_decoder* pDecoder, ma_int64* pCursor) -{ - MA_ASSERT(pDecoder != NULL); - - return ma_vfs_or_default_tell(pDecoder->data.vfs.pVFS, pDecoder->data.vfs.file, pCursor); -} - -static ma_result ma_decoder__preinit_vfs(ma_vfs* pVFS, const char* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - ma_vfs_file file; - - result = ma_decoder__preinit(ma_decoder__on_read_vfs, ma_decoder__on_seek_vfs, ma_decoder__on_tell_vfs, NULL, pConfig, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - if (pFilePath == NULL || pFilePath[0] == '\0') { - return MA_INVALID_ARGS; - } - - result = ma_vfs_or_default_open(pVFS, pFilePath, MA_OPEN_MODE_READ, &file); - if (result != MA_SUCCESS) { - return result; - } - - pDecoder->data.vfs.pVFS = pVFS; - pDecoder->data.vfs.file = file; - - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_init_vfs(ma_vfs* pVFS, const char* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - ma_decoder_config config; - - config = ma_decoder_config_init_copy(pConfig); - result = ma_decoder__preinit_vfs(pVFS, pFilePath, &config, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - result = MA_NO_BACKEND; - - if (config.encodingFormat != ma_encoding_format_unknown) { - #ifdef MA_HAS_WAV - if (config.encodingFormat == ma_encoding_format_wav) { - result = ma_decoder_init_wav__internal(&config, pDecoder); - } - #endif - #ifdef MA_HAS_FLAC - if (config.encodingFormat == ma_encoding_format_flac) { - result = ma_decoder_init_flac__internal(&config, pDecoder); - } - #endif - #ifdef MA_HAS_MP3 - if (config.encodingFormat == ma_encoding_format_mp3) { - result = ma_decoder_init_mp3__internal(&config, pDecoder); - } - #endif - #ifdef MA_HAS_VORBIS - if (config.encodingFormat == ma_encoding_format_vorbis) { - result = ma_decoder_init_vorbis__internal(&config, pDecoder); - } - #endif - - /* Make sure we seek back to the start if we didn't initialize a decoder successfully so the next attempts have a fresh start. */ - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - - if (result != MA_SUCCESS) { - /* Getting here means we weren't able to initialize a decoder of a specific encoding format. */ - - /* - We use trial and error to open a decoder. We prioritize custom decoders so that if they - implement the same encoding format they take priority over the built-in decoders. - */ - if (result != MA_SUCCESS) { - result = ma_decoder_init_custom__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - - /* - If we get to this point and we still haven't found a decoder, and the caller has requested a - specific encoding format, there's no hope for it. Abort. - */ - if (config.encodingFormat != ma_encoding_format_unknown) { - return MA_NO_BACKEND; - } - - #ifdef MA_HAS_WAV - if (result != MA_SUCCESS && ma_path_extension_equal(pFilePath, "wav")) { - result = ma_decoder_init_wav__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_FLAC - if (result != MA_SUCCESS && ma_path_extension_equal(pFilePath, "flac")) { - result = ma_decoder_init_flac__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_MP3 - if (result != MA_SUCCESS && ma_path_extension_equal(pFilePath, "mp3")) { - result = ma_decoder_init_mp3__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - } - - /* If we still haven't got a result just use trial and error. Otherwise we can finish up. */ - if (result != MA_SUCCESS) { - result = ma_decoder_init__internal(ma_decoder__on_read_vfs, ma_decoder__on_seek_vfs, NULL, &config, pDecoder); - } else { - result = ma_decoder__postinit(&config, pDecoder); - } - - if (result != MA_SUCCESS) { - if (pDecoder->data.vfs.file != NULL) { /* <-- Will be reset to NULL if ma_decoder_uninit() is called in one of the steps above which allows us to avoid a double close of the file. */ - ma_vfs_or_default_close(pVFS, pDecoder->data.vfs.file); - } - - return result; - } - - return MA_SUCCESS; -} - - -static ma_result ma_decoder__preinit_vfs_w(ma_vfs* pVFS, const wchar_t* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - ma_vfs_file file; - - result = ma_decoder__preinit(ma_decoder__on_read_vfs, ma_decoder__on_seek_vfs, ma_decoder__on_tell_vfs, NULL, pConfig, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - if (pFilePath == NULL || pFilePath[0] == '\0') { - return MA_INVALID_ARGS; - } - - result = ma_vfs_or_default_open_w(pVFS, pFilePath, MA_OPEN_MODE_READ, &file); - if (result != MA_SUCCESS) { - return result; - } - - pDecoder->data.vfs.pVFS = pVFS; - pDecoder->data.vfs.file = file; - - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_init_vfs_w(ma_vfs* pVFS, const wchar_t* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - ma_result result; - ma_decoder_config config; - - config = ma_decoder_config_init_copy(pConfig); - result = ma_decoder__preinit_vfs_w(pVFS, pFilePath, &config, pDecoder); - if (result != MA_SUCCESS) { - return result; - } - - result = MA_NO_BACKEND; - - if (config.encodingFormat != ma_encoding_format_unknown) { - #ifdef MA_HAS_WAV - if (config.encodingFormat == ma_encoding_format_wav) { - result = ma_decoder_init_wav__internal(&config, pDecoder); - } - #endif - #ifdef MA_HAS_FLAC - if (config.encodingFormat == ma_encoding_format_flac) { - result = ma_decoder_init_flac__internal(&config, pDecoder); - } - #endif - #ifdef MA_HAS_MP3 - if (config.encodingFormat == ma_encoding_format_mp3) { - result = ma_decoder_init_mp3__internal(&config, pDecoder); - } - #endif - #ifdef MA_HAS_VORBIS - if (config.encodingFormat == ma_encoding_format_vorbis) { - result = ma_decoder_init_vorbis__internal(&config, pDecoder); - } - #endif - - /* Make sure we seek back to the start if we didn't initialize a decoder successfully so the next attempts have a fresh start. */ - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - - if (result != MA_SUCCESS) { - /* Getting here means we weren't able to initialize a decoder of a specific encoding format. */ - - /* - We use trial and error to open a decoder. We prioritize custom decoders so that if they - implement the same encoding format they take priority over the built-in decoders. - */ - if (result != MA_SUCCESS) { - result = ma_decoder_init_custom__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - - /* - If we get to this point and we still haven't found a decoder, and the caller has requested a - specific encoding format, there's no hope for it. Abort. - */ - if (config.encodingFormat != ma_encoding_format_unknown) { - return MA_NO_BACKEND; - } - - #ifdef MA_HAS_WAV - if (result != MA_SUCCESS && ma_path_extension_equal_w(pFilePath, L"wav")) { - result = ma_decoder_init_wav__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_FLAC - if (result != MA_SUCCESS && ma_path_extension_equal_w(pFilePath, L"flac")) { - result = ma_decoder_init_flac__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - #ifdef MA_HAS_MP3 - if (result != MA_SUCCESS && ma_path_extension_equal_w(pFilePath, L"mp3")) { - result = ma_decoder_init_mp3__internal(&config, pDecoder); - if (result != MA_SUCCESS) { - ma_decoder__on_seek_vfs(pDecoder, 0, ma_seek_origin_start); - } - } - #endif - } - - /* If we still haven't got a result just use trial and error. Otherwise we can finish up. */ - if (result != MA_SUCCESS) { - result = ma_decoder_init__internal(ma_decoder__on_read_vfs, ma_decoder__on_seek_vfs, NULL, &config, pDecoder); - } else { - result = ma_decoder__postinit(&config, pDecoder); - } - - if (result != MA_SUCCESS) { - ma_vfs_or_default_close(pVFS, pDecoder->data.vfs.file); - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_init_file(const char* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - return ma_decoder_init_vfs(NULL, pFilePath, pConfig, pDecoder); -} - -MA_API ma_result ma_decoder_init_file_w(const wchar_t* pFilePath, const ma_decoder_config* pConfig, ma_decoder* pDecoder) -{ - return ma_decoder_init_vfs_w(NULL, pFilePath, pConfig, pDecoder); -} - -MA_API ma_result ma_decoder_uninit(ma_decoder* pDecoder) -{ - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - if (pDecoder->pBackend != NULL) { - if (pDecoder->pBackendVTable != NULL && pDecoder->pBackendVTable->onUninit != NULL) { - pDecoder->pBackendVTable->onUninit(pDecoder->pBackendUserData, pDecoder->pBackend, &pDecoder->allocationCallbacks); - } - } - - if (pDecoder->onRead == ma_decoder__on_read_vfs) { - ma_vfs_or_default_close(pDecoder->data.vfs.pVFS, pDecoder->data.vfs.file); - pDecoder->data.vfs.file = NULL; - } - - ma_data_converter_uninit(&pDecoder->converter, &pDecoder->allocationCallbacks); - ma_data_source_uninit(&pDecoder->ds); - - if (pDecoder->pInputCache != NULL) { - ma_free(pDecoder->pInputCache, &pDecoder->allocationCallbacks); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_read_pcm_frames(ma_decoder* pDecoder, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint64 totalFramesReadOut; - void* pRunningFramesOut; - - if (pFramesRead != NULL) { - *pFramesRead = 0; /* Safety. */ - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - if (pDecoder->pBackend == NULL) { - return MA_INVALID_OPERATION; - } - - /* Fast path. */ - if (pDecoder->converter.isPassthrough) { - result = ma_data_source_read_pcm_frames(pDecoder->pBackend, pFramesOut, frameCount, &totalFramesReadOut); - } else { - /* - Getting here means we need to do data conversion. If we're seeking forward and are _not_ doing resampling we can run this in a fast path. If we're doing resampling we - need to run through each sample because we need to ensure it's internal cache is updated. - */ - if (pFramesOut == NULL && pDecoder->converter.hasResampler == MA_FALSE) { - result = ma_data_source_read_pcm_frames(pDecoder->pBackend, NULL, frameCount, &totalFramesReadOut); - } else { - /* Slow path. Need to run everything through the data converter. */ - ma_format internalFormat; - ma_uint32 internalChannels; - - totalFramesReadOut = 0; - pRunningFramesOut = pFramesOut; - - result = ma_data_source_get_data_format(pDecoder->pBackend, &internalFormat, &internalChannels, NULL, NULL, 0); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the internal format and channel count. */ - } - - /* - We run a different path depending on whether or not we are using a heap-allocated - intermediary buffer or not. If the data converter does not support the calculation of - the required number of input frames, we'll use the heap-allocated path. Otherwise we'll - use the stack-allocated path. - */ - if (pDecoder->pInputCache != NULL) { - /* We don't have a way of determining the required number of input frames, so need to persistently store input data in a cache. */ - while (totalFramesReadOut < frameCount) { - ma_uint64 framesToReadThisIterationIn; - ma_uint64 framesToReadThisIterationOut; - - /* If there's any data available in the cache, that needs to get processed first. */ - if (pDecoder->inputCacheRemaining > 0) { - framesToReadThisIterationOut = (frameCount - totalFramesReadOut); - framesToReadThisIterationIn = framesToReadThisIterationOut; - if (framesToReadThisIterationIn > pDecoder->inputCacheRemaining) { - framesToReadThisIterationIn = pDecoder->inputCacheRemaining; - } - - result = ma_data_converter_process_pcm_frames(&pDecoder->converter, ma_offset_pcm_frames_ptr(pDecoder->pInputCache, pDecoder->inputCacheConsumed, internalFormat, internalChannels), &framesToReadThisIterationIn, pRunningFramesOut, &framesToReadThisIterationOut); - if (result != MA_SUCCESS) { - break; - } - - pDecoder->inputCacheConsumed += framesToReadThisIterationIn; - pDecoder->inputCacheRemaining -= framesToReadThisIterationIn; - - totalFramesReadOut += framesToReadThisIterationOut; - - if (pRunningFramesOut != NULL) { - pRunningFramesOut = ma_offset_ptr(pRunningFramesOut, framesToReadThisIterationOut * ma_get_bytes_per_frame(pDecoder->outputFormat, pDecoder->outputChannels)); - } - - if (framesToReadThisIterationIn == 0 && framesToReadThisIterationOut == 0) { - break; /* We're done. */ - } - } - - /* Getting here means there's no data in the cache and we need to fill it up from the data source. */ - if (pDecoder->inputCacheRemaining == 0) { - pDecoder->inputCacheConsumed = 0; - - result = ma_data_source_read_pcm_frames(pDecoder->pBackend, pDecoder->pInputCache, pDecoder->inputCacheCap, &pDecoder->inputCacheRemaining); - if (result != MA_SUCCESS) { - break; - } - } - } - } else { - /* We have a way of determining the required number of input frames so just use the stack. */ - while (totalFramesReadOut < frameCount) { - ma_uint8 pIntermediaryBuffer[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* In internal format. */ - ma_uint64 intermediaryBufferCap = sizeof(pIntermediaryBuffer) / ma_get_bytes_per_frame(internalFormat, internalChannels); - ma_uint64 framesToReadThisIterationIn; - ma_uint64 framesReadThisIterationIn; - ma_uint64 framesToReadThisIterationOut; - ma_uint64 framesReadThisIterationOut; - ma_uint64 requiredInputFrameCount; - - framesToReadThisIterationOut = (frameCount - totalFramesReadOut); - framesToReadThisIterationIn = framesToReadThisIterationOut; - if (framesToReadThisIterationIn > intermediaryBufferCap) { - framesToReadThisIterationIn = intermediaryBufferCap; - } - - ma_data_converter_get_required_input_frame_count(&pDecoder->converter, framesToReadThisIterationOut, &requiredInputFrameCount); - if (framesToReadThisIterationIn > requiredInputFrameCount) { - framesToReadThisIterationIn = requiredInputFrameCount; - } - - if (requiredInputFrameCount > 0) { - result = ma_data_source_read_pcm_frames(pDecoder->pBackend, pIntermediaryBuffer, framesToReadThisIterationIn, &framesReadThisIterationIn); - } else { - framesReadThisIterationIn = 0; - } - - /* - At this point we have our decoded data in input format and now we need to convert to output format. Note that even if we didn't read any - input frames, we still want to try processing frames because there may some output frames generated from cached input data. - */ - framesReadThisIterationOut = framesToReadThisIterationOut; - result = ma_data_converter_process_pcm_frames(&pDecoder->converter, pIntermediaryBuffer, &framesReadThisIterationIn, pRunningFramesOut, &framesReadThisIterationOut); - if (result != MA_SUCCESS) { - break; - } - - totalFramesReadOut += framesReadThisIterationOut; - - if (pRunningFramesOut != NULL) { - pRunningFramesOut = ma_offset_ptr(pRunningFramesOut, framesReadThisIterationOut * ma_get_bytes_per_frame(pDecoder->outputFormat, pDecoder->outputChannels)); - } - - if (framesReadThisIterationIn == 0 && framesReadThisIterationOut == 0) { - break; /* We're done. */ - } - } - } - } - } - - pDecoder->readPointerInPCMFrames += totalFramesReadOut; - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesReadOut; - } - - if (result == MA_SUCCESS && totalFramesReadOut == 0) { - result = MA_AT_END; - } - - return result; -} - -MA_API ma_result ma_decoder_seek_to_pcm_frame(ma_decoder* pDecoder, ma_uint64 frameIndex) -{ - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - if (pDecoder->pBackend != NULL) { - ma_result result; - ma_uint64 internalFrameIndex; - ma_uint32 internalSampleRate; - ma_uint64 currentFrameIndex; - - result = ma_data_source_get_data_format(pDecoder->pBackend, NULL, NULL, &internalSampleRate, NULL, 0); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the internal sample rate. */ - } - - if (internalSampleRate == pDecoder->outputSampleRate) { - internalFrameIndex = frameIndex; - } else { - internalFrameIndex = ma_calculate_frame_count_after_resampling(internalSampleRate, pDecoder->outputSampleRate, frameIndex); - } - - /* Only seek if we're requesting a different frame to what we're currently sitting on. */ - ma_data_source_get_cursor_in_pcm_frames(pDecoder->pBackend, ¤tFrameIndex); - if (currentFrameIndex != internalFrameIndex) { - result = ma_data_source_seek_to_pcm_frame(pDecoder->pBackend, internalFrameIndex); - if (result == MA_SUCCESS) { - pDecoder->readPointerInPCMFrames = frameIndex; - } - - /* Reset the data converter so that any cached data in the resampler is cleared. */ - ma_data_converter_reset(&pDecoder->converter); - } - - return result; - } - - /* Should never get here, but if we do it means onSeekToPCMFrame was not set by the backend. */ - return MA_INVALID_ARGS; -} - -MA_API ma_result ma_decoder_get_data_format(ma_decoder* pDecoder, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - if (pFormat != NULL) { - *pFormat = pDecoder->outputFormat; - } - - if (pChannels != NULL) { - *pChannels = pDecoder->outputChannels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pDecoder->outputSampleRate; - } - - if (pChannelMap != NULL) { - ma_data_converter_get_output_channel_map(&pDecoder->converter, pChannelMap, channelMapCap); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_get_cursor_in_pcm_frames(ma_decoder* pDecoder, ma_uint64* pCursor) -{ - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = pDecoder->readPointerInPCMFrames; - - return MA_SUCCESS; -} - -MA_API ma_result ma_decoder_get_length_in_pcm_frames(ma_decoder* pDecoder, ma_uint64* pLength) -{ - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; - - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - if (pDecoder->pBackend != NULL) { - ma_result result; - ma_uint64 internalLengthInPCMFrames; - ma_uint32 internalSampleRate; - - result = ma_data_source_get_length_in_pcm_frames(pDecoder->pBackend, &internalLengthInPCMFrames); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the internal length. */ - } - - result = ma_data_source_get_data_format(pDecoder->pBackend, NULL, NULL, &internalSampleRate, NULL, 0); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the internal sample rate. */ - } - - if (internalSampleRate == pDecoder->outputSampleRate) { - *pLength = internalLengthInPCMFrames; - } else { - *pLength = ma_calculate_frame_count_after_resampling(pDecoder->outputSampleRate, internalSampleRate, internalLengthInPCMFrames); - } - - return MA_SUCCESS; - } else { - return MA_NO_BACKEND; - } -} - -MA_API ma_result ma_decoder_get_available_frames(ma_decoder* pDecoder, ma_uint64* pAvailableFrames) -{ - ma_result result; - ma_uint64 totalFrameCount; - - if (pAvailableFrames == NULL) { - return MA_INVALID_ARGS; - } - - *pAvailableFrames = 0; - - if (pDecoder == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_decoder_get_length_in_pcm_frames(pDecoder, &totalFrameCount); - if (result != MA_SUCCESS) { - return result; - } - - if (totalFrameCount <= pDecoder->readPointerInPCMFrames) { - *pAvailableFrames = 0; - } else { - *pAvailableFrames = totalFrameCount - pDecoder->readPointerInPCMFrames; - } - - return MA_SUCCESS; -} - - -static ma_result ma_decoder__full_decode_and_uninit(ma_decoder* pDecoder, ma_decoder_config* pConfigOut, ma_uint64* pFrameCountOut, void** ppPCMFramesOut) -{ - ma_result result; - ma_uint64 totalFrameCount; - ma_uint64 bpf; - ma_uint64 dataCapInFrames; - void* pPCMFramesOut; - - MA_ASSERT(pDecoder != NULL); - - totalFrameCount = 0; - bpf = ma_get_bytes_per_frame(pDecoder->outputFormat, pDecoder->outputChannels); - - /* The frame count is unknown until we try reading. Thus, we just run in a loop. */ - dataCapInFrames = 0; - pPCMFramesOut = NULL; - for (;;) { - ma_uint64 frameCountToTryReading; - ma_uint64 framesJustRead; - - /* Make room if there's not enough. */ - if (totalFrameCount == dataCapInFrames) { - void* pNewPCMFramesOut; - ma_uint64 newDataCapInFrames = dataCapInFrames*2; - if (newDataCapInFrames == 0) { - newDataCapInFrames = 4096; - } - - if ((newDataCapInFrames * bpf) > MA_SIZE_MAX) { - ma_free(pPCMFramesOut, &pDecoder->allocationCallbacks); - return MA_TOO_BIG; - } - - pNewPCMFramesOut = (void*)ma_realloc(pPCMFramesOut, (size_t)(newDataCapInFrames * bpf), &pDecoder->allocationCallbacks); - if (pNewPCMFramesOut == NULL) { - ma_free(pPCMFramesOut, &pDecoder->allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - dataCapInFrames = newDataCapInFrames; - pPCMFramesOut = pNewPCMFramesOut; - } - - frameCountToTryReading = dataCapInFrames - totalFrameCount; - MA_ASSERT(frameCountToTryReading > 0); - - result = ma_decoder_read_pcm_frames(pDecoder, (ma_uint8*)pPCMFramesOut + (totalFrameCount * bpf), frameCountToTryReading, &framesJustRead); - totalFrameCount += framesJustRead; - - if (result != MA_SUCCESS) { - break; - } - - if (framesJustRead < frameCountToTryReading) { - break; - } - } - - - if (pConfigOut != NULL) { - pConfigOut->format = pDecoder->outputFormat; - pConfigOut->channels = pDecoder->outputChannels; - pConfigOut->sampleRate = pDecoder->outputSampleRate; - } - - if (ppPCMFramesOut != NULL) { - *ppPCMFramesOut = pPCMFramesOut; - } else { - ma_free(pPCMFramesOut, &pDecoder->allocationCallbacks); - } - - if (pFrameCountOut != NULL) { - *pFrameCountOut = totalFrameCount; - } - - ma_decoder_uninit(pDecoder); - return MA_SUCCESS; -} - -MA_API ma_result ma_decode_from_vfs(ma_vfs* pVFS, const char* pFilePath, ma_decoder_config* pConfig, ma_uint64* pFrameCountOut, void** ppPCMFramesOut) -{ - ma_result result; - ma_decoder_config config; - ma_decoder decoder; - - if (pFrameCountOut != NULL) { - *pFrameCountOut = 0; - } - if (ppPCMFramesOut != NULL) { - *ppPCMFramesOut = NULL; - } - - config = ma_decoder_config_init_copy(pConfig); - - result = ma_decoder_init_vfs(pVFS, pFilePath, &config, &decoder); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_decoder__full_decode_and_uninit(&decoder, pConfig, pFrameCountOut, ppPCMFramesOut); - - return result; -} - -MA_API ma_result ma_decode_file(const char* pFilePath, ma_decoder_config* pConfig, ma_uint64* pFrameCountOut, void** ppPCMFramesOut) -{ - return ma_decode_from_vfs(NULL, pFilePath, pConfig, pFrameCountOut, ppPCMFramesOut); -} - -MA_API ma_result ma_decode_memory(const void* pData, size_t dataSize, ma_decoder_config* pConfig, ma_uint64* pFrameCountOut, void** ppPCMFramesOut) -{ - ma_decoder_config config; - ma_decoder decoder; - ma_result result; - - if (pFrameCountOut != NULL) { - *pFrameCountOut = 0; - } - if (ppPCMFramesOut != NULL) { - *ppPCMFramesOut = NULL; - } - - if (pData == NULL || dataSize == 0) { - return MA_INVALID_ARGS; - } - - config = ma_decoder_config_init_copy(pConfig); - - result = ma_decoder_init_memory(pData, dataSize, &config, &decoder); - if (result != MA_SUCCESS) { - return result; - } - - return ma_decoder__full_decode_and_uninit(&decoder, pConfig, pFrameCountOut, ppPCMFramesOut); -} -#endif /* MA_NO_DECODING */ - - -#ifndef MA_NO_ENCODING - -#if defined(MA_HAS_WAV) -static size_t ma_encoder__internal_on_write_wav(void* pUserData, const void* pData, size_t bytesToWrite) -{ - ma_encoder* pEncoder = (ma_encoder*)pUserData; - size_t bytesWritten = 0; - - MA_ASSERT(pEncoder != NULL); - - pEncoder->onWrite(pEncoder, pData, bytesToWrite, &bytesWritten); - return bytesWritten; -} - -static drwav_bool32 ma_encoder__internal_on_seek_wav(void* pUserData, int offset, drwav_seek_origin origin) -{ - ma_encoder* pEncoder = (ma_encoder*)pUserData; - ma_result result; - - MA_ASSERT(pEncoder != NULL); - - result = pEncoder->onSeek(pEncoder, offset, (origin == drwav_seek_origin_start) ? ma_seek_origin_start : ma_seek_origin_current); - if (result != MA_SUCCESS) { - return DRWAV_FALSE; - } else { - return DRWAV_TRUE; - } -} - -static ma_result ma_encoder__on_init_wav(ma_encoder* pEncoder) -{ - drwav_data_format wavFormat; - drwav_allocation_callbacks allocationCallbacks; - drwav* pWav; - - MA_ASSERT(pEncoder != NULL); - - pWav = (drwav*)ma_malloc(sizeof(*pWav), &pEncoder->config.allocationCallbacks); - if (pWav == NULL) { - return MA_OUT_OF_MEMORY; - } - - wavFormat.container = drwav_container_riff; - wavFormat.channels = pEncoder->config.channels; - wavFormat.sampleRate = pEncoder->config.sampleRate; - wavFormat.bitsPerSample = ma_get_bytes_per_sample(pEncoder->config.format) * 8; - if (pEncoder->config.format == ma_format_f32) { - wavFormat.format = DR_WAVE_FORMAT_IEEE_FLOAT; - } else { - wavFormat.format = DR_WAVE_FORMAT_PCM; - } - - allocationCallbacks.pUserData = pEncoder->config.allocationCallbacks.pUserData; - allocationCallbacks.onMalloc = pEncoder->config.allocationCallbacks.onMalloc; - allocationCallbacks.onRealloc = pEncoder->config.allocationCallbacks.onRealloc; - allocationCallbacks.onFree = pEncoder->config.allocationCallbacks.onFree; - - if (!drwav_init_write(pWav, &wavFormat, ma_encoder__internal_on_write_wav, ma_encoder__internal_on_seek_wav, pEncoder, &allocationCallbacks)) { - return MA_ERROR; - } - - pEncoder->pInternalEncoder = pWav; - - return MA_SUCCESS; -} - -static void ma_encoder__on_uninit_wav(ma_encoder* pEncoder) -{ - drwav* pWav; - - MA_ASSERT(pEncoder != NULL); - - pWav = (drwav*)pEncoder->pInternalEncoder; - MA_ASSERT(pWav != NULL); - - drwav_uninit(pWav); - ma_free(pWav, &pEncoder->config.allocationCallbacks); -} - -static ma_result ma_encoder__on_write_pcm_frames_wav(ma_encoder* pEncoder, const void* pFramesIn, ma_uint64 frameCount, ma_uint64* pFramesWritten) -{ - drwav* pWav; - ma_uint64 framesWritten; - - MA_ASSERT(pEncoder != NULL); - - pWav = (drwav*)pEncoder->pInternalEncoder; - MA_ASSERT(pWav != NULL); - - framesWritten = drwav_write_pcm_frames(pWav, frameCount, pFramesIn); - - if (pFramesWritten != NULL) { - *pFramesWritten = framesWritten; - } - - return MA_SUCCESS; -} -#endif - -MA_API ma_encoder_config ma_encoder_config_init(ma_encoding_format encodingFormat, ma_format format, ma_uint32 channels, ma_uint32 sampleRate) -{ - ma_encoder_config config; - - MA_ZERO_OBJECT(&config); - config.encodingFormat = encodingFormat; - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - - return config; -} - -MA_API ma_result ma_encoder_preinit(const ma_encoder_config* pConfig, ma_encoder* pEncoder) -{ - ma_result result; - - if (pEncoder == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pEncoder); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->format == ma_format_unknown || pConfig->channels == 0 || pConfig->sampleRate == 0) { - return MA_INVALID_ARGS; - } - - pEncoder->config = *pConfig; - - result = ma_allocation_callbacks_init_copy(&pEncoder->config.allocationCallbacks, &pConfig->allocationCallbacks); - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_encoder_init__internal(ma_encoder_write_proc onWrite, ma_encoder_seek_proc onSeek, void* pUserData, ma_encoder* pEncoder) -{ - ma_result result = MA_SUCCESS; - - /* This assumes ma_encoder_preinit() has been called prior. */ - MA_ASSERT(pEncoder != NULL); - - if (onWrite == NULL || onSeek == NULL) { - return MA_INVALID_ARGS; - } - - pEncoder->onWrite = onWrite; - pEncoder->onSeek = onSeek; - pEncoder->pUserData = pUserData; - - switch (pEncoder->config.encodingFormat) - { - case ma_encoding_format_wav: - { - #if defined(MA_HAS_WAV) - pEncoder->onInit = ma_encoder__on_init_wav; - pEncoder->onUninit = ma_encoder__on_uninit_wav; - pEncoder->onWritePCMFrames = ma_encoder__on_write_pcm_frames_wav; - #else - result = MA_NO_BACKEND; - #endif - } break; - - default: - { - result = MA_INVALID_ARGS; - } break; - } - - /* Getting here means we should have our backend callbacks set up. */ - if (result == MA_SUCCESS) { - result = pEncoder->onInit(pEncoder); - } - - return result; -} - -static ma_result ma_encoder__on_write_vfs(ma_encoder* pEncoder, const void* pBufferIn, size_t bytesToWrite, size_t* pBytesWritten) -{ - return ma_vfs_or_default_write(pEncoder->data.vfs.pVFS, pEncoder->data.vfs.file, pBufferIn, bytesToWrite, pBytesWritten); -} - -static ma_result ma_encoder__on_seek_vfs(ma_encoder* pEncoder, ma_int64 offset, ma_seek_origin origin) -{ - return ma_vfs_or_default_seek(pEncoder->data.vfs.pVFS, pEncoder->data.vfs.file, offset, origin); -} - -MA_API ma_result ma_encoder_init_vfs(ma_vfs* pVFS, const char* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder) -{ - ma_result result; - ma_vfs_file file; - - result = ma_encoder_preinit(pConfig, pEncoder); - if (result != MA_SUCCESS) { - return result; - } - - /* Now open the file. If this fails we don't need to uninitialize the encoder. */ - result = ma_vfs_or_default_open(pVFS, pFilePath, MA_OPEN_MODE_WRITE, &file); - if (result != MA_SUCCESS) { - return result; - } - - pEncoder->data.vfs.pVFS = pVFS; - pEncoder->data.vfs.file = file; - - result = ma_encoder_init__internal(ma_encoder__on_write_vfs, ma_encoder__on_seek_vfs, NULL, pEncoder); - if (result != MA_SUCCESS) { - ma_vfs_or_default_close(pVFS, file); - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_encoder_init_vfs_w(ma_vfs* pVFS, const wchar_t* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder) -{ - ma_result result; - ma_vfs_file file; - - result = ma_encoder_preinit(pConfig, pEncoder); - if (result != MA_SUCCESS) { - return result; - } - - /* Now open the file. If this fails we don't need to uninitialize the encoder. */ - result = ma_vfs_or_default_open_w(pVFS, pFilePath, MA_OPEN_MODE_WRITE, &file); - if (result != MA_SUCCESS) { - return result; - } - - pEncoder->data.vfs.pVFS = pVFS; - pEncoder->data.vfs.file = file; - - result = ma_encoder_init__internal(ma_encoder__on_write_vfs, ma_encoder__on_seek_vfs, NULL, pEncoder); - if (result != MA_SUCCESS) { - ma_vfs_or_default_close(pVFS, file); - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_encoder_init_file(const char* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder) -{ - return ma_encoder_init_vfs(NULL, pFilePath, pConfig, pEncoder); -} - -MA_API ma_result ma_encoder_init_file_w(const wchar_t* pFilePath, const ma_encoder_config* pConfig, ma_encoder* pEncoder) -{ - return ma_encoder_init_vfs_w(NULL, pFilePath, pConfig, pEncoder); -} - -MA_API ma_result ma_encoder_init(ma_encoder_write_proc onWrite, ma_encoder_seek_proc onSeek, void* pUserData, const ma_encoder_config* pConfig, ma_encoder* pEncoder) -{ - ma_result result; - - result = ma_encoder_preinit(pConfig, pEncoder); - if (result != MA_SUCCESS) { - return result; - } - - return ma_encoder_init__internal(onWrite, onSeek, pUserData, pEncoder); -} - - -MA_API void ma_encoder_uninit(ma_encoder* pEncoder) -{ - if (pEncoder == NULL) { - return; - } - - if (pEncoder->onUninit) { - pEncoder->onUninit(pEncoder); - } - - /* If we have a file handle, close it. */ - if (pEncoder->onWrite == ma_encoder__on_write_vfs) { - ma_vfs_or_default_close(pEncoder->data.vfs.pVFS, pEncoder->data.vfs.file); - pEncoder->data.vfs.file = NULL; - } -} - - -MA_API ma_result ma_encoder_write_pcm_frames(ma_encoder* pEncoder, const void* pFramesIn, ma_uint64 frameCount, ma_uint64* pFramesWritten) -{ - if (pFramesWritten != NULL) { - *pFramesWritten = 0; - } - - if (pEncoder == NULL || pFramesIn == NULL) { - return MA_INVALID_ARGS; - } - - return pEncoder->onWritePCMFrames(pEncoder, pFramesIn, frameCount, pFramesWritten); -} -#endif /* MA_NO_ENCODING */ - - - -/************************************************************************************************************************************************************** - -Generation - -**************************************************************************************************************************************************************/ -#ifndef MA_NO_GENERATION -MA_API ma_waveform_config ma_waveform_config_init(ma_format format, ma_uint32 channels, ma_uint32 sampleRate, ma_waveform_type type, double amplitude, double frequency) -{ - ma_waveform_config config; - - MA_ZERO_OBJECT(&config); - config.format = format; - config.channels = channels; - config.sampleRate = sampleRate; - config.type = type; - config.amplitude = amplitude; - config.frequency = frequency; - - return config; -} - -static ma_result ma_waveform__data_source_on_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_waveform_read_pcm_frames((ma_waveform*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_waveform__data_source_on_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_waveform_seek_to_pcm_frame((ma_waveform*)pDataSource, frameIndex); -} - -static ma_result ma_waveform__data_source_on_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - ma_waveform* pWaveform = (ma_waveform*)pDataSource; - - *pFormat = pWaveform->config.format; - *pChannels = pWaveform->config.channels; - *pSampleRate = pWaveform->config.sampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pWaveform->config.channels); - - return MA_SUCCESS; -} - -static ma_result ma_waveform__data_source_on_get_cursor(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - ma_waveform* pWaveform = (ma_waveform*)pDataSource; - - *pCursor = (ma_uint64)(pWaveform->time / pWaveform->advance); - - return MA_SUCCESS; -} - -static double ma_waveform__calculate_advance(ma_uint32 sampleRate, double frequency) -{ - return (1.0 / (sampleRate / frequency)); -} - -static void ma_waveform__update_advance(ma_waveform* pWaveform) -{ - pWaveform->advance = ma_waveform__calculate_advance(pWaveform->config.sampleRate, pWaveform->config.frequency); -} - -static ma_data_source_vtable g_ma_waveform_data_source_vtable = -{ - ma_waveform__data_source_on_read, - ma_waveform__data_source_on_seek, - ma_waveform__data_source_on_get_data_format, - ma_waveform__data_source_on_get_cursor, - NULL, /* onGetLength. There's no notion of a length in waveforms. */ - NULL, /* onSetLooping */ - 0 -}; - -MA_API ma_result ma_waveform_init(const ma_waveform_config* pConfig, ma_waveform* pWaveform) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pWaveform); - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_waveform_data_source_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pWaveform->ds); - if (result != MA_SUCCESS) { - return result; - } - - pWaveform->config = *pConfig; - pWaveform->advance = ma_waveform__calculate_advance(pWaveform->config.sampleRate, pWaveform->config.frequency); - pWaveform->time = 0; - - return MA_SUCCESS; -} - -MA_API void ma_waveform_uninit(ma_waveform* pWaveform) -{ - if (pWaveform == NULL) { - return; - } - - ma_data_source_uninit(&pWaveform->ds); -} - -MA_API ma_result ma_waveform_set_amplitude(ma_waveform* pWaveform, double amplitude) -{ - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - pWaveform->config.amplitude = amplitude; - return MA_SUCCESS; -} - -MA_API ma_result ma_waveform_set_frequency(ma_waveform* pWaveform, double frequency) -{ - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - pWaveform->config.frequency = frequency; - ma_waveform__update_advance(pWaveform); - - return MA_SUCCESS; -} - -MA_API ma_result ma_waveform_set_type(ma_waveform* pWaveform, ma_waveform_type type) -{ - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - pWaveform->config.type = type; - return MA_SUCCESS; -} - -MA_API ma_result ma_waveform_set_sample_rate(ma_waveform* pWaveform, ma_uint32 sampleRate) -{ - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - pWaveform->config.sampleRate = sampleRate; - ma_waveform__update_advance(pWaveform); - - return MA_SUCCESS; -} - -static float ma_waveform_sine_f32(double time, double amplitude) -{ - return (float)(ma_sind(MA_TAU_D * time) * amplitude); -} - -static ma_int16 ma_waveform_sine_s16(double time, double amplitude) -{ - return ma_pcm_sample_f32_to_s16(ma_waveform_sine_f32(time, amplitude)); -} - -static float ma_waveform_square_f32(double time, double amplitude) -{ - double f = time - (ma_int64)time; - double r; - - if (f < 0.5) { - r = amplitude; - } else { - r = -amplitude; - } - - return (float)r; -} - -static ma_int16 ma_waveform_square_s16(double time, double amplitude) -{ - return ma_pcm_sample_f32_to_s16(ma_waveform_square_f32(time, amplitude)); -} - -static float ma_waveform_triangle_f32(double time, double amplitude) -{ - double f = time - (ma_int64)time; - double r; - - r = 2 * ma_abs(2 * (f - 0.5)) - 1; - - return (float)(r * amplitude); -} - -static ma_int16 ma_waveform_triangle_s16(double time, double amplitude) -{ - return ma_pcm_sample_f32_to_s16(ma_waveform_triangle_f32(time, amplitude)); -} - -static float ma_waveform_sawtooth_f32(double time, double amplitude) -{ - double f = time - (ma_int64)time; - double r; - - r = 2 * (f - 0.5); - - return (float)(r * amplitude); -} - -static ma_int16 ma_waveform_sawtooth_s16(double time, double amplitude) -{ - return ma_pcm_sample_f32_to_s16(ma_waveform_sawtooth_f32(time, amplitude)); -} - -static void ma_waveform_read_pcm_frames__sine(ma_waveform* pWaveform, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint64 iChannel; - ma_uint32 bps = ma_get_bytes_per_sample(pWaveform->config.format); - ma_uint32 bpf = bps * pWaveform->config.channels; - - MA_ASSERT(pWaveform != NULL); - MA_ASSERT(pFramesOut != NULL); - - if (pWaveform->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_sine_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else if (pWaveform->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_waveform_sine_s16(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutS16[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_sine_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pWaveform->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } -} - -static void ma_waveform_read_pcm_frames__square(ma_waveform* pWaveform, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint64 iChannel; - ma_uint32 bps = ma_get_bytes_per_sample(pWaveform->config.format); - ma_uint32 bpf = bps * pWaveform->config.channels; - - MA_ASSERT(pWaveform != NULL); - MA_ASSERT(pFramesOut != NULL); - - if (pWaveform->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_square_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else if (pWaveform->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_waveform_square_s16(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutS16[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_square_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pWaveform->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } -} - -static void ma_waveform_read_pcm_frames__triangle(ma_waveform* pWaveform, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint64 iChannel; - ma_uint32 bps = ma_get_bytes_per_sample(pWaveform->config.format); - ma_uint32 bpf = bps * pWaveform->config.channels; - - MA_ASSERT(pWaveform != NULL); - MA_ASSERT(pFramesOut != NULL); - - if (pWaveform->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_triangle_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else if (pWaveform->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_waveform_triangle_s16(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutS16[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_triangle_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pWaveform->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } -} - -static void ma_waveform_read_pcm_frames__sawtooth(ma_waveform* pWaveform, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint64 iChannel; - ma_uint32 bps = ma_get_bytes_per_sample(pWaveform->config.format); - ma_uint32 bpf = bps * pWaveform->config.channels; - - MA_ASSERT(pWaveform != NULL); - MA_ASSERT(pFramesOut != NULL); - - if (pWaveform->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_sawtooth_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutF32[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else if (pWaveform->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_waveform_sawtooth_s16(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - pFramesOutS16[iFrame*pWaveform->config.channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_waveform_sawtooth_f32(pWaveform->time, pWaveform->config.amplitude); - pWaveform->time += pWaveform->advance; - - for (iChannel = 0; iChannel < pWaveform->config.channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pWaveform->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } -} - -MA_API ma_result ma_waveform_read_pcm_frames(ma_waveform* pWaveform, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - if (pFramesOut != NULL) { - switch (pWaveform->config.type) - { - case ma_waveform_type_sine: - { - ma_waveform_read_pcm_frames__sine(pWaveform, pFramesOut, frameCount); - } break; - - case ma_waveform_type_square: - { - ma_waveform_read_pcm_frames__square(pWaveform, pFramesOut, frameCount); - } break; - - case ma_waveform_type_triangle: - { - ma_waveform_read_pcm_frames__triangle(pWaveform, pFramesOut, frameCount); - } break; - - case ma_waveform_type_sawtooth: - { - ma_waveform_read_pcm_frames__sawtooth(pWaveform, pFramesOut, frameCount); - } break; - - default: return MA_INVALID_OPERATION; /* Unknown waveform type. */ - } - } else { - pWaveform->time += pWaveform->advance * (ma_int64)frameCount; /* Cast to int64 required for VC6. Won't affect anything in practice. */ - } - - if (pFramesRead != NULL) { - *pFramesRead = frameCount; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_waveform_seek_to_pcm_frame(ma_waveform* pWaveform, ma_uint64 frameIndex) -{ - if (pWaveform == NULL) { - return MA_INVALID_ARGS; - } - - pWaveform->time = pWaveform->advance * (ma_int64)frameIndex; /* Casting for VC6. Won't be an issue in practice. */ - - return MA_SUCCESS; -} - - -MA_API ma_noise_config ma_noise_config_init(ma_format format, ma_uint32 channels, ma_noise_type type, ma_int32 seed, double amplitude) -{ - ma_noise_config config; - MA_ZERO_OBJECT(&config); - - config.format = format; - config.channels = channels; - config.type = type; - config.seed = seed; - config.amplitude = amplitude; - - if (config.seed == 0) { - config.seed = MA_DEFAULT_LCG_SEED; - } - - return config; -} - - -static ma_result ma_noise__data_source_on_read(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_noise_read_pcm_frames((ma_noise*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_noise__data_source_on_seek(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - /* No-op. Just pretend to be successful. */ - (void)pDataSource; - (void)frameIndex; - return MA_SUCCESS; -} - -static ma_result ma_noise__data_source_on_get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - ma_noise* pNoise = (ma_noise*)pDataSource; - - *pFormat = pNoise->config.format; - *pChannels = pNoise->config.channels; - *pSampleRate = 0; /* There is no notion of sample rate with noise generation. */ - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pNoise->config.channels); - - return MA_SUCCESS; -} - -static ma_data_source_vtable g_ma_noise_data_source_vtable = -{ - ma_noise__data_source_on_read, - ma_noise__data_source_on_seek, /* No-op for noise. */ - ma_noise__data_source_on_get_data_format, - NULL, /* onGetCursor. No notion of a cursor for noise. */ - NULL, /* onGetLength. No notion of a length for noise. */ - NULL, /* onSetLooping */ - 0 -}; - - -#ifndef MA_PINK_NOISE_BIN_SIZE -#define MA_PINK_NOISE_BIN_SIZE 16 -#endif - -typedef struct -{ - size_t sizeInBytes; - struct - { - size_t binOffset; - size_t accumulationOffset; - size_t counterOffset; - } pink; - struct - { - size_t accumulationOffset; - } brownian; -} ma_noise_heap_layout; - -static ma_result ma_noise_get_heap_layout(const ma_noise_config* pConfig, ma_noise_heap_layout* pHeapLayout) -{ - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->channels == 0) { - return MA_INVALID_ARGS; - } - - pHeapLayout->sizeInBytes = 0; - - /* Pink. */ - if (pConfig->type == ma_noise_type_pink) { - /* bin */ - pHeapLayout->pink.binOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(double*) * pConfig->channels; - pHeapLayout->sizeInBytes += sizeof(double ) * pConfig->channels * MA_PINK_NOISE_BIN_SIZE; - - /* accumulation */ - pHeapLayout->pink.accumulationOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(double) * pConfig->channels; - - /* counter */ - pHeapLayout->pink.counterOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(ma_uint32) * pConfig->channels; - } - - /* Brownian. */ - if (pConfig->type == ma_noise_type_brownian) { - /* accumulation */ - pHeapLayout->brownian.accumulationOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += sizeof(double) * pConfig->channels; - } - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_noise_get_heap_size(const ma_noise_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_noise_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_noise_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_noise_init_preallocated(const ma_noise_config* pConfig, void* pHeap, ma_noise* pNoise) -{ - ma_result result; - ma_noise_heap_layout heapLayout; - ma_data_source_config dataSourceConfig; - ma_uint32 iChannel; - - if (pNoise == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNoise); - - result = ma_noise_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pNoise->_pHeap = pHeap; - MA_ZERO_MEMORY(pNoise->_pHeap, heapLayout.sizeInBytes); - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_noise_data_source_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pNoise->ds); - if (result != MA_SUCCESS) { - return result; - } - - pNoise->config = *pConfig; - ma_lcg_seed(&pNoise->lcg, pConfig->seed); - - if (pNoise->config.type == ma_noise_type_pink) { - pNoise->state.pink.bin = (double** )ma_offset_ptr(pHeap, heapLayout.pink.binOffset); - pNoise->state.pink.accumulation = (double* )ma_offset_ptr(pHeap, heapLayout.pink.accumulationOffset); - pNoise->state.pink.counter = (ma_uint32*)ma_offset_ptr(pHeap, heapLayout.pink.counterOffset); - - for (iChannel = 0; iChannel < pConfig->channels; iChannel += 1) { - pNoise->state.pink.bin[iChannel] = (double*)ma_offset_ptr(pHeap, heapLayout.pink.binOffset + (sizeof(double*) * pConfig->channels) + (sizeof(double) * MA_PINK_NOISE_BIN_SIZE * iChannel)); - pNoise->state.pink.accumulation[iChannel] = 0; - pNoise->state.pink.counter[iChannel] = 1; - } - } - - if (pNoise->config.type == ma_noise_type_brownian) { - pNoise->state.brownian.accumulation = (double*)ma_offset_ptr(pHeap, heapLayout.brownian.accumulationOffset); - - for (iChannel = 0; iChannel < pConfig->channels; iChannel += 1) { - pNoise->state.brownian.accumulation[iChannel] = 0; - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_noise_init(const ma_noise_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_noise* pNoise) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_noise_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_noise_init_preallocated(pConfig, pHeap, pNoise); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pNoise->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_noise_uninit(ma_noise* pNoise, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pNoise == NULL) { - return; - } - - ma_data_source_uninit(&pNoise->ds); - - if (pNoise->_ownsHeap) { - ma_free(pNoise->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_result ma_noise_set_amplitude(ma_noise* pNoise, double amplitude) -{ - if (pNoise == NULL) { - return MA_INVALID_ARGS; - } - - pNoise->config.amplitude = amplitude; - return MA_SUCCESS; -} - -MA_API ma_result ma_noise_set_seed(ma_noise* pNoise, ma_int32 seed) -{ - if (pNoise == NULL) { - return MA_INVALID_ARGS; - } - - pNoise->lcg.state = seed; - return MA_SUCCESS; -} - - -MA_API ma_result ma_noise_set_type(ma_noise* pNoise, ma_noise_type type) -{ - if (pNoise == NULL) { - return MA_INVALID_ARGS; - } - - /* - This function should never have been implemented in the first place. Changing the type dynamically is not - supported. Instead you need to uninitialize and reinitiailize a fresh `ma_noise` object. This function - will be removed in version 0.12. - */ - MA_ASSERT(MA_FALSE); - (void)type; - - return MA_INVALID_OPERATION; -} - -static MA_INLINE float ma_noise_f32_white(ma_noise* pNoise) -{ - return (float)(ma_lcg_rand_f64(&pNoise->lcg) * pNoise->config.amplitude); -} - -static MA_INLINE ma_int16 ma_noise_s16_white(ma_noise* pNoise) -{ - return ma_pcm_sample_f32_to_s16(ma_noise_f32_white(pNoise)); -} - -static MA_INLINE ma_uint64 ma_noise_read_pcm_frames__white(ma_noise* pNoise, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint32 iChannel; - const ma_uint32 channels = pNoise->config.channels; - MA_ASSUME(channels > 0); - - if (pNoise->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_noise_f32_white(pNoise); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutF32[iFrame*channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutF32[iFrame*channels + iChannel] = ma_noise_f32_white(pNoise); - } - } - } - } else if (pNoise->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_noise_s16_white(pNoise); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutS16[iFrame*channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutS16[iFrame*channels + iChannel] = ma_noise_s16_white(pNoise); - } - } - } - } else { - const ma_uint32 bps = ma_get_bytes_per_sample(pNoise->config.format); - const ma_uint32 bpf = bps * channels; - - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_noise_f32_white(pNoise); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pNoise->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - float s = ma_noise_f32_white(pNoise); - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pNoise->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } - } - - return frameCount; -} - - -static MA_INLINE unsigned int ma_tzcnt32(unsigned int x) -{ - unsigned int n; - - /* Special case for odd numbers since they should happen about half the time. */ - if (x & 0x1) { - return 0; - } - - if (x == 0) { - return sizeof(x) << 3; - } - - n = 1; - if ((x & 0x0000FFFF) == 0) { x >>= 16; n += 16; } - if ((x & 0x000000FF) == 0) { x >>= 8; n += 8; } - if ((x & 0x0000000F) == 0) { x >>= 4; n += 4; } - if ((x & 0x00000003) == 0) { x >>= 2; n += 2; } - n -= x & 0x00000001; - - return n; -} - -/* -Pink noise generation based on Tonic (public domain) with modifications. https://github.com/TonicAudio/Tonic/blob/master/src/Tonic/Noise.h - -This is basically _the_ reference for pink noise from what I've found: http://www.firstpr.com.au/dsp/pink-noise/ -*/ -static MA_INLINE float ma_noise_f32_pink(ma_noise* pNoise, ma_uint32 iChannel) -{ - double result; - double binPrev; - double binNext; - unsigned int ibin; - - ibin = ma_tzcnt32(pNoise->state.pink.counter[iChannel]) & (MA_PINK_NOISE_BIN_SIZE - 1); - - binPrev = pNoise->state.pink.bin[iChannel][ibin]; - binNext = ma_lcg_rand_f64(&pNoise->lcg); - pNoise->state.pink.bin[iChannel][ibin] = binNext; - - pNoise->state.pink.accumulation[iChannel] += (binNext - binPrev); - pNoise->state.pink.counter[iChannel] += 1; - - result = (ma_lcg_rand_f64(&pNoise->lcg) + pNoise->state.pink.accumulation[iChannel]); - result /= 10; - - return (float)(result * pNoise->config.amplitude); -} - -static MA_INLINE ma_int16 ma_noise_s16_pink(ma_noise* pNoise, ma_uint32 iChannel) -{ - return ma_pcm_sample_f32_to_s16(ma_noise_f32_pink(pNoise, iChannel)); -} - -static MA_INLINE ma_uint64 ma_noise_read_pcm_frames__pink(ma_noise* pNoise, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint32 iChannel; - const ma_uint32 channels = pNoise->config.channels; - MA_ASSUME(channels > 0); - - if (pNoise->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_noise_f32_pink(pNoise, 0); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutF32[iFrame*channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutF32[iFrame*channels + iChannel] = ma_noise_f32_pink(pNoise, iChannel); - } - } - } - } else if (pNoise->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_noise_s16_pink(pNoise, 0); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutS16[iFrame*channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutS16[iFrame*channels + iChannel] = ma_noise_s16_pink(pNoise, iChannel); - } - } - } - } else { - const ma_uint32 bps = ma_get_bytes_per_sample(pNoise->config.format); - const ma_uint32 bpf = bps * channels; - - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_noise_f32_pink(pNoise, 0); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pNoise->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - float s = ma_noise_f32_pink(pNoise, iChannel); - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pNoise->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } - } - - return frameCount; -} - - -static MA_INLINE float ma_noise_f32_brownian(ma_noise* pNoise, ma_uint32 iChannel) -{ - double result; - - result = (ma_lcg_rand_f64(&pNoise->lcg) + pNoise->state.brownian.accumulation[iChannel]); - result /= 1.005; /* Don't escape the -1..1 range on average. */ - - pNoise->state.brownian.accumulation[iChannel] = result; - result /= 20; - - return (float)(result * pNoise->config.amplitude); -} - -static MA_INLINE ma_int16 ma_noise_s16_brownian(ma_noise* pNoise, ma_uint32 iChannel) -{ - return ma_pcm_sample_f32_to_s16(ma_noise_f32_brownian(pNoise, iChannel)); -} - -static MA_INLINE ma_uint64 ma_noise_read_pcm_frames__brownian(ma_noise* pNoise, void* pFramesOut, ma_uint64 frameCount) -{ - ma_uint64 iFrame; - ma_uint32 iChannel; - const ma_uint32 channels = pNoise->config.channels; - MA_ASSUME(channels > 0); - - if (pNoise->config.format == ma_format_f32) { - float* pFramesOutF32 = (float*)pFramesOut; - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_noise_f32_brownian(pNoise, 0); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutF32[iFrame*channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutF32[iFrame*channels + iChannel] = ma_noise_f32_brownian(pNoise, iChannel); - } - } - } - } else if (pNoise->config.format == ma_format_s16) { - ma_int16* pFramesOutS16 = (ma_int16*)pFramesOut; - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - ma_int16 s = ma_noise_s16_brownian(pNoise, 0); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutS16[iFrame*channels + iChannel] = s; - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - pFramesOutS16[iFrame*channels + iChannel] = ma_noise_s16_brownian(pNoise, iChannel); - } - } - } - } else { - const ma_uint32 bps = ma_get_bytes_per_sample(pNoise->config.format); - const ma_uint32 bpf = bps * channels; - - if (pNoise->config.duplicateChannels) { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - float s = ma_noise_f32_brownian(pNoise, 0); - for (iChannel = 0; iChannel < channels; iChannel += 1) { - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pNoise->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } else { - for (iFrame = 0; iFrame < frameCount; iFrame += 1) { - for (iChannel = 0; iChannel < channels; iChannel += 1) { - float s = ma_noise_f32_brownian(pNoise, iChannel); - ma_pcm_convert(ma_offset_ptr(pFramesOut, iFrame*bpf + iChannel*bps), pNoise->config.format, &s, ma_format_f32, 1, ma_dither_mode_none); - } - } - } - } - - return frameCount; -} - -MA_API ma_result ma_noise_read_pcm_frames(ma_noise* pNoise, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_uint64 framesRead = 0; - - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - if (pNoise == NULL) { - return MA_INVALID_ARGS; - } - - /* The output buffer is allowed to be NULL. Since we aren't tracking cursors or anything we can just do nothing and pretend to be successful. */ - if (pFramesOut == NULL) { - framesRead = frameCount; - } else { - switch (pNoise->config.type) { - case ma_noise_type_white: framesRead = ma_noise_read_pcm_frames__white (pNoise, pFramesOut, frameCount); break; - case ma_noise_type_pink: framesRead = ma_noise_read_pcm_frames__pink (pNoise, pFramesOut, frameCount); break; - case ma_noise_type_brownian: framesRead = ma_noise_read_pcm_frames__brownian(pNoise, pFramesOut, frameCount); break; - default: return MA_INVALID_OPERATION; /* Unknown noise type. */ - } - } - - if (pFramesRead != NULL) { - *pFramesRead = framesRead; - } - - return MA_SUCCESS; -} -#endif /* MA_NO_GENERATION */ - - - -#ifndef MA_NO_RESOURCE_MANAGER -#ifndef MA_RESOURCE_MANAGER_PAGE_SIZE_IN_MILLISECONDS -#define MA_RESOURCE_MANAGER_PAGE_SIZE_IN_MILLISECONDS 1000 -#endif - -#ifndef MA_JOB_TYPE_RESOURCE_MANAGER_QUEUE_CAPACITY -#define MA_JOB_TYPE_RESOURCE_MANAGER_QUEUE_CAPACITY 1024 -#endif - -MA_API ma_resource_manager_pipeline_notifications ma_resource_manager_pipeline_notifications_init(void) -{ - ma_resource_manager_pipeline_notifications notifications; - - MA_ZERO_OBJECT(¬ifications); - - return notifications; -} - -static void ma_resource_manager_pipeline_notifications_signal_all_notifications(const ma_resource_manager_pipeline_notifications* pPipelineNotifications) -{ - if (pPipelineNotifications == NULL) { - return; - } - - if (pPipelineNotifications->init.pNotification) { ma_async_notification_signal(pPipelineNotifications->init.pNotification); } - if (pPipelineNotifications->done.pNotification) { ma_async_notification_signal(pPipelineNotifications->done.pNotification); } -} - -static void ma_resource_manager_pipeline_notifications_acquire_all_fences(const ma_resource_manager_pipeline_notifications* pPipelineNotifications) -{ - if (pPipelineNotifications == NULL) { - return; - } - - if (pPipelineNotifications->init.pFence != NULL) { ma_fence_acquire(pPipelineNotifications->init.pFence); } - if (pPipelineNotifications->done.pFence != NULL) { ma_fence_acquire(pPipelineNotifications->done.pFence); } -} - -static void ma_resource_manager_pipeline_notifications_release_all_fences(const ma_resource_manager_pipeline_notifications* pPipelineNotifications) -{ - if (pPipelineNotifications == NULL) { - return; - } - - if (pPipelineNotifications->init.pFence != NULL) { ma_fence_release(pPipelineNotifications->init.pFence); } - if (pPipelineNotifications->done.pFence != NULL) { ma_fence_release(pPipelineNotifications->done.pFence); } -} - - - -#ifndef MA_DEFAULT_HASH_SEED -#define MA_DEFAULT_HASH_SEED 42 -#endif - -/* MurmurHash3. Based on code from https://github.com/PeterScott/murmur3/blob/master/murmur3.c (public domain). */ -#if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #if __GNUC__ >= 7 - #pragma GCC diagnostic ignored "-Wimplicit-fallthrough" - #endif -#endif - -static MA_INLINE ma_uint32 ma_rotl32(ma_uint32 x, ma_int8 r) -{ - return (x << r) | (x >> (32 - r)); -} - -static MA_INLINE ma_uint32 ma_hash_getblock(const ma_uint32* blocks, int i) -{ - ma_uint32 block; - - /* Try silencing a sanitization warning about unaligned access by doing a memcpy() instead of assignment. */ - MA_COPY_MEMORY(&block, ma_offset_ptr(blocks, i * sizeof(block)), sizeof(block)); - - if (ma_is_little_endian()) { - return block; - } else { - return ma_swap_endian_uint32(block); - } -} - -static MA_INLINE ma_uint32 ma_hash_fmix32(ma_uint32 h) -{ - h ^= h >> 16; - h *= 0x85ebca6b; - h ^= h >> 13; - h *= 0xc2b2ae35; - h ^= h >> 16; - - return h; -} - -static ma_uint32 ma_hash_32(const void* key, int len, ma_uint32 seed) -{ - const ma_uint8* data = (const ma_uint8*)key; - const ma_uint32* blocks; - const ma_uint8* tail; - const int nblocks = len / 4; - ma_uint32 h1 = seed; - ma_uint32 c1 = 0xcc9e2d51; - ma_uint32 c2 = 0x1b873593; - ma_uint32 k1; - int i; - - blocks = (const ma_uint32 *)(data + nblocks*4); - - for(i = -nblocks; i; i++) { - k1 = ma_hash_getblock(blocks,i); - - k1 *= c1; - k1 = ma_rotl32(k1, 15); - k1 *= c2; - - h1 ^= k1; - h1 = ma_rotl32(h1, 13); - h1 = h1*5 + 0xe6546b64; - } - - - tail = (const ma_uint8*)(data + nblocks*4); - - k1 = 0; - switch(len & 3) { - case 3: k1 ^= tail[2] << 16; - case 2: k1 ^= tail[1] << 8; - case 1: k1 ^= tail[0]; - k1 *= c1; k1 = ma_rotl32(k1, 15); k1 *= c2; h1 ^= k1; - }; - - - h1 ^= len; - h1 = ma_hash_fmix32(h1); - - return h1; -} - -#if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push -#endif -/* End MurmurHash3 */ - -static ma_uint32 ma_hash_string_32(const char* str) -{ - return ma_hash_32(str, (int)strlen(str), MA_DEFAULT_HASH_SEED); -} - -static ma_uint32 ma_hash_string_w_32(const wchar_t* str) -{ - return ma_hash_32(str, (int)wcslen(str) * sizeof(*str), MA_DEFAULT_HASH_SEED); -} - - - - -/* -Basic BST Functions -*/ -static ma_result ma_resource_manager_data_buffer_node_search(ma_resource_manager* pResourceManager, ma_uint32 hashedName32, ma_resource_manager_data_buffer_node** ppDataBufferNode) -{ - ma_resource_manager_data_buffer_node* pCurrentNode; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(ppDataBufferNode != NULL); - - pCurrentNode = pResourceManager->pRootDataBufferNode; - while (pCurrentNode != NULL) { - if (hashedName32 == pCurrentNode->hashedName32) { - break; /* Found. */ - } else if (hashedName32 < pCurrentNode->hashedName32) { - pCurrentNode = pCurrentNode->pChildLo; - } else { - pCurrentNode = pCurrentNode->pChildHi; - } - } - - *ppDataBufferNode = pCurrentNode; - - if (pCurrentNode == NULL) { - return MA_DOES_NOT_EXIST; - } else { - return MA_SUCCESS; - } -} - -static ma_result ma_resource_manager_data_buffer_node_insert_point(ma_resource_manager* pResourceManager, ma_uint32 hashedName32, ma_resource_manager_data_buffer_node** ppInsertPoint) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager_data_buffer_node* pCurrentNode; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(ppInsertPoint != NULL); - - *ppInsertPoint = NULL; - - if (pResourceManager->pRootDataBufferNode == NULL) { - return MA_SUCCESS; /* No items. */ - } - - /* We need to find the node that will become the parent of the new node. If a node is found that already has the same hashed name we need to return MA_ALREADY_EXISTS. */ - pCurrentNode = pResourceManager->pRootDataBufferNode; - while (pCurrentNode != NULL) { - if (hashedName32 == pCurrentNode->hashedName32) { - result = MA_ALREADY_EXISTS; - break; - } else { - if (hashedName32 < pCurrentNode->hashedName32) { - if (pCurrentNode->pChildLo == NULL) { - result = MA_SUCCESS; - break; - } else { - pCurrentNode = pCurrentNode->pChildLo; - } - } else { - if (pCurrentNode->pChildHi == NULL) { - result = MA_SUCCESS; - break; - } else { - pCurrentNode = pCurrentNode->pChildHi; - } - } - } - } - - *ppInsertPoint = pCurrentNode; - return result; -} - -static ma_result ma_resource_manager_data_buffer_node_insert_at(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, ma_resource_manager_data_buffer_node* pInsertPoint) -{ - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - - /* The key must have been set before calling this function. */ - MA_ASSERT(pDataBufferNode->hashedName32 != 0); - - if (pInsertPoint == NULL) { - /* It's the first node. */ - pResourceManager->pRootDataBufferNode = pDataBufferNode; - } else { - /* It's not the first node. It needs to be inserted. */ - if (pDataBufferNode->hashedName32 < pInsertPoint->hashedName32) { - MA_ASSERT(pInsertPoint->pChildLo == NULL); - pInsertPoint->pChildLo = pDataBufferNode; - } else { - MA_ASSERT(pInsertPoint->pChildHi == NULL); - pInsertPoint->pChildHi = pDataBufferNode; - } - } - - pDataBufferNode->pParent = pInsertPoint; - - return MA_SUCCESS; -} - -#if 0 /* Unused for now. */ -static ma_result ma_resource_manager_data_buffer_node_insert(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - ma_result result; - ma_resource_manager_data_buffer_node* pInsertPoint; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - - result = ma_resource_manager_data_buffer_node_insert_point(pResourceManager, pDataBufferNode->hashedName32, &pInsertPoint); - if (result != MA_SUCCESS) { - return MA_INVALID_ARGS; - } - - return ma_resource_manager_data_buffer_node_insert_at(pResourceManager, pDataBufferNode, pInsertPoint); -} -#endif - -static MA_INLINE ma_resource_manager_data_buffer_node* ma_resource_manager_data_buffer_node_find_min(ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - ma_resource_manager_data_buffer_node* pCurrentNode; - - MA_ASSERT(pDataBufferNode != NULL); - - pCurrentNode = pDataBufferNode; - while (pCurrentNode->pChildLo != NULL) { - pCurrentNode = pCurrentNode->pChildLo; - } - - return pCurrentNode; -} - -static MA_INLINE ma_resource_manager_data_buffer_node* ma_resource_manager_data_buffer_node_find_max(ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - ma_resource_manager_data_buffer_node* pCurrentNode; - - MA_ASSERT(pDataBufferNode != NULL); - - pCurrentNode = pDataBufferNode; - while (pCurrentNode->pChildHi != NULL) { - pCurrentNode = pCurrentNode->pChildHi; - } - - return pCurrentNode; -} - -static MA_INLINE ma_resource_manager_data_buffer_node* ma_resource_manager_data_buffer_node_find_inorder_successor(ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - MA_ASSERT(pDataBufferNode != NULL); - MA_ASSERT(pDataBufferNode->pChildHi != NULL); - - return ma_resource_manager_data_buffer_node_find_min(pDataBufferNode->pChildHi); -} - -static MA_INLINE ma_resource_manager_data_buffer_node* ma_resource_manager_data_buffer_node_find_inorder_predecessor(ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - MA_ASSERT(pDataBufferNode != NULL); - MA_ASSERT(pDataBufferNode->pChildLo != NULL); - - return ma_resource_manager_data_buffer_node_find_max(pDataBufferNode->pChildLo); -} - -static ma_result ma_resource_manager_data_buffer_node_remove(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - - if (pDataBufferNode->pChildLo == NULL) { - if (pDataBufferNode->pChildHi == NULL) { - /* Simple case - deleting a buffer with no children. */ - if (pDataBufferNode->pParent == NULL) { - MA_ASSERT(pResourceManager->pRootDataBufferNode == pDataBufferNode); /* There is only a single buffer in the tree which should be equal to the root node. */ - pResourceManager->pRootDataBufferNode = NULL; - } else { - if (pDataBufferNode->pParent->pChildLo == pDataBufferNode) { - pDataBufferNode->pParent->pChildLo = NULL; - } else { - pDataBufferNode->pParent->pChildHi = NULL; - } - } - } else { - /* Node has one child - pChildHi != NULL. */ - pDataBufferNode->pChildHi->pParent = pDataBufferNode->pParent; - - if (pDataBufferNode->pParent == NULL) { - MA_ASSERT(pResourceManager->pRootDataBufferNode == pDataBufferNode); - pResourceManager->pRootDataBufferNode = pDataBufferNode->pChildHi; - } else { - if (pDataBufferNode->pParent->pChildLo == pDataBufferNode) { - pDataBufferNode->pParent->pChildLo = pDataBufferNode->pChildHi; - } else { - pDataBufferNode->pParent->pChildHi = pDataBufferNode->pChildHi; - } - } - } - } else { - if (pDataBufferNode->pChildHi == NULL) { - /* Node has one child - pChildLo != NULL. */ - pDataBufferNode->pChildLo->pParent = pDataBufferNode->pParent; - - if (pDataBufferNode->pParent == NULL) { - MA_ASSERT(pResourceManager->pRootDataBufferNode == pDataBufferNode); - pResourceManager->pRootDataBufferNode = pDataBufferNode->pChildLo; - } else { - if (pDataBufferNode->pParent->pChildLo == pDataBufferNode) { - pDataBufferNode->pParent->pChildLo = pDataBufferNode->pChildLo; - } else { - pDataBufferNode->pParent->pChildHi = pDataBufferNode->pChildLo; - } - } - } else { - /* Complex case - deleting a node with two children. */ - ma_resource_manager_data_buffer_node* pReplacementDataBufferNode; - - /* For now we are just going to use the in-order successor as the replacement, but we may want to try to keep this balanced by switching between the two. */ - pReplacementDataBufferNode = ma_resource_manager_data_buffer_node_find_inorder_successor(pDataBufferNode); - MA_ASSERT(pReplacementDataBufferNode != NULL); - - /* - Now that we have our replacement node we can make the change. The simple way to do this would be to just exchange the values, and then remove the replacement - node, however we track specific nodes via pointers which means we can't just swap out the values. We need to instead just change the pointers around. The - replacement node should have at most 1 child. Therefore, we can detach it in terms of our simpler cases above. What we're essentially doing is detaching the - replacement node and reinserting it into the same position as the deleted node. - */ - MA_ASSERT(pReplacementDataBufferNode->pParent != NULL); /* The replacement node should never be the root which means it should always have a parent. */ - MA_ASSERT(pReplacementDataBufferNode->pChildLo == NULL); /* Because we used in-order successor. This would be pChildHi == NULL if we used in-order predecessor. */ - - if (pReplacementDataBufferNode->pChildHi == NULL) { - if (pReplacementDataBufferNode->pParent->pChildLo == pReplacementDataBufferNode) { - pReplacementDataBufferNode->pParent->pChildLo = NULL; - } else { - pReplacementDataBufferNode->pParent->pChildHi = NULL; - } - } else { - pReplacementDataBufferNode->pChildHi->pParent = pReplacementDataBufferNode->pParent; - if (pReplacementDataBufferNode->pParent->pChildLo == pReplacementDataBufferNode) { - pReplacementDataBufferNode->pParent->pChildLo = pReplacementDataBufferNode->pChildHi; - } else { - pReplacementDataBufferNode->pParent->pChildHi = pReplacementDataBufferNode->pChildHi; - } - } - - - /* The replacement node has essentially been detached from the binary tree, so now we need to replace the old data buffer with it. The first thing to update is the parent */ - if (pDataBufferNode->pParent != NULL) { - if (pDataBufferNode->pParent->pChildLo == pDataBufferNode) { - pDataBufferNode->pParent->pChildLo = pReplacementDataBufferNode; - } else { - pDataBufferNode->pParent->pChildHi = pReplacementDataBufferNode; - } - } - - /* Now need to update the replacement node's pointers. */ - pReplacementDataBufferNode->pParent = pDataBufferNode->pParent; - pReplacementDataBufferNode->pChildLo = pDataBufferNode->pChildLo; - pReplacementDataBufferNode->pChildHi = pDataBufferNode->pChildHi; - - /* Now the children of the replacement node need to have their parent pointers updated. */ - if (pReplacementDataBufferNode->pChildLo != NULL) { - pReplacementDataBufferNode->pChildLo->pParent = pReplacementDataBufferNode; - } - if (pReplacementDataBufferNode->pChildHi != NULL) { - pReplacementDataBufferNode->pChildHi->pParent = pReplacementDataBufferNode; - } - - /* Now the root node needs to be updated. */ - if (pResourceManager->pRootDataBufferNode == pDataBufferNode) { - pResourceManager->pRootDataBufferNode = pReplacementDataBufferNode; - } - } - } - - return MA_SUCCESS; -} - -#if 0 /* Unused for now. */ -static ma_result ma_resource_manager_data_buffer_node_remove_by_key(ma_resource_manager* pResourceManager, ma_uint32 hashedName32) -{ - ma_result result; - ma_resource_manager_data_buffer_node* pDataBufferNode; - - result = ma_resource_manager_data_buffer_search(pResourceManager, hashedName32, &pDataBufferNode); - if (result != MA_SUCCESS) { - return result; /* Could not find the data buffer. */ - } - - return ma_resource_manager_data_buffer_remove(pResourceManager, pDataBufferNode); -} -#endif - -static ma_resource_manager_data_supply_type ma_resource_manager_data_buffer_node_get_data_supply_type(ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - return (ma_resource_manager_data_supply_type)c89atomic_load_i32(&pDataBufferNode->data.type); -} - -static void ma_resource_manager_data_buffer_node_set_data_supply_type(ma_resource_manager_data_buffer_node* pDataBufferNode, ma_resource_manager_data_supply_type supplyType) -{ - c89atomic_exchange_i32(&pDataBufferNode->data.type, supplyType); -} - -static ma_result ma_resource_manager_data_buffer_node_increment_ref(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, ma_uint32* pNewRefCount) -{ - ma_uint32 refCount; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - - (void)pResourceManager; - - refCount = c89atomic_fetch_add_32(&pDataBufferNode->refCount, 1) + 1; - - if (pNewRefCount != NULL) { - *pNewRefCount = refCount; - } - - return MA_SUCCESS; -} - -static ma_result ma_resource_manager_data_buffer_node_decrement_ref(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, ma_uint32* pNewRefCount) -{ - ma_uint32 refCount; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - - (void)pResourceManager; - - refCount = c89atomic_fetch_sub_32(&pDataBufferNode->refCount, 1) - 1; - - if (pNewRefCount != NULL) { - *pNewRefCount = refCount; - } - - return MA_SUCCESS; -} - -static void ma_resource_manager_data_buffer_node_free(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - - if (pDataBufferNode->isDataOwnedByResourceManager) { - if (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBufferNode) == ma_resource_manager_data_supply_type_encoded) { - ma_free((void*)pDataBufferNode->data.backend.encoded.pData, &pResourceManager->config.allocationCallbacks); - pDataBufferNode->data.backend.encoded.pData = NULL; - pDataBufferNode->data.backend.encoded.sizeInBytes = 0; - } else if (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBufferNode) == ma_resource_manager_data_supply_type_decoded) { - ma_free((void*)pDataBufferNode->data.backend.decoded.pData, &pResourceManager->config.allocationCallbacks); - pDataBufferNode->data.backend.decoded.pData = NULL; - pDataBufferNode->data.backend.decoded.totalFrameCount = 0; - } else if (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBufferNode) == ma_resource_manager_data_supply_type_decoded_paged) { - ma_paged_audio_buffer_data_uninit(&pDataBufferNode->data.backend.decodedPaged.data, &pResourceManager->config.allocationCallbacks); - } else { - /* Should never hit this if the node was successfully initialized. */ - MA_ASSERT(pDataBufferNode->result != MA_SUCCESS); - } - } - - /* The data buffer itself needs to be freed. */ - ma_free(pDataBufferNode, &pResourceManager->config.allocationCallbacks); -} - -static ma_result ma_resource_manager_data_buffer_node_result(const ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - MA_ASSERT(pDataBufferNode != NULL); - - return (ma_result)c89atomic_load_i32((ma_result*)&pDataBufferNode->result); /* Need a naughty const-cast here. */ -} - - -static ma_bool32 ma_resource_manager_is_threading_enabled(const ma_resource_manager* pResourceManager) -{ - MA_ASSERT(pResourceManager != NULL); - - return (pResourceManager->config.flags & MA_RESOURCE_MANAGER_FLAG_NO_THREADING) == 0; -} - - -typedef struct -{ - union - { - ma_async_notification_event e; - ma_async_notification_poll p; - } backend; /* Must be the first member. */ - ma_resource_manager* pResourceManager; -} ma_resource_manager_inline_notification; - -static ma_result ma_resource_manager_inline_notification_init(ma_resource_manager* pResourceManager, ma_resource_manager_inline_notification* pNotification) -{ - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pNotification != NULL); - - pNotification->pResourceManager = pResourceManager; - - if (ma_resource_manager_is_threading_enabled(pResourceManager)) { - return ma_async_notification_event_init(&pNotification->backend.e); - } else { - return ma_async_notification_poll_init(&pNotification->backend.p); - } -} - -static void ma_resource_manager_inline_notification_uninit(ma_resource_manager_inline_notification* pNotification) -{ - MA_ASSERT(pNotification != NULL); - - if (ma_resource_manager_is_threading_enabled(pNotification->pResourceManager)) { - ma_async_notification_event_uninit(&pNotification->backend.e); - } else { - /* No need to uninitialize a polling notification. */ - } -} - -static void ma_resource_manager_inline_notification_wait(ma_resource_manager_inline_notification* pNotification) -{ - MA_ASSERT(pNotification != NULL); - - if (ma_resource_manager_is_threading_enabled(pNotification->pResourceManager)) { - ma_async_notification_event_wait(&pNotification->backend.e); - } else { - while (ma_async_notification_poll_is_signalled(&pNotification->backend.p) == MA_FALSE) { - ma_result result = ma_resource_manager_process_next_job(pNotification->pResourceManager); - if (result == MA_NO_DATA_AVAILABLE || result == MA_CANCELLED) { - break; - } - } - } -} - -static void ma_resource_manager_inline_notification_wait_and_uninit(ma_resource_manager_inline_notification* pNotification) -{ - ma_resource_manager_inline_notification_wait(pNotification); - ma_resource_manager_inline_notification_uninit(pNotification); -} - - -static void ma_resource_manager_data_buffer_bst_lock(ma_resource_manager* pResourceManager) -{ - MA_ASSERT(pResourceManager != NULL); - - if (ma_resource_manager_is_threading_enabled(pResourceManager)) { - #ifndef MA_NO_THREADING - { - ma_mutex_lock(&pResourceManager->dataBufferBSTLock); - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never hit this. */ - } - #endif - } else { - /* Threading not enabled. Do nothing. */ - } -} - -static void ma_resource_manager_data_buffer_bst_unlock(ma_resource_manager* pResourceManager) -{ - MA_ASSERT(pResourceManager != NULL); - - if (ma_resource_manager_is_threading_enabled(pResourceManager)) { - #ifndef MA_NO_THREADING - { - ma_mutex_unlock(&pResourceManager->dataBufferBSTLock); - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never hit this. */ - } - #endif - } else { - /* Threading not enabled. Do nothing. */ - } -} - -#ifndef MA_NO_THREADING -static ma_thread_result MA_THREADCALL ma_resource_manager_job_thread(void* pUserData) -{ - ma_resource_manager* pResourceManager = (ma_resource_manager*)pUserData; - MA_ASSERT(pResourceManager != NULL); - - for (;;) { - ma_result result; - ma_job job; - - result = ma_resource_manager_next_job(pResourceManager, &job); - if (result != MA_SUCCESS) { - break; - } - - /* Terminate if we got a quit message. */ - if (job.toc.breakup.code == MA_JOB_TYPE_QUIT) { - break; - } - - ma_job_process(&job); - } - - return (ma_thread_result)0; -} -#endif - -MA_API ma_resource_manager_config ma_resource_manager_config_init(void) -{ - ma_resource_manager_config config; - - MA_ZERO_OBJECT(&config); - config.decodedFormat = ma_format_unknown; - config.decodedChannels = 0; - config.decodedSampleRate = 0; - config.jobThreadCount = 1; /* A single miniaudio-managed job thread by default. */ - config.jobQueueCapacity = MA_JOB_TYPE_RESOURCE_MANAGER_QUEUE_CAPACITY; - - /* Flags. */ - config.flags = 0; - #ifdef MA_NO_THREADING - { - /* Threading is disabled at compile time so disable threading at runtime as well by default. */ - config.flags |= MA_RESOURCE_MANAGER_FLAG_NO_THREADING; - config.jobThreadCount = 0; - } - #endif - - return config; -} - - -MA_API ma_result ma_resource_manager_init(const ma_resource_manager_config* pConfig, ma_resource_manager* pResourceManager) -{ - ma_result result; - ma_job_queue_config jobQueueConfig; - - if (pResourceManager == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pResourceManager); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - #ifndef MA_NO_THREADING - { - if (pConfig->jobThreadCount > ma_countof(pResourceManager->jobThreads)) { - return MA_INVALID_ARGS; /* Requesting too many job threads. */ - } - } - #endif - - pResourceManager->config = *pConfig; - ma_allocation_callbacks_init_copy(&pResourceManager->config.allocationCallbacks, &pConfig->allocationCallbacks); - - /* Get the log set up early so we can start using it as soon as possible. */ - if (pResourceManager->config.pLog == NULL) { - result = ma_log_init(&pResourceManager->config.allocationCallbacks, &pResourceManager->log); - if (result == MA_SUCCESS) { - pResourceManager->config.pLog = &pResourceManager->log; - } else { - pResourceManager->config.pLog = NULL; /* Logging is unavailable. */ - } - } - - if (pResourceManager->config.pVFS == NULL) { - result = ma_default_vfs_init(&pResourceManager->defaultVFS, &pResourceManager->config.allocationCallbacks); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the default file system. */ - } - - pResourceManager->config.pVFS = &pResourceManager->defaultVFS; - } - - /* If threading has been disabled at compile time, enfore it at run time as well. */ - #ifdef MA_NO_THREADING - { - pResourceManager->config.flags |= MA_RESOURCE_MANAGER_FLAG_NO_THREADING; - } - #endif - - /* We need to force MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING if MA_RESOURCE_MANAGER_FLAG_NO_THREADING is set. */ - if ((pResourceManager->config.flags & MA_RESOURCE_MANAGER_FLAG_NO_THREADING) != 0) { - pResourceManager->config.flags |= MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING; - - /* We cannot allow job threads when MA_RESOURCE_MANAGER_FLAG_NO_THREADING has been set. This is an invalid use case. */ - if (pResourceManager->config.jobThreadCount > 0) { - return MA_INVALID_ARGS; - } - } - - /* Job queue. */ - jobQueueConfig.capacity = pResourceManager->config.jobQueueCapacity; - jobQueueConfig.flags = 0; - if ((pResourceManager->config.flags & MA_RESOURCE_MANAGER_FLAG_NON_BLOCKING) != 0) { - if (pResourceManager->config.jobThreadCount > 0) { - return MA_INVALID_ARGS; /* Non-blocking mode is only valid for self-managed job threads. */ - } - - jobQueueConfig.flags |= MA_JOB_QUEUE_FLAG_NON_BLOCKING; - } - - result = ma_job_queue_init(&jobQueueConfig, &pResourceManager->config.allocationCallbacks, &pResourceManager->jobQueue); - if (result != MA_SUCCESS) { - return result; - } - - - /* Custom decoding backends. */ - if (pConfig->ppCustomDecodingBackendVTables != NULL && pConfig->customDecodingBackendCount > 0) { - size_t sizeInBytes = sizeof(*pResourceManager->config.ppCustomDecodingBackendVTables) * pConfig->customDecodingBackendCount; - - pResourceManager->config.ppCustomDecodingBackendVTables = (ma_decoding_backend_vtable**)ma_malloc(sizeInBytes, &pResourceManager->config.allocationCallbacks); - if (pResourceManager->config.ppCustomDecodingBackendVTables == NULL) { - ma_job_queue_uninit(&pResourceManager->jobQueue, &pResourceManager->config.allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - MA_COPY_MEMORY(pResourceManager->config.ppCustomDecodingBackendVTables, pConfig->ppCustomDecodingBackendVTables, sizeInBytes); - - pResourceManager->config.customDecodingBackendCount = pConfig->customDecodingBackendCount; - pResourceManager->config.pCustomDecodingBackendUserData = pConfig->pCustomDecodingBackendUserData; - } - - - - /* Here is where we initialize our threading stuff. We don't do this if we don't support threading. */ - if (ma_resource_manager_is_threading_enabled(pResourceManager)) { - #ifndef MA_NO_THREADING - { - ma_uint32 iJobThread; - - /* Data buffer lock. */ - result = ma_mutex_init(&pResourceManager->dataBufferBSTLock); - if (result != MA_SUCCESS) { - ma_job_queue_uninit(&pResourceManager->jobQueue, &pResourceManager->config.allocationCallbacks); - return result; - } - - /* Create the job threads last to ensure the threads has access to valid data. */ - for (iJobThread = 0; iJobThread < pResourceManager->config.jobThreadCount; iJobThread += 1) { - result = ma_thread_create(&pResourceManager->jobThreads[iJobThread], ma_thread_priority_normal, pResourceManager->config.jobThreadStackSize, ma_resource_manager_job_thread, pResourceManager, &pResourceManager->config.allocationCallbacks); - if (result != MA_SUCCESS) { - ma_mutex_uninit(&pResourceManager->dataBufferBSTLock); - ma_job_queue_uninit(&pResourceManager->jobQueue, &pResourceManager->config.allocationCallbacks); - return result; - } - } - } - #else - { - /* Threading is disabled at compile time. We should never get here because validation checks should have already been performed. */ - MA_ASSERT(MA_FALSE); - } - #endif - } - - return MA_SUCCESS; -} - - -static void ma_resource_manager_delete_all_data_buffer_nodes(ma_resource_manager* pResourceManager) -{ - MA_ASSERT(pResourceManager); - - /* If everything was done properly, there shouldn't be any active data buffers. */ - while (pResourceManager->pRootDataBufferNode != NULL) { - ma_resource_manager_data_buffer_node* pDataBufferNode = pResourceManager->pRootDataBufferNode; - ma_resource_manager_data_buffer_node_remove(pResourceManager, pDataBufferNode); - - /* The data buffer has been removed from the BST, so now we need to free it's data. */ - ma_resource_manager_data_buffer_node_free(pResourceManager, pDataBufferNode); - } -} - -MA_API void ma_resource_manager_uninit(ma_resource_manager* pResourceManager) -{ - if (pResourceManager == NULL) { - return; - } - - /* - Job threads need to be killed first. To do this we need to post a quit message to the message queue and then wait for the thread. The quit message will never be removed from the - queue which means it will never not be returned after being encounted for the first time which means all threads will eventually receive it. - */ - ma_resource_manager_post_job_quit(pResourceManager); - - /* Wait for every job to finish before continuing to ensure nothing is sill trying to access any of our objects below. */ - if (ma_resource_manager_is_threading_enabled(pResourceManager)) { - #ifndef MA_NO_THREADING - { - ma_uint32 iJobThread; - - for (iJobThread = 0; iJobThread < pResourceManager->config.jobThreadCount; iJobThread += 1) { - ma_thread_wait(&pResourceManager->jobThreads[iJobThread]); - } - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never hit this. */ - } - #endif - } - - /* At this point the thread should have returned and no other thread should be accessing our data. We can now delete all data buffers. */ - ma_resource_manager_delete_all_data_buffer_nodes(pResourceManager); - - /* The job queue is no longer needed. */ - ma_job_queue_uninit(&pResourceManager->jobQueue, &pResourceManager->config.allocationCallbacks); - - /* We're no longer doing anything with data buffers so the lock can now be uninitialized. */ - if (ma_resource_manager_is_threading_enabled(pResourceManager)) { - #ifndef MA_NO_THREADING - { - ma_mutex_uninit(&pResourceManager->dataBufferBSTLock); - } - #else - { - MA_ASSERT(MA_FALSE); /* Should never hit this. */ - } - #endif - } - - ma_free(pResourceManager->config.ppCustomDecodingBackendVTables, &pResourceManager->config.allocationCallbacks); - - if (pResourceManager->config.pLog == &pResourceManager->log) { - ma_log_uninit(&pResourceManager->log); - } -} - -MA_API ma_log* ma_resource_manager_get_log(ma_resource_manager* pResourceManager) -{ - if (pResourceManager == NULL) { - return NULL; - } - - return pResourceManager->config.pLog; -} - - - -MA_API ma_resource_manager_data_source_config ma_resource_manager_data_source_config_init(void) -{ - ma_resource_manager_data_source_config config; - - MA_ZERO_OBJECT(&config); - config.rangeBegInPCMFrames = MA_DATA_SOURCE_DEFAULT_RANGE_BEG; - config.rangeEndInPCMFrames = MA_DATA_SOURCE_DEFAULT_RANGE_END; - config.loopPointBegInPCMFrames = MA_DATA_SOURCE_DEFAULT_LOOP_POINT_BEG; - config.loopPointEndInPCMFrames = MA_DATA_SOURCE_DEFAULT_LOOP_POINT_END; - config.isLooping = MA_FALSE; - - return config; -} - - -static ma_decoder_config ma_resource_manager__init_decoder_config(ma_resource_manager* pResourceManager) -{ - ma_decoder_config config; - - config = ma_decoder_config_init(pResourceManager->config.decodedFormat, pResourceManager->config.decodedChannels, pResourceManager->config.decodedSampleRate); - config.allocationCallbacks = pResourceManager->config.allocationCallbacks; - config.ppCustomBackendVTables = pResourceManager->config.ppCustomDecodingBackendVTables; - config.customBackendCount = pResourceManager->config.customDecodingBackendCount; - config.pCustomBackendUserData = pResourceManager->config.pCustomDecodingBackendUserData; - - return config; -} - -static ma_result ma_resource_manager__init_decoder(ma_resource_manager* pResourceManager, const char* pFilePath, const wchar_t* pFilePathW, ma_decoder* pDecoder) -{ - ma_result result; - ma_decoder_config config; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pFilePath != NULL || pFilePathW != NULL); - MA_ASSERT(pDecoder != NULL); - - config = ma_resource_manager__init_decoder_config(pResourceManager); - - if (pFilePath != NULL) { - result = ma_decoder_init_vfs(pResourceManager->config.pVFS, pFilePath, &config, pDecoder); - if (result != MA_SUCCESS) { - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Failed to load file \"%s\". %s.\n", pFilePath, ma_result_description(result)); - return result; - } - } else { - result = ma_decoder_init_vfs_w(pResourceManager->config.pVFS, pFilePathW, &config, pDecoder); - if (result != MA_SUCCESS) { - #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(_MSC_VER) - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Failed to load file \"%ls\". %s.\n", pFilePathW, ma_result_description(result)); - #endif - return result; - } - } - - return MA_SUCCESS; -} - -static ma_bool32 ma_resource_manager_data_buffer_has_connector(ma_resource_manager_data_buffer* pDataBuffer) -{ - return ma_atomic_bool32_get(&pDataBuffer->isConnectorInitialized); -} - -static ma_data_source* ma_resource_manager_data_buffer_get_connector(ma_resource_manager_data_buffer* pDataBuffer) -{ - if (ma_resource_manager_data_buffer_has_connector(pDataBuffer) == MA_FALSE) { - return NULL; /* Connector not yet initialized. */ - } - - switch (pDataBuffer->pNode->data.type) - { - case ma_resource_manager_data_supply_type_encoded: return &pDataBuffer->connector.decoder; - case ma_resource_manager_data_supply_type_decoded: return &pDataBuffer->connector.buffer; - case ma_resource_manager_data_supply_type_decoded_paged: return &pDataBuffer->connector.pagedBuffer; - - case ma_resource_manager_data_supply_type_unknown: - default: - { - ma_log_postf(ma_resource_manager_get_log(pDataBuffer->pResourceManager), MA_LOG_LEVEL_ERROR, "Failed to retrieve data buffer connector. Unknown data supply type.\n"); - return NULL; - }; - }; -} - -static ma_result ma_resource_manager_data_buffer_init_connector(ma_resource_manager_data_buffer* pDataBuffer, const ma_resource_manager_data_source_config* pConfig, ma_async_notification* pInitNotification, ma_fence* pInitFence) -{ - ma_result result; - - MA_ASSERT(pDataBuffer != NULL); - MA_ASSERT(pConfig != NULL); - MA_ASSERT(ma_resource_manager_data_buffer_has_connector(pDataBuffer) == MA_FALSE); - - /* The underlying data buffer must be initialized before we'll be able to know how to initialize the backend. */ - result = ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode); - if (result != MA_SUCCESS && result != MA_BUSY) { - return result; /* The data buffer is in an erroneous state. */ - } - - /* - We need to initialize either a ma_decoder or an ma_audio_buffer depending on whether or not the backing data is encoded or decoded. These act as the - "instance" to the data and are used to form the connection between underlying data buffer and the data source. If the data buffer is decoded, we can use - an ma_audio_buffer. This enables us to use memory mapping when mixing which saves us a bit of data movement overhead. - */ - switch (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode)) - { - case ma_resource_manager_data_supply_type_encoded: /* Connector is a decoder. */ - { - ma_decoder_config config; - config = ma_resource_manager__init_decoder_config(pDataBuffer->pResourceManager); - result = ma_decoder_init_memory(pDataBuffer->pNode->data.backend.encoded.pData, pDataBuffer->pNode->data.backend.encoded.sizeInBytes, &config, &pDataBuffer->connector.decoder); - } break; - - case ma_resource_manager_data_supply_type_decoded: /* Connector is an audio buffer. */ - { - ma_audio_buffer_config config; - config = ma_audio_buffer_config_init(pDataBuffer->pNode->data.backend.decoded.format, pDataBuffer->pNode->data.backend.decoded.channels, pDataBuffer->pNode->data.backend.decoded.totalFrameCount, pDataBuffer->pNode->data.backend.decoded.pData, NULL); - result = ma_audio_buffer_init(&config, &pDataBuffer->connector.buffer); - } break; - - case ma_resource_manager_data_supply_type_decoded_paged: /* Connector is a paged audio buffer. */ - { - ma_paged_audio_buffer_config config; - config = ma_paged_audio_buffer_config_init(&pDataBuffer->pNode->data.backend.decodedPaged.data); - result = ma_paged_audio_buffer_init(&config, &pDataBuffer->connector.pagedBuffer); - } break; - - case ma_resource_manager_data_supply_type_unknown: - default: - { - /* Unknown data supply type. Should never happen. Need to post an error here. */ - return MA_INVALID_ARGS; - }; - } - - /* - Initialization of the connector is when we can fire the init notification. This will give the application access to - the format/channels/rate of the data source. - */ - if (result == MA_SUCCESS) { - /* - The resource manager supports the ability to set the range and loop settings via a config at - initialization time. This results in an case where the ranges could be set explicitly via - ma_data_source_set_*() before we get to this point here. If this happens, we'll end up - hitting a case where we just override those settings which results in what feels like a bug. - - To address this we only change the relevant properties if they're not equal to defaults. If - they're equal to defaults there's no need to change them anyway. If they're *not* set to the - default values, we can assume the user has set the range and loop settings via the config. If - they're doing their own calls to ma_data_source_set_*() in addition to setting them via the - config, that's entirely on the caller and any synchronization issue becomes their problem. - */ - if (pConfig->rangeBegInPCMFrames != MA_DATA_SOURCE_DEFAULT_RANGE_BEG || pConfig->rangeEndInPCMFrames != MA_DATA_SOURCE_DEFAULT_RANGE_END) { - ma_data_source_set_range_in_pcm_frames(pDataBuffer, pConfig->rangeBegInPCMFrames, pConfig->rangeEndInPCMFrames); - } - - if (pConfig->loopPointBegInPCMFrames != MA_DATA_SOURCE_DEFAULT_LOOP_POINT_BEG || pConfig->loopPointEndInPCMFrames != MA_DATA_SOURCE_DEFAULT_LOOP_POINT_END) { - ma_data_source_set_loop_point_in_pcm_frames(pDataBuffer, pConfig->loopPointBegInPCMFrames, pConfig->loopPointEndInPCMFrames); - } - - if (pConfig->isLooping != MA_FALSE) { - ma_data_source_set_looping(pDataBuffer, pConfig->isLooping); - } - - ma_atomic_bool32_set(&pDataBuffer->isConnectorInitialized, MA_TRUE); - - if (pInitNotification != NULL) { - ma_async_notification_signal(pInitNotification); - } - - if (pInitFence != NULL) { - ma_fence_release(pInitFence); - } - } - - /* At this point the backend should be initialized. We do *not* want to set pDataSource->result here - that needs to be done at a higher level to ensure it's done as the last step. */ - return result; -} - -static ma_result ma_resource_manager_data_buffer_uninit_connector(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer* pDataBuffer) -{ - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBuffer != NULL); - - (void)pResourceManager; - - switch (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode)) - { - case ma_resource_manager_data_supply_type_encoded: /* Connector is a decoder. */ - { - ma_decoder_uninit(&pDataBuffer->connector.decoder); - } break; - - case ma_resource_manager_data_supply_type_decoded: /* Connector is an audio buffer. */ - { - ma_audio_buffer_uninit(&pDataBuffer->connector.buffer); - } break; - - case ma_resource_manager_data_supply_type_decoded_paged: /* Connector is a paged audio buffer. */ - { - ma_paged_audio_buffer_uninit(&pDataBuffer->connector.pagedBuffer); - } break; - - case ma_resource_manager_data_supply_type_unknown: - default: - { - /* Unknown data supply type. Should never happen. Need to post an error here. */ - return MA_INVALID_ARGS; - }; - } - - return MA_SUCCESS; -} - -static ma_uint32 ma_resource_manager_data_buffer_node_next_execution_order(ma_resource_manager_data_buffer_node* pDataBufferNode) -{ - MA_ASSERT(pDataBufferNode != NULL); - return c89atomic_fetch_add_32(&pDataBufferNode->executionCounter, 1); -} - -static ma_result ma_resource_manager_data_buffer_node_init_supply_encoded(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, const char* pFilePath, const wchar_t* pFilePathW) -{ - ma_result result; - size_t dataSizeInBytes; - void* pData; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - MA_ASSERT(pFilePath != NULL || pFilePathW != NULL); - - result = ma_vfs_open_and_read_file_ex(pResourceManager->config.pVFS, pFilePath, pFilePathW, &pData, &dataSizeInBytes, &pResourceManager->config.allocationCallbacks); - if (result != MA_SUCCESS) { - if (pFilePath != NULL) { - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Failed to load file \"%s\". %s.\n", pFilePath, ma_result_description(result)); - } else { - #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(_MSC_VER) - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Failed to load file \"%ls\". %s.\n", pFilePathW, ma_result_description(result)); - #endif - } - - return result; - } - - pDataBufferNode->data.backend.encoded.pData = pData; - pDataBufferNode->data.backend.encoded.sizeInBytes = dataSizeInBytes; - ma_resource_manager_data_buffer_node_set_data_supply_type(pDataBufferNode, ma_resource_manager_data_supply_type_encoded); /* <-- Must be set last. */ - - return MA_SUCCESS; -} - -static ma_result ma_resource_manager_data_buffer_node_init_supply_decoded(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, const char* pFilePath, const wchar_t* pFilePathW, ma_uint32 flags, ma_decoder** ppDecoder) -{ - ma_result result = MA_SUCCESS; - ma_decoder* pDecoder; - ma_uint64 totalFrameCount; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - MA_ASSERT(ppDecoder != NULL); - MA_ASSERT(pFilePath != NULL || pFilePathW != NULL); - - *ppDecoder = NULL; /* For safety. */ - - pDecoder = (ma_decoder*)ma_malloc(sizeof(*pDecoder), &pResourceManager->config.allocationCallbacks); - if (pDecoder == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_resource_manager__init_decoder(pResourceManager, pFilePath, pFilePathW, pDecoder); - if (result != MA_SUCCESS) { - ma_free(pDecoder, &pResourceManager->config.allocationCallbacks); - return result; - } - - /* - At this point we have the decoder and we now need to initialize the data supply. This will - be either a decoded buffer, or a decoded paged buffer. A regular buffer is just one big heap - allocated buffer, whereas a paged buffer is a linked list of paged-sized buffers. The latter - is used when the length of a sound is unknown until a full decode has been performed. - */ - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_UNKNOWN_LENGTH) == 0) { - result = ma_decoder_get_length_in_pcm_frames(pDecoder, &totalFrameCount); - if (result != MA_SUCCESS) { - return result; - } - } else { - totalFrameCount = 0; - } - - if (totalFrameCount > 0) { - /* It's a known length. The data supply is a regular decoded buffer. */ - ma_uint64 dataSizeInBytes; - void* pData; - - dataSizeInBytes = totalFrameCount * ma_get_bytes_per_frame(pDecoder->outputFormat, pDecoder->outputChannels); - if (dataSizeInBytes > MA_SIZE_MAX) { - ma_decoder_uninit(pDecoder); - ma_free(pDecoder, &pResourceManager->config.allocationCallbacks); - return MA_TOO_BIG; - } - - pData = ma_malloc((size_t)dataSizeInBytes, &pResourceManager->config.allocationCallbacks); - if (pData == NULL) { - ma_decoder_uninit(pDecoder); - ma_free(pDecoder, &pResourceManager->config.allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - /* The buffer needs to be initialized to silence in case the caller reads from it. */ - ma_silence_pcm_frames(pData, totalFrameCount, pDecoder->outputFormat, pDecoder->outputChannels); - - /* Data has been allocated and the data supply can now be initialized. */ - pDataBufferNode->data.backend.decoded.pData = pData; - pDataBufferNode->data.backend.decoded.totalFrameCount = totalFrameCount; - pDataBufferNode->data.backend.decoded.format = pDecoder->outputFormat; - pDataBufferNode->data.backend.decoded.channels = pDecoder->outputChannels; - pDataBufferNode->data.backend.decoded.sampleRate = pDecoder->outputSampleRate; - pDataBufferNode->data.backend.decoded.decodedFrameCount = 0; - ma_resource_manager_data_buffer_node_set_data_supply_type(pDataBufferNode, ma_resource_manager_data_supply_type_decoded); /* <-- Must be set last. */ - } else { - /* - It's an unknown length. The data supply is a paged decoded buffer. Setting this up is - actually easier than the non-paged decoded buffer because we just need to initialize - a ma_paged_audio_buffer object. - */ - result = ma_paged_audio_buffer_data_init(pDecoder->outputFormat, pDecoder->outputChannels, &pDataBufferNode->data.backend.decodedPaged.data); - if (result != MA_SUCCESS) { - ma_decoder_uninit(pDecoder); - ma_free(pDecoder, &pResourceManager->config.allocationCallbacks); - return result; - } - - pDataBufferNode->data.backend.decodedPaged.sampleRate = pDecoder->outputSampleRate; - pDataBufferNode->data.backend.decodedPaged.decodedFrameCount = 0; - ma_resource_manager_data_buffer_node_set_data_supply_type(pDataBufferNode, ma_resource_manager_data_supply_type_decoded_paged); /* <-- Must be set last. */ - } - - *ppDecoder = pDecoder; - - return MA_SUCCESS; -} - -static ma_result ma_resource_manager_data_buffer_node_decode_next_page(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, ma_decoder* pDecoder) -{ - ma_result result = MA_SUCCESS; - ma_uint64 pageSizeInFrames; - ma_uint64 framesToTryReading; - ma_uint64 framesRead; - - MA_ASSERT(pResourceManager != NULL); - MA_ASSERT(pDataBufferNode != NULL); - MA_ASSERT(pDecoder != NULL); - - /* We need to know the size of a page in frames to know how many frames to decode. */ - pageSizeInFrames = MA_RESOURCE_MANAGER_PAGE_SIZE_IN_MILLISECONDS * (pDecoder->outputSampleRate/1000); - framesToTryReading = pageSizeInFrames; - - /* - Here is where we do the decoding of the next page. We'll run a slightly different path depending - on whether or not we're using a flat or paged buffer because the allocation of the page differs - between the two. For a flat buffer it's an offset to an already-allocated buffer. For a paged - buffer, we need to allocate a new page and attach it to the linked list. - */ - switch (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBufferNode)) - { - case ma_resource_manager_data_supply_type_decoded: - { - /* The destination buffer is an offset to the existing buffer. Don't read more than we originally retrieved when we first initialized the decoder. */ - void* pDst; - ma_uint64 framesRemaining = pDataBufferNode->data.backend.decoded.totalFrameCount - pDataBufferNode->data.backend.decoded.decodedFrameCount; - if (framesToTryReading > framesRemaining) { - framesToTryReading = framesRemaining; - } - - if (framesToTryReading > 0) { - pDst = ma_offset_ptr( - pDataBufferNode->data.backend.decoded.pData, - pDataBufferNode->data.backend.decoded.decodedFrameCount * ma_get_bytes_per_frame(pDataBufferNode->data.backend.decoded.format, pDataBufferNode->data.backend.decoded.channels) - ); - MA_ASSERT(pDst != NULL); - - result = ma_decoder_read_pcm_frames(pDecoder, pDst, framesToTryReading, &framesRead); - if (framesRead > 0) { - pDataBufferNode->data.backend.decoded.decodedFrameCount += framesRead; - } - } else { - framesRead = 0; - } - } break; - - case ma_resource_manager_data_supply_type_decoded_paged: - { - /* The destination buffer is a freshly allocated page. */ - ma_paged_audio_buffer_page* pPage; - - result = ma_paged_audio_buffer_data_allocate_page(&pDataBufferNode->data.backend.decodedPaged.data, framesToTryReading, NULL, &pResourceManager->config.allocationCallbacks, &pPage); - if (result != MA_SUCCESS) { - return result; - } - - result = ma_decoder_read_pcm_frames(pDecoder, pPage->pAudioData, framesToTryReading, &framesRead); - if (framesRead > 0) { - pPage->sizeInFrames = framesRead; - - result = ma_paged_audio_buffer_data_append_page(&pDataBufferNode->data.backend.decodedPaged.data, pPage); - if (result == MA_SUCCESS) { - pDataBufferNode->data.backend.decodedPaged.decodedFrameCount += framesRead; - } else { - /* Failed to append the page. Just abort and set the status to MA_AT_END. */ - ma_paged_audio_buffer_data_free_page(&pDataBufferNode->data.backend.decodedPaged.data, pPage, &pResourceManager->config.allocationCallbacks); - result = MA_AT_END; - } - } else { - /* No frames were read. Free the page and just set the status to MA_AT_END. */ - ma_paged_audio_buffer_data_free_page(&pDataBufferNode->data.backend.decodedPaged.data, pPage, &pResourceManager->config.allocationCallbacks); - result = MA_AT_END; - } - } break; - - case ma_resource_manager_data_supply_type_encoded: - case ma_resource_manager_data_supply_type_unknown: - default: - { - /* Unexpected data supply type. */ - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_ERROR, "Unexpected data supply type (%d) when decoding page.", ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBufferNode)); - return MA_ERROR; - }; - } - - if (result == MA_SUCCESS && framesRead == 0) { - result = MA_AT_END; - } - - return result; -} - -static ma_result ma_resource_manager_data_buffer_node_acquire_critical_section(ma_resource_manager* pResourceManager, const char* pFilePath, const wchar_t* pFilePathW, ma_uint32 hashedName32, ma_uint32 flags, const ma_resource_manager_data_supply* pExistingData, ma_fence* pInitFence, ma_fence* pDoneFence, ma_resource_manager_inline_notification* pInitNotification, ma_resource_manager_data_buffer_node** ppDataBufferNode) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager_data_buffer_node* pDataBufferNode = NULL; - ma_resource_manager_data_buffer_node* pInsertPoint; - - if (ppDataBufferNode != NULL) { - *ppDataBufferNode = NULL; - } - - result = ma_resource_manager_data_buffer_node_insert_point(pResourceManager, hashedName32, &pInsertPoint); - if (result == MA_ALREADY_EXISTS) { - /* The node already exists. We just need to increment the reference count. */ - pDataBufferNode = pInsertPoint; - - result = ma_resource_manager_data_buffer_node_increment_ref(pResourceManager, pDataBufferNode, NULL); - if (result != MA_SUCCESS) { - return result; /* Should never happen. Failed to increment the reference count. */ - } - - result = MA_ALREADY_EXISTS; - goto done; - } else { - /* - The node does not already exist. We need to post a LOAD_DATA_BUFFER_NODE job here. This - needs to be done inside the critical section to ensure an uninitialization of the node - does not occur before initialization on another thread. - */ - pDataBufferNode = (ma_resource_manager_data_buffer_node*)ma_malloc(sizeof(*pDataBufferNode), &pResourceManager->config.allocationCallbacks); - if (pDataBufferNode == NULL) { - return MA_OUT_OF_MEMORY; - } - - MA_ZERO_OBJECT(pDataBufferNode); - pDataBufferNode->hashedName32 = hashedName32; - pDataBufferNode->refCount = 1; /* Always set to 1 by default (this is our first reference). */ - - if (pExistingData == NULL) { - pDataBufferNode->data.type = ma_resource_manager_data_supply_type_unknown; /* <-- We won't know this until we start decoding. */ - pDataBufferNode->result = MA_BUSY; /* Must be set to MA_BUSY before we leave the critical section, so might as well do it now. */ - pDataBufferNode->isDataOwnedByResourceManager = MA_TRUE; - } else { - pDataBufferNode->data = *pExistingData; - pDataBufferNode->result = MA_SUCCESS; /* Not loading asynchronously, so just set the status */ - pDataBufferNode->isDataOwnedByResourceManager = MA_FALSE; - } - - result = ma_resource_manager_data_buffer_node_insert_at(pResourceManager, pDataBufferNode, pInsertPoint); - if (result != MA_SUCCESS) { - ma_free(pDataBufferNode, &pResourceManager->config.allocationCallbacks); - return result; /* Should never happen. Failed to insert the data buffer into the BST. */ - } - - /* - Here is where we'll post the job, but only if we're loading asynchronously. If we're - loading synchronously we'll defer loading to a later stage, outside of the critical - section. - */ - if (pDataBufferNode->isDataOwnedByResourceManager && (flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC) != 0) { - /* Loading asynchronously. Post the job. */ - ma_job job; - char* pFilePathCopy = NULL; - wchar_t* pFilePathWCopy = NULL; - - /* We need a copy of the file path. We should probably make this more efficient, but for now we'll do a transient memory allocation. */ - if (pFilePath != NULL) { - pFilePathCopy = ma_copy_string(pFilePath, &pResourceManager->config.allocationCallbacks); - } else { - pFilePathWCopy = ma_copy_string_w(pFilePathW, &pResourceManager->config.allocationCallbacks); - } - - if (pFilePathCopy == NULL && pFilePathWCopy == NULL) { - ma_resource_manager_data_buffer_node_remove(pResourceManager, pDataBufferNode); - ma_free(pDataBufferNode, &pResourceManager->config.allocationCallbacks); - return MA_OUT_OF_MEMORY; - } - - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_init(pResourceManager, pInitNotification); - } - - /* Acquire init and done fences before posting the job. These will be unacquired by the job thread. */ - if (pInitFence != NULL) { ma_fence_acquire(pInitFence); } - if (pDoneFence != NULL) { ma_fence_acquire(pDoneFence); } - - /* We now have everything we need to post the job to the job thread. */ - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER_NODE); - job.order = ma_resource_manager_data_buffer_node_next_execution_order(pDataBufferNode); - job.data.resourceManager.loadDataBufferNode.pResourceManager = pResourceManager; - job.data.resourceManager.loadDataBufferNode.pDataBufferNode = pDataBufferNode; - job.data.resourceManager.loadDataBufferNode.pFilePath = pFilePathCopy; - job.data.resourceManager.loadDataBufferNode.pFilePathW = pFilePathWCopy; - job.data.resourceManager.loadDataBufferNode.flags = flags; - job.data.resourceManager.loadDataBufferNode.pInitNotification = ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) ? pInitNotification : NULL; - job.data.resourceManager.loadDataBufferNode.pDoneNotification = NULL; - job.data.resourceManager.loadDataBufferNode.pInitFence = pInitFence; - job.data.resourceManager.loadDataBufferNode.pDoneFence = pDoneFence; - - result = ma_resource_manager_post_job(pResourceManager, &job); - if (result != MA_SUCCESS) { - /* Failed to post job. Probably ran out of memory. */ - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_ERROR, "Failed to post MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER_NODE job. %s.\n", ma_result_description(result)); - - /* - Fences were acquired before posting the job, but since the job was not able to - be posted, we need to make sure we release them so nothing gets stuck waiting. - */ - if (pInitFence != NULL) { ma_fence_release(pInitFence); } - if (pDoneFence != NULL) { ma_fence_release(pDoneFence); } - - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_init(pResourceManager, pInitNotification); - } - - ma_free(pFilePathCopy, &pResourceManager->config.allocationCallbacks); - ma_free(pFilePathWCopy, &pResourceManager->config.allocationCallbacks); - - ma_resource_manager_data_buffer_node_remove(pResourceManager, pDataBufferNode); - ma_free(pDataBufferNode, &pResourceManager->config.allocationCallbacks); - - return result; - } - } - } - -done: - if (ppDataBufferNode != NULL) { - *ppDataBufferNode = pDataBufferNode; - } - - return result; -} - -static ma_result ma_resource_manager_data_buffer_node_acquire(ma_resource_manager* pResourceManager, const char* pFilePath, const wchar_t* pFilePathW, ma_uint32 hashedName32, ma_uint32 flags, const ma_resource_manager_data_supply* pExistingData, ma_fence* pInitFence, ma_fence* pDoneFence, ma_resource_manager_data_buffer_node** ppDataBufferNode) -{ - ma_result result = MA_SUCCESS; - ma_bool32 nodeAlreadyExists = MA_FALSE; - ma_resource_manager_data_buffer_node* pDataBufferNode = NULL; - ma_resource_manager_inline_notification initNotification; /* Used when the WAIT_INIT flag is set. */ - - if (ppDataBufferNode != NULL) { - *ppDataBufferNode = NULL; /* Safety. */ - } - - if (pResourceManager == NULL || (pFilePath == NULL && pFilePathW == NULL && hashedName32 == 0)) { - return MA_INVALID_ARGS; - } - - /* If we're specifying existing data, it must be valid. */ - if (pExistingData != NULL && pExistingData->type == ma_resource_manager_data_supply_type_unknown) { - return MA_INVALID_ARGS; - } - - /* If we don't support threading, remove the ASYNC flag to make the rest of this a bit simpler. */ - if (ma_resource_manager_is_threading_enabled(pResourceManager) == MA_FALSE) { - flags &= ~MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC; - } - - if (hashedName32 == 0) { - if (pFilePath != NULL) { - hashedName32 = ma_hash_string_32(pFilePath); - } else { - hashedName32 = ma_hash_string_w_32(pFilePathW); - } - } - - /* - Here is where we either increment the node's reference count or allocate a new one and add it - to the BST. When allocating a new node, we need to make sure the LOAD_DATA_BUFFER_NODE job is - posted inside the critical section just in case the caller immediately uninitializes the node - as this will ensure the FREE_DATA_BUFFER_NODE job is given an execution order such that the - node is not uninitialized before initialization. - */ - ma_resource_manager_data_buffer_bst_lock(pResourceManager); - { - result = ma_resource_manager_data_buffer_node_acquire_critical_section(pResourceManager, pFilePath, pFilePathW, hashedName32, flags, pExistingData, pInitFence, pDoneFence, &initNotification, &pDataBufferNode); - } - ma_resource_manager_data_buffer_bst_unlock(pResourceManager); - - if (result == MA_ALREADY_EXISTS) { - nodeAlreadyExists = MA_TRUE; - result = MA_SUCCESS; - } else { - if (result != MA_SUCCESS) { - return result; - } - } - - /* - If we're loading synchronously, we'll need to load everything now. When loading asynchronously, - a job will have been posted inside the BST critical section so that an uninitialization can be - allocated an appropriate execution order thereby preventing it from being uninitialized before - the node is initialized by the decoding thread(s). - */ - if (nodeAlreadyExists == MA_FALSE) { /* Don't need to try loading anything if the node already exists. */ - if (pFilePath == NULL && pFilePathW == NULL) { - /* - If this path is hit, it means a buffer is being copied (i.e. initialized from only the - hashed name), but that node has been freed in the meantime, probably from some other - thread. This is an invalid operation. - */ - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Cloning data buffer node failed because the source node was released. The source node must remain valid until the cloning has completed.\n"); - result = MA_INVALID_OPERATION; - goto done; - } - - if (pDataBufferNode->isDataOwnedByResourceManager) { - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC) == 0) { - /* Loading synchronously. Load the sound in it's entirety here. */ - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE) == 0) { - /* No decoding. This is the simple case - just store the file contents in memory. */ - result = ma_resource_manager_data_buffer_node_init_supply_encoded(pResourceManager, pDataBufferNode, pFilePath, pFilePathW); - if (result != MA_SUCCESS) { - goto done; - } - } else { - /* Decoding. We do this the same way as we do when loading asynchronously. */ - ma_decoder* pDecoder; - result = ma_resource_manager_data_buffer_node_init_supply_decoded(pResourceManager, pDataBufferNode, pFilePath, pFilePathW, flags, &pDecoder); - if (result != MA_SUCCESS) { - goto done; - } - - /* We have the decoder, now decode page by page just like we do when loading asynchronously. */ - for (;;) { - /* Decode next page. */ - result = ma_resource_manager_data_buffer_node_decode_next_page(pResourceManager, pDataBufferNode, pDecoder); - if (result != MA_SUCCESS) { - break; /* Will return MA_AT_END when the last page has been decoded. */ - } - } - - /* Reaching the end needs to be considered successful. */ - if (result == MA_AT_END) { - result = MA_SUCCESS; - } - - /* - At this point the data buffer is either fully decoded or some error occurred. Either - way, the decoder is no longer necessary. - */ - ma_decoder_uninit(pDecoder); - ma_free(pDecoder, &pResourceManager->config.allocationCallbacks); - } - - /* Getting here means we were successful. Make sure the status of the node is updated accordingly. */ - c89atomic_exchange_i32(&pDataBufferNode->result, result); - } else { - /* Loading asynchronously. We may need to wait for initialization. */ - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_wait(&initNotification); - } - } - } else { - /* The data is not managed by the resource manager so there's nothing else to do. */ - MA_ASSERT(pExistingData != NULL); - } - } - -done: - /* If we failed to initialize the data buffer we need to free it. */ - if (result != MA_SUCCESS) { - if (nodeAlreadyExists == MA_FALSE) { - ma_resource_manager_data_buffer_node_remove(pResourceManager, pDataBufferNode); - ma_free(pDataBufferNode, &pResourceManager->config.allocationCallbacks); - } - } - - /* - The init notification needs to be uninitialized. This will be used if the node does not already - exist, and we've specified ASYNC | WAIT_INIT. - */ - if (nodeAlreadyExists == MA_FALSE && pDataBufferNode->isDataOwnedByResourceManager && (flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC) != 0) { - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_uninit(&initNotification); - } - } - - if (ppDataBufferNode != NULL) { - *ppDataBufferNode = pDataBufferNode; - } - - return result; -} - -static ma_result ma_resource_manager_data_buffer_node_unacquire(ma_resource_manager* pResourceManager, ma_resource_manager_data_buffer_node* pDataBufferNode, const char* pName, const wchar_t* pNameW) -{ - ma_result result = MA_SUCCESS; - ma_uint32 refCount = 0xFFFFFFFF; /* The new reference count of the node after decrementing. Initialize to non-0 to be safe we don't fall into the freeing path. */ - ma_uint32 hashedName32 = 0; - - if (pResourceManager == NULL) { - return MA_INVALID_ARGS; - } - - if (pDataBufferNode == NULL) { - if (pName == NULL && pNameW == NULL) { - return MA_INVALID_ARGS; - } - - if (pName != NULL) { - hashedName32 = ma_hash_string_32(pName); - } else { - hashedName32 = ma_hash_string_w_32(pNameW); - } - } - - /* - The first thing to do is decrement the reference counter of the node. Then, if the reference - count is zero, we need to free the node. If the node is still in the process of loading, we'll - need to post a job to the job queue to free the node. Otherwise we'll just do it here. - */ - ma_resource_manager_data_buffer_bst_lock(pResourceManager); - { - /* Might need to find the node. Must be done inside the critical section. */ - if (pDataBufferNode == NULL) { - result = ma_resource_manager_data_buffer_node_search(pResourceManager, hashedName32, &pDataBufferNode); - if (result != MA_SUCCESS) { - goto stage2; /* Couldn't find the node. */ - } - } - - result = ma_resource_manager_data_buffer_node_decrement_ref(pResourceManager, pDataBufferNode, &refCount); - if (result != MA_SUCCESS) { - goto stage2; /* Should never happen. */ - } - - if (refCount == 0) { - result = ma_resource_manager_data_buffer_node_remove(pResourceManager, pDataBufferNode); - if (result != MA_SUCCESS) { - goto stage2; /* An error occurred when trying to remove the data buffer. This should never happen. */ - } - } - } - ma_resource_manager_data_buffer_bst_unlock(pResourceManager); - -stage2: - if (result != MA_SUCCESS) { - return result; - } - - /* - Here is where we need to free the node. We don't want to do this inside the critical section - above because we want to keep that as small as possible for multi-threaded efficiency. - */ - if (refCount == 0) { - if (ma_resource_manager_data_buffer_node_result(pDataBufferNode) == MA_BUSY) { - /* The sound is still loading. We need to delay the freeing of the node to a safe time. */ - ma_job job; - - /* We need to mark the node as unavailable for the sake of the resource manager worker threads. */ - c89atomic_exchange_i32(&pDataBufferNode->result, MA_UNAVAILABLE); - - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER_NODE); - job.order = ma_resource_manager_data_buffer_node_next_execution_order(pDataBufferNode); - job.data.resourceManager.freeDataBufferNode.pResourceManager = pResourceManager; - job.data.resourceManager.freeDataBufferNode.pDataBufferNode = pDataBufferNode; - - result = ma_resource_manager_post_job(pResourceManager, &job); - if (result != MA_SUCCESS) { - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_ERROR, "Failed to post MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER_NODE job. %s.\n", ma_result_description(result)); - return result; - } - - /* If we don't support threading, process the job queue here. */ - if (ma_resource_manager_is_threading_enabled(pResourceManager) == MA_FALSE) { - while (ma_resource_manager_data_buffer_node_result(pDataBufferNode) == MA_BUSY) { - result = ma_resource_manager_process_next_job(pResourceManager); - if (result == MA_NO_DATA_AVAILABLE || result == MA_CANCELLED) { - result = MA_SUCCESS; - break; - } - } - } else { - /* Threading is enabled. The job queue will deal with the rest of the cleanup from here. */ - } - } else { - /* The sound isn't loading so we can just free the node here. */ - ma_resource_manager_data_buffer_node_free(pResourceManager, pDataBufferNode); - } - } - - return result; -} - - - -static ma_uint32 ma_resource_manager_data_buffer_next_execution_order(ma_resource_manager_data_buffer* pDataBuffer) -{ - MA_ASSERT(pDataBuffer != NULL); - return c89atomic_fetch_add_32(&pDataBuffer->executionCounter, 1); -} - -static ma_result ma_resource_manager_data_buffer_cb__read_pcm_frames(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_resource_manager_data_buffer_read_pcm_frames((ma_resource_manager_data_buffer*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_resource_manager_data_buffer_cb__seek_to_pcm_frame(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_resource_manager_data_buffer_seek_to_pcm_frame((ma_resource_manager_data_buffer*)pDataSource, frameIndex); -} - -static ma_result ma_resource_manager_data_buffer_cb__get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_resource_manager_data_buffer_get_data_format((ma_resource_manager_data_buffer*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_resource_manager_data_buffer_cb__get_cursor_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_resource_manager_data_buffer_get_cursor_in_pcm_frames((ma_resource_manager_data_buffer*)pDataSource, pCursor); -} - -static ma_result ma_resource_manager_data_buffer_cb__get_length_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_resource_manager_data_buffer_get_length_in_pcm_frames((ma_resource_manager_data_buffer*)pDataSource, pLength); -} - -static ma_result ma_resource_manager_data_buffer_cb__set_looping(ma_data_source* pDataSource, ma_bool32 isLooping) -{ - ma_resource_manager_data_buffer* pDataBuffer = (ma_resource_manager_data_buffer*)pDataSource; - MA_ASSERT(pDataBuffer != NULL); - - c89atomic_exchange_32(&pDataBuffer->isLooping, isLooping); - - /* The looping state needs to be set on the connector as well or else looping won't work when we read audio data. */ - ma_data_source_set_looping(ma_resource_manager_data_buffer_get_connector(pDataBuffer), isLooping); - - return MA_SUCCESS; -} - -static ma_data_source_vtable g_ma_resource_manager_data_buffer_vtable = -{ - ma_resource_manager_data_buffer_cb__read_pcm_frames, - ma_resource_manager_data_buffer_cb__seek_to_pcm_frame, - ma_resource_manager_data_buffer_cb__get_data_format, - ma_resource_manager_data_buffer_cb__get_cursor_in_pcm_frames, - ma_resource_manager_data_buffer_cb__get_length_in_pcm_frames, - ma_resource_manager_data_buffer_cb__set_looping, - 0 -}; - -static ma_result ma_resource_manager_data_buffer_init_ex_internal(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_uint32 hashedName32, ma_resource_manager_data_buffer* pDataBuffer) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager_data_buffer_node* pDataBufferNode; - ma_data_source_config dataSourceConfig; - ma_bool32 async; - ma_uint32 flags; - ma_resource_manager_pipeline_notifications notifications; - - if (pDataBuffer == NULL) { - if (pConfig != NULL && pConfig->pNotifications != NULL) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(pConfig->pNotifications); - } - - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDataBuffer); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->pNotifications != NULL) { - notifications = *pConfig->pNotifications; /* From here on out we should be referencing `notifications` instead of `pNotifications`. Set this to NULL to catch errors at testing time. */ - } else { - MA_ZERO_OBJECT(¬ifications); - } - - /* For safety, always remove the ASYNC flag if threading is disabled on the resource manager. */ - flags = pConfig->flags; - if (ma_resource_manager_is_threading_enabled(pResourceManager) == MA_FALSE) { - flags &= ~MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC; - } - - async = (flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC) != 0; - - /* - Fences need to be acquired before doing anything. These must be aquired and released outside of - the node to ensure there's no holes where ma_fence_wait() could prematurely return before the - data buffer has completed initialization. - - When loading asynchronously, the node acquisition routine below will acquire the fences on this - thread and then release them on the async thread when the operation is complete. - - These fences are always released at the "done" tag at the end of this function. They'll be - acquired a second if loading asynchronously. This double acquisition system is just done to - simplify code maintanence. - */ - ma_resource_manager_pipeline_notifications_acquire_all_fences(¬ifications); - { - /* We first need to acquire a node. If ASYNC is not set, this will not return until the entire sound has been loaded. */ - result = ma_resource_manager_data_buffer_node_acquire(pResourceManager, pConfig->pFilePath, pConfig->pFilePathW, hashedName32, flags, NULL, notifications.init.pFence, notifications.done.pFence, &pDataBufferNode); - if (result != MA_SUCCESS) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - goto done; - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_resource_manager_data_buffer_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pDataBuffer->ds); - if (result != MA_SUCCESS) { - ma_resource_manager_data_buffer_node_unacquire(pResourceManager, pDataBufferNode, NULL, NULL); - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - goto done; - } - - pDataBuffer->pResourceManager = pResourceManager; - pDataBuffer->pNode = pDataBufferNode; - pDataBuffer->flags = flags; - pDataBuffer->result = MA_BUSY; /* Always default to MA_BUSY for safety. It'll be overwritten when loading completes or an error occurs. */ - - /* If we're loading asynchronously we need to post a job to the job queue to initialize the connector. */ - if (async == MA_FALSE || ma_resource_manager_data_buffer_node_result(pDataBufferNode) == MA_SUCCESS) { - /* Loading synchronously or the data has already been fully loaded. We can just initialize the connector from here without a job. */ - result = ma_resource_manager_data_buffer_init_connector(pDataBuffer, pConfig, NULL, NULL); - c89atomic_exchange_i32(&pDataBuffer->result, result); - - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - goto done; - } else { - /* The node's data supply isn't initialized yet. The caller has requested that we load asynchronously so we need to post a job to do this. */ - ma_job job; - ma_resource_manager_inline_notification initNotification; /* Used when the WAIT_INIT flag is set. */ - - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_init(pResourceManager, &initNotification); - } - - /* - The status of the data buffer needs to be set to MA_BUSY before posting the job so that the - worker thread is aware of it's busy state. If the LOAD_DATA_BUFFER job sees a status other - than MA_BUSY, it'll assume an error and fall through to an early exit. - */ - c89atomic_exchange_i32(&pDataBuffer->result, MA_BUSY); - - /* Acquire fences a second time. These will be released by the async thread. */ - ma_resource_manager_pipeline_notifications_acquire_all_fences(¬ifications); - - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER); - job.order = ma_resource_manager_data_buffer_next_execution_order(pDataBuffer); - job.data.resourceManager.loadDataBuffer.pDataBuffer = pDataBuffer; - job.data.resourceManager.loadDataBuffer.pInitNotification = ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) ? &initNotification : notifications.init.pNotification; - job.data.resourceManager.loadDataBuffer.pDoneNotification = notifications.done.pNotification; - job.data.resourceManager.loadDataBuffer.pInitFence = notifications.init.pFence; - job.data.resourceManager.loadDataBuffer.pDoneFence = notifications.done.pFence; - job.data.resourceManager.loadDataBuffer.rangeBegInPCMFrames = pConfig->rangeBegInPCMFrames; - job.data.resourceManager.loadDataBuffer.rangeEndInPCMFrames = pConfig->rangeEndInPCMFrames; - job.data.resourceManager.loadDataBuffer.loopPointBegInPCMFrames = pConfig->loopPointBegInPCMFrames; - job.data.resourceManager.loadDataBuffer.loopPointEndInPCMFrames = pConfig->loopPointEndInPCMFrames; - job.data.resourceManager.loadDataBuffer.isLooping = pConfig->isLooping; - - result = ma_resource_manager_post_job(pResourceManager, &job); - if (result != MA_SUCCESS) { - /* We failed to post the job. Most likely there isn't enough room in the queue's buffer. */ - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_ERROR, "Failed to post MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_BUFFER job. %s.\n", ma_result_description(result)); - c89atomic_exchange_i32(&pDataBuffer->result, result); - - /* Release the fences after the result has been set on the data buffer. */ - ma_resource_manager_pipeline_notifications_release_all_fences(¬ifications); - } else { - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_wait(&initNotification); - - if (notifications.init.pNotification != NULL) { - ma_async_notification_signal(notifications.init.pNotification); - } - - /* NOTE: Do not release the init fence here. It will have been done by the job. */ - - /* Make sure we return an error if initialization failed on the async thread. */ - result = ma_resource_manager_data_buffer_result(pDataBuffer); - if (result == MA_BUSY) { - result = MA_SUCCESS; - } - } - } - - if ((flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - ma_resource_manager_inline_notification_uninit(&initNotification); - } - } - - if (result != MA_SUCCESS) { - ma_resource_manager_data_buffer_node_unacquire(pResourceManager, pDataBufferNode, NULL, NULL); - goto done; - } - } -done: - if (result == MA_SUCCESS) { - if (pConfig->initialSeekPointInPCMFrames > 0) { - ma_resource_manager_data_buffer_seek_to_pcm_frame(pDataBuffer, pConfig->initialSeekPointInPCMFrames); - } - } - - ma_resource_manager_pipeline_notifications_release_all_fences(¬ifications); - - return result; -} - -MA_API ma_result ma_resource_manager_data_buffer_init_ex(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_buffer* pDataBuffer) -{ - return ma_resource_manager_data_buffer_init_ex_internal(pResourceManager, pConfig, 0, pDataBuffer); -} - -MA_API ma_result ma_resource_manager_data_buffer_init(ma_resource_manager* pResourceManager, const char* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_buffer* pDataBuffer) -{ - ma_resource_manager_data_source_config config; - - config = ma_resource_manager_data_source_config_init(); - config.pFilePath = pFilePath; - config.flags = flags; - config.pNotifications = pNotifications; - - return ma_resource_manager_data_buffer_init_ex(pResourceManager, &config, pDataBuffer); -} - -MA_API ma_result ma_resource_manager_data_buffer_init_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_buffer* pDataBuffer) -{ - ma_resource_manager_data_source_config config; - - config = ma_resource_manager_data_source_config_init(); - config.pFilePathW = pFilePath; - config.flags = flags; - config.pNotifications = pNotifications; - - return ma_resource_manager_data_buffer_init_ex(pResourceManager, &config, pDataBuffer); -} - -MA_API ma_result ma_resource_manager_data_buffer_init_copy(ma_resource_manager* pResourceManager, const ma_resource_manager_data_buffer* pExistingDataBuffer, ma_resource_manager_data_buffer* pDataBuffer) -{ - ma_resource_manager_data_source_config config; - - if (pExistingDataBuffer == NULL) { - return MA_INVALID_ARGS; - } - - MA_ASSERT(pExistingDataBuffer->pNode != NULL); /* <-- If you've triggered this, you've passed in an invalid existing data buffer. */ - - config = ma_resource_manager_data_source_config_init(); - config.flags = pExistingDataBuffer->flags; - - return ma_resource_manager_data_buffer_init_ex_internal(pResourceManager, &config, pExistingDataBuffer->pNode->hashedName32, pDataBuffer); -} - -static ma_result ma_resource_manager_data_buffer_uninit_internal(ma_resource_manager_data_buffer* pDataBuffer) -{ - MA_ASSERT(pDataBuffer != NULL); - - /* The connector should be uninitialized first. */ - ma_resource_manager_data_buffer_uninit_connector(pDataBuffer->pResourceManager, pDataBuffer); - - /* With the connector uninitialized we can unacquire the node. */ - ma_resource_manager_data_buffer_node_unacquire(pDataBuffer->pResourceManager, pDataBuffer->pNode, NULL, NULL); - - /* The base data source needs to be uninitialized as well. */ - ma_data_source_uninit(&pDataBuffer->ds); - - return MA_SUCCESS; -} - -MA_API ma_result ma_resource_manager_data_buffer_uninit(ma_resource_manager_data_buffer* pDataBuffer) -{ - ma_result result; - - if (pDataBuffer == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_buffer_result(pDataBuffer) == MA_SUCCESS) { - /* The data buffer can be deleted synchronously. */ - return ma_resource_manager_data_buffer_uninit_internal(pDataBuffer); - } else { - /* - The data buffer needs to be deleted asynchronously because it's still loading. With the status set to MA_UNAVAILABLE, no more pages will - be loaded and the uninitialization should happen fairly quickly. Since the caller owns the data buffer, we need to wait for this event - to get processed before returning. - */ - ma_resource_manager_inline_notification notification; - ma_job job; - - /* - We need to mark the node as unavailable so we don't try reading from it anymore, but also to - let the loading thread know that it needs to abort it's loading procedure. - */ - c89atomic_exchange_i32(&pDataBuffer->result, MA_UNAVAILABLE); - - result = ma_resource_manager_inline_notification_init(pDataBuffer->pResourceManager, ¬ification); - if (result != MA_SUCCESS) { - return result; /* Failed to create the notification. This should rarely, if ever, happen. */ - } - - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER); - job.order = ma_resource_manager_data_buffer_next_execution_order(pDataBuffer); - job.data.resourceManager.freeDataBuffer.pDataBuffer = pDataBuffer; - job.data.resourceManager.freeDataBuffer.pDoneNotification = ¬ification; - job.data.resourceManager.freeDataBuffer.pDoneFence = NULL; - - result = ma_resource_manager_post_job(pDataBuffer->pResourceManager, &job); - if (result != MA_SUCCESS) { - ma_resource_manager_inline_notification_uninit(¬ification); - return result; - } - - ma_resource_manager_inline_notification_wait_and_uninit(¬ification); - } - - return result; -} - -MA_API ma_result ma_resource_manager_data_buffer_read_pcm_frames(ma_resource_manager_data_buffer* pDataBuffer, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint64 framesRead = 0; - ma_bool32 isDecodedBufferBusy = MA_FALSE; - - /* Safety. */ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - /* - We cannot be using the data buffer after it's been uninitialized. If you trigger this assert it means you're trying to read from the data buffer after - it's been uninitialized or is in the process of uninitializing. - */ - MA_ASSERT(ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) != MA_UNAVAILABLE); - - /* If the node is not initialized we need to abort with a busy code. */ - if (ma_resource_manager_data_buffer_has_connector(pDataBuffer) == MA_FALSE) { - return MA_BUSY; /* Still loading. */ - } - - /* - If we've got a seek scheduled we'll want to do that before reading. However, for paged buffers, there's - a chance that the sound hasn't yet been decoded up to the seek point will result in the seek failing. If - this happens, we need to keep the seek scheduled and return MA_BUSY. - */ - if (pDataBuffer->seekToCursorOnNextRead) { - pDataBuffer->seekToCursorOnNextRead = MA_FALSE; - - result = ma_data_source_seek_to_pcm_frame(ma_resource_manager_data_buffer_get_connector(pDataBuffer), pDataBuffer->seekTargetInPCMFrames); - if (result != MA_SUCCESS) { - if (result == MA_BAD_SEEK && ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode) == ma_resource_manager_data_supply_type_decoded_paged) { - pDataBuffer->seekToCursorOnNextRead = MA_TRUE; /* Keep the seek scheduled. We just haven't loaded enough data yet to do the seek properly. */ - return MA_BUSY; - } - - return result; - } - } - - /* - For decoded buffers (not paged) we need to check beforehand how many frames we have available. We cannot - exceed this amount. We'll read as much as we can, and then return MA_BUSY. - */ - if (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode) == ma_resource_manager_data_supply_type_decoded) { - ma_uint64 availableFrames; - - isDecodedBufferBusy = (ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) == MA_BUSY); - - if (ma_resource_manager_data_buffer_get_available_frames(pDataBuffer, &availableFrames) == MA_SUCCESS) { - /* Don't try reading more than the available frame count. */ - if (frameCount > availableFrames) { - frameCount = availableFrames; - - /* - If there's no frames available we want to set the status to MA_AT_END. The logic below - will check if the node is busy, and if so, change it to MA_BUSY. The reason we do this - is because we don't want to call `ma_data_source_read_pcm_frames()` if the frame count - is 0 because that'll result in a situation where it's possible MA_AT_END won't get - returned. - */ - if (frameCount == 0) { - result = MA_AT_END; - } - } else { - isDecodedBufferBusy = MA_FALSE; /* We have enough frames available in the buffer to avoid a MA_BUSY status. */ - } - } - } - - /* Don't attempt to read anything if we've got no frames available. */ - if (frameCount > 0) { - result = ma_data_source_read_pcm_frames(ma_resource_manager_data_buffer_get_connector(pDataBuffer), pFramesOut, frameCount, &framesRead); - } - - /* - If we returned MA_AT_END, but the node is still loading, we don't want to return that code or else the caller will interpret the sound - as at the end and terminate decoding. - */ - if (result == MA_AT_END) { - if (ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) == MA_BUSY) { - result = MA_BUSY; - } - } - - if (isDecodedBufferBusy) { - result = MA_BUSY; - } - - if (pFramesRead != NULL) { - *pFramesRead = framesRead; - } - - if (result == MA_SUCCESS && framesRead == 0) { - result = MA_AT_END; - } - - return result; -} - -MA_API ma_result ma_resource_manager_data_buffer_seek_to_pcm_frame(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64 frameIndex) -{ - ma_result result; - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) != MA_UNAVAILABLE); - - /* If we haven't yet got a connector we need to abort. */ - if (ma_resource_manager_data_buffer_has_connector(pDataBuffer) == MA_FALSE) { - pDataBuffer->seekTargetInPCMFrames = frameIndex; - pDataBuffer->seekToCursorOnNextRead = MA_TRUE; - return MA_BUSY; /* Still loading. */ - } - - result = ma_data_source_seek_to_pcm_frame(ma_resource_manager_data_buffer_get_connector(pDataBuffer), frameIndex); - if (result != MA_SUCCESS) { - return result; - } - - pDataBuffer->seekTargetInPCMFrames = ~(ma_uint64)0; /* <-- For identification purposes. */ - pDataBuffer->seekToCursorOnNextRead = MA_FALSE; - - return MA_SUCCESS; -} - -MA_API ma_result ma_resource_manager_data_buffer_get_data_format(ma_resource_manager_data_buffer* pDataBuffer, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) != MA_UNAVAILABLE); - - switch (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode)) - { - case ma_resource_manager_data_supply_type_encoded: - { - return ma_data_source_get_data_format(&pDataBuffer->connector.decoder, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); - }; - - case ma_resource_manager_data_supply_type_decoded: - { - *pFormat = pDataBuffer->pNode->data.backend.decoded.format; - *pChannels = pDataBuffer->pNode->data.backend.decoded.channels; - *pSampleRate = pDataBuffer->pNode->data.backend.decoded.sampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pDataBuffer->pNode->data.backend.decoded.channels); - return MA_SUCCESS; - }; - - case ma_resource_manager_data_supply_type_decoded_paged: - { - *pFormat = pDataBuffer->pNode->data.backend.decodedPaged.data.format; - *pChannels = pDataBuffer->pNode->data.backend.decodedPaged.data.channels; - *pSampleRate = pDataBuffer->pNode->data.backend.decodedPaged.sampleRate; - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, pDataBuffer->pNode->data.backend.decoded.channels); - return MA_SUCCESS; - }; - - case ma_resource_manager_data_supply_type_unknown: - { - return MA_BUSY; /* Still loading. */ - }; - - default: - { - /* Unknown supply type. Should never hit this. */ - return MA_INVALID_ARGS; - } - } -} - -MA_API ma_result ma_resource_manager_data_buffer_get_cursor_in_pcm_frames(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64* pCursor) -{ - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) != MA_UNAVAILABLE); - - if (pDataBuffer == NULL || pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - switch (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode)) - { - case ma_resource_manager_data_supply_type_encoded: - { - return ma_decoder_get_cursor_in_pcm_frames(&pDataBuffer->connector.decoder, pCursor); - }; - - case ma_resource_manager_data_supply_type_decoded: - { - return ma_audio_buffer_get_cursor_in_pcm_frames(&pDataBuffer->connector.buffer, pCursor); - }; - - case ma_resource_manager_data_supply_type_decoded_paged: - { - return ma_paged_audio_buffer_get_cursor_in_pcm_frames(&pDataBuffer->connector.pagedBuffer, pCursor); - }; - - case ma_resource_manager_data_supply_type_unknown: - { - return MA_BUSY; - }; - - default: - { - return MA_INVALID_ARGS; - } - } -} - -MA_API ma_result ma_resource_manager_data_buffer_get_length_in_pcm_frames(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64* pLength) -{ - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) != MA_UNAVAILABLE); - - if (pDataBuffer == NULL || pLength == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode) == ma_resource_manager_data_supply_type_unknown) { - return MA_BUSY; /* Still loading. */ - } - - return ma_data_source_get_length_in_pcm_frames(ma_resource_manager_data_buffer_get_connector(pDataBuffer), pLength); -} - -MA_API ma_result ma_resource_manager_data_buffer_result(const ma_resource_manager_data_buffer* pDataBuffer) -{ - if (pDataBuffer == NULL) { - return MA_INVALID_ARGS; - } - - return (ma_result)c89atomic_load_i32((ma_result*)&pDataBuffer->result); /* Need a naughty const-cast here. */ -} - -MA_API ma_result ma_resource_manager_data_buffer_set_looping(ma_resource_manager_data_buffer* pDataBuffer, ma_bool32 isLooping) -{ - return ma_data_source_set_looping(pDataBuffer, isLooping); -} - -MA_API ma_bool32 ma_resource_manager_data_buffer_is_looping(const ma_resource_manager_data_buffer* pDataBuffer) -{ - return ma_data_source_is_looping(pDataBuffer); -} - -MA_API ma_result ma_resource_manager_data_buffer_get_available_frames(ma_resource_manager_data_buffer* pDataBuffer, ma_uint64* pAvailableFrames) -{ - if (pAvailableFrames == NULL) { - return MA_INVALID_ARGS; - } - - *pAvailableFrames = 0; - - if (pDataBuffer == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode) == ma_resource_manager_data_supply_type_unknown) { - if (ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode) == MA_BUSY) { - return MA_BUSY; - } else { - return MA_INVALID_OPERATION; /* No connector. */ - } - } - - switch (ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode)) - { - case ma_resource_manager_data_supply_type_encoded: - { - return ma_decoder_get_available_frames(&pDataBuffer->connector.decoder, pAvailableFrames); - }; - - case ma_resource_manager_data_supply_type_decoded: - { - return ma_audio_buffer_get_available_frames(&pDataBuffer->connector.buffer, pAvailableFrames); - }; - - case ma_resource_manager_data_supply_type_decoded_paged: - { - ma_uint64 cursor; - ma_paged_audio_buffer_get_cursor_in_pcm_frames(&pDataBuffer->connector.pagedBuffer, &cursor); - - if (pDataBuffer->pNode->data.backend.decodedPaged.decodedFrameCount > cursor) { - *pAvailableFrames = pDataBuffer->pNode->data.backend.decodedPaged.decodedFrameCount - cursor; - } else { - *pAvailableFrames = 0; - } - - return MA_SUCCESS; - }; - - case ma_resource_manager_data_supply_type_unknown: - default: - { - /* Unknown supply type. Should never hit this. */ - return MA_INVALID_ARGS; - } - } -} - -MA_API ma_result ma_resource_manager_register_file(ma_resource_manager* pResourceManager, const char* pFilePath, ma_uint32 flags) -{ - return ma_resource_manager_data_buffer_node_acquire(pResourceManager, pFilePath, NULL, 0, flags, NULL, NULL, NULL, NULL); -} - -MA_API ma_result ma_resource_manager_register_file_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath, ma_uint32 flags) -{ - return ma_resource_manager_data_buffer_node_acquire(pResourceManager, NULL, pFilePath, 0, flags, NULL, NULL, NULL, NULL); -} - - -static ma_result ma_resource_manager_register_data(ma_resource_manager* pResourceManager, const char* pName, const wchar_t* pNameW, ma_resource_manager_data_supply* pExistingData) -{ - return ma_resource_manager_data_buffer_node_acquire(pResourceManager, pName, pNameW, 0, 0, pExistingData, NULL, NULL, NULL); -} - -static ma_result ma_resource_manager_register_decoded_data_internal(ma_resource_manager* pResourceManager, const char* pName, const wchar_t* pNameW, const void* pData, ma_uint64 frameCount, ma_format format, ma_uint32 channels, ma_uint32 sampleRate) -{ - ma_resource_manager_data_supply data; - data.type = ma_resource_manager_data_supply_type_decoded; - data.backend.decoded.pData = pData; - data.backend.decoded.totalFrameCount = frameCount; - data.backend.decoded.format = format; - data.backend.decoded.channels = channels; - data.backend.decoded.sampleRate = sampleRate; - - return ma_resource_manager_register_data(pResourceManager, pName, pNameW, &data); -} - -MA_API ma_result ma_resource_manager_register_decoded_data(ma_resource_manager* pResourceManager, const char* pName, const void* pData, ma_uint64 frameCount, ma_format format, ma_uint32 channels, ma_uint32 sampleRate) -{ - return ma_resource_manager_register_decoded_data_internal(pResourceManager, pName, NULL, pData, frameCount, format, channels, sampleRate); -} - -MA_API ma_result ma_resource_manager_register_decoded_data_w(ma_resource_manager* pResourceManager, const wchar_t* pName, const void* pData, ma_uint64 frameCount, ma_format format, ma_uint32 channels, ma_uint32 sampleRate) -{ - return ma_resource_manager_register_decoded_data_internal(pResourceManager, NULL, pName, pData, frameCount, format, channels, sampleRate); -} - - -static ma_result ma_resource_manager_register_encoded_data_internal(ma_resource_manager* pResourceManager, const char* pName, const wchar_t* pNameW, const void* pData, size_t sizeInBytes) -{ - ma_resource_manager_data_supply data; - data.type = ma_resource_manager_data_supply_type_encoded; - data.backend.encoded.pData = pData; - data.backend.encoded.sizeInBytes = sizeInBytes; - - return ma_resource_manager_register_data(pResourceManager, pName, pNameW, &data); -} - -MA_API ma_result ma_resource_manager_register_encoded_data(ma_resource_manager* pResourceManager, const char* pName, const void* pData, size_t sizeInBytes) -{ - return ma_resource_manager_register_encoded_data_internal(pResourceManager, pName, NULL, pData, sizeInBytes); -} - -MA_API ma_result ma_resource_manager_register_encoded_data_w(ma_resource_manager* pResourceManager, const wchar_t* pName, const void* pData, size_t sizeInBytes) -{ - return ma_resource_manager_register_encoded_data_internal(pResourceManager, NULL, pName, pData, sizeInBytes); -} - - -MA_API ma_result ma_resource_manager_unregister_file(ma_resource_manager* pResourceManager, const char* pFilePath) -{ - return ma_resource_manager_unregister_data(pResourceManager, pFilePath); -} - -MA_API ma_result ma_resource_manager_unregister_file_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath) -{ - return ma_resource_manager_unregister_data_w(pResourceManager, pFilePath); -} - -MA_API ma_result ma_resource_manager_unregister_data(ma_resource_manager* pResourceManager, const char* pName) -{ - return ma_resource_manager_data_buffer_node_unacquire(pResourceManager, NULL, pName, NULL); -} - -MA_API ma_result ma_resource_manager_unregister_data_w(ma_resource_manager* pResourceManager, const wchar_t* pName) -{ - return ma_resource_manager_data_buffer_node_unacquire(pResourceManager, NULL, NULL, pName); -} - - -static ma_uint32 ma_resource_manager_data_stream_next_execution_order(ma_resource_manager_data_stream* pDataStream) -{ - MA_ASSERT(pDataStream != NULL); - return c89atomic_fetch_add_32(&pDataStream->executionCounter, 1); -} - -static ma_bool32 ma_resource_manager_data_stream_is_decoder_at_end(const ma_resource_manager_data_stream* pDataStream) -{ - MA_ASSERT(pDataStream != NULL); - return c89atomic_load_32((ma_bool32*)&pDataStream->isDecoderAtEnd); -} - -static ma_uint32 ma_resource_manager_data_stream_seek_counter(const ma_resource_manager_data_stream* pDataStream) -{ - MA_ASSERT(pDataStream != NULL); - return c89atomic_load_32((ma_uint32*)&pDataStream->seekCounter); -} - - -static ma_result ma_resource_manager_data_stream_cb__read_pcm_frames(ma_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_resource_manager_data_stream_read_pcm_frames((ma_resource_manager_data_stream*)pDataSource, pFramesOut, frameCount, pFramesRead); -} - -static ma_result ma_resource_manager_data_stream_cb__seek_to_pcm_frame(ma_data_source* pDataSource, ma_uint64 frameIndex) -{ - return ma_resource_manager_data_stream_seek_to_pcm_frame((ma_resource_manager_data_stream*)pDataSource, frameIndex); -} - -static ma_result ma_resource_manager_data_stream_cb__get_data_format(ma_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - return ma_resource_manager_data_stream_get_data_format((ma_resource_manager_data_stream*)pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -static ma_result ma_resource_manager_data_stream_cb__get_cursor_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pCursor) -{ - return ma_resource_manager_data_stream_get_cursor_in_pcm_frames((ma_resource_manager_data_stream*)pDataSource, pCursor); -} - -static ma_result ma_resource_manager_data_stream_cb__get_length_in_pcm_frames(ma_data_source* pDataSource, ma_uint64* pLength) -{ - return ma_resource_manager_data_stream_get_length_in_pcm_frames((ma_resource_manager_data_stream*)pDataSource, pLength); -} - -static ma_result ma_resource_manager_data_stream_cb__set_looping(ma_data_source* pDataSource, ma_bool32 isLooping) -{ - ma_resource_manager_data_stream* pDataStream = (ma_resource_manager_data_stream*)pDataSource; - MA_ASSERT(pDataStream != NULL); - - c89atomic_exchange_32(&pDataStream->isLooping, isLooping); - - return MA_SUCCESS; -} - -static ma_data_source_vtable g_ma_resource_manager_data_stream_vtable = -{ - ma_resource_manager_data_stream_cb__read_pcm_frames, - ma_resource_manager_data_stream_cb__seek_to_pcm_frame, - ma_resource_manager_data_stream_cb__get_data_format, - ma_resource_manager_data_stream_cb__get_cursor_in_pcm_frames, - ma_resource_manager_data_stream_cb__get_length_in_pcm_frames, - ma_resource_manager_data_stream_cb__set_looping, - 0 /*MA_DATA_SOURCE_SELF_MANAGED_RANGE_AND_LOOP_POINT*/ -}; - -static void ma_resource_manager_data_stream_set_absolute_cursor(ma_resource_manager_data_stream* pDataStream, ma_uint64 absoluteCursor) -{ - /* Loop if possible. */ - if (absoluteCursor > pDataStream->totalLengthInPCMFrames && pDataStream->totalLengthInPCMFrames > 0) { - absoluteCursor = absoluteCursor % pDataStream->totalLengthInPCMFrames; - } - - c89atomic_exchange_64(&pDataStream->absoluteCursor, absoluteCursor); -} - -MA_API ma_result ma_resource_manager_data_stream_init_ex(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_stream* pDataStream) -{ - ma_result result; - ma_data_source_config dataSourceConfig; - char* pFilePathCopy = NULL; - wchar_t* pFilePathWCopy = NULL; - ma_job job; - ma_bool32 waitBeforeReturning = MA_FALSE; - ma_resource_manager_inline_notification waitNotification; - ma_resource_manager_pipeline_notifications notifications; - - if (pDataStream == NULL) { - if (pConfig != NULL && pConfig->pNotifications != NULL) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(pConfig->pNotifications); - } - - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDataStream); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->pNotifications != NULL) { - notifications = *pConfig->pNotifications; /* From here on out, `notifications` should be used instead of `pNotifications`. Setting this to NULL to catch any errors at testing time. */ - } else { - MA_ZERO_OBJECT(¬ifications); - } - - dataSourceConfig = ma_data_source_config_init(); - dataSourceConfig.vtable = &g_ma_resource_manager_data_stream_vtable; - - result = ma_data_source_init(&dataSourceConfig, &pDataStream->ds); - if (result != MA_SUCCESS) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - return result; - } - - pDataStream->pResourceManager = pResourceManager; - pDataStream->flags = pConfig->flags; - pDataStream->result = MA_BUSY; - - ma_data_source_set_range_in_pcm_frames(pDataStream, pConfig->rangeBegInPCMFrames, pConfig->rangeEndInPCMFrames); - ma_data_source_set_loop_point_in_pcm_frames(pDataStream, pConfig->loopPointBegInPCMFrames, pConfig->loopPointEndInPCMFrames); - ma_data_source_set_looping(pDataStream, pConfig->isLooping); - - if (pResourceManager == NULL || (pConfig->pFilePath == NULL && pConfig->pFilePathW == NULL)) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - return MA_INVALID_ARGS; - } - - /* We want all access to the VFS and the internal decoder to happen on the job thread just to keep things easier to manage for the VFS. */ - - /* We need a copy of the file path. We should probably make this more efficient, but for now we'll do a transient memory allocation. */ - if (pConfig->pFilePath != NULL) { - pFilePathCopy = ma_copy_string(pConfig->pFilePath, &pResourceManager->config.allocationCallbacks); - } else { - pFilePathWCopy = ma_copy_string_w(pConfig->pFilePathW, &pResourceManager->config.allocationCallbacks); - } - - if (pFilePathCopy == NULL && pFilePathWCopy == NULL) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - return MA_OUT_OF_MEMORY; - } - - /* - We need to check for the presence of MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC. If it's not set, we need to wait before returning. Otherwise we - can return immediately. Likewise, we'll also check for MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT and do the same. - */ - if ((pConfig->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_ASYNC) == 0 || (pConfig->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT) != 0) { - waitBeforeReturning = MA_TRUE; - ma_resource_manager_inline_notification_init(pResourceManager, &waitNotification); - } - - ma_resource_manager_pipeline_notifications_acquire_all_fences(¬ifications); - - /* Set the absolute cursor to our initial seek position so retrieval of the cursor returns a good value. */ - ma_resource_manager_data_stream_set_absolute_cursor(pDataStream, pConfig->initialSeekPointInPCMFrames); - - /* We now have everything we need to post the job. This is the last thing we need to do from here. The rest will be done by the job thread. */ - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_LOAD_DATA_STREAM); - job.order = ma_resource_manager_data_stream_next_execution_order(pDataStream); - job.data.resourceManager.loadDataStream.pDataStream = pDataStream; - job.data.resourceManager.loadDataStream.pFilePath = pFilePathCopy; - job.data.resourceManager.loadDataStream.pFilePathW = pFilePathWCopy; - job.data.resourceManager.loadDataStream.initialSeekPoint = pConfig->initialSeekPointInPCMFrames; - job.data.resourceManager.loadDataStream.pInitNotification = (waitBeforeReturning == MA_TRUE) ? &waitNotification : notifications.init.pNotification; - job.data.resourceManager.loadDataStream.pInitFence = notifications.init.pFence; - result = ma_resource_manager_post_job(pResourceManager, &job); - if (result != MA_SUCCESS) { - ma_resource_manager_pipeline_notifications_signal_all_notifications(¬ifications); - ma_resource_manager_pipeline_notifications_release_all_fences(¬ifications); - - if (waitBeforeReturning) { - ma_resource_manager_inline_notification_uninit(&waitNotification); - } - - ma_free(pFilePathCopy, &pResourceManager->config.allocationCallbacks); - ma_free(pFilePathWCopy, &pResourceManager->config.allocationCallbacks); - return result; - } - - /* Wait if needed. */ - if (waitBeforeReturning) { - ma_resource_manager_inline_notification_wait_and_uninit(&waitNotification); - - if (notifications.init.pNotification != NULL) { - ma_async_notification_signal(notifications.init.pNotification); - } - - /* - If there was an error during initialization make sure we return that result here. We don't want to do this - if we're not waiting because it will most likely be in a busy state. - */ - if (pDataStream->result != MA_SUCCESS) { - return pDataStream->result; - } - - /* NOTE: Do not release pInitFence here. That will be done by the job. */ - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_resource_manager_data_stream_init(ma_resource_manager* pResourceManager, const char* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_stream* pDataStream) -{ - ma_resource_manager_data_source_config config; - - config = ma_resource_manager_data_source_config_init(); - config.pFilePath = pFilePath; - config.flags = flags; - config.pNotifications = pNotifications; - - return ma_resource_manager_data_stream_init_ex(pResourceManager, &config, pDataStream); -} - -MA_API ma_result ma_resource_manager_data_stream_init_w(ma_resource_manager* pResourceManager, const wchar_t* pFilePath, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_stream* pDataStream) -{ - ma_resource_manager_data_source_config config; - - config = ma_resource_manager_data_source_config_init(); - config.pFilePathW = pFilePath; - config.flags = flags; - config.pNotifications = pNotifications; - - return ma_resource_manager_data_stream_init_ex(pResourceManager, &config, pDataStream); -} - -MA_API ma_result ma_resource_manager_data_stream_uninit(ma_resource_manager_data_stream* pDataStream) -{ - ma_resource_manager_inline_notification freeEvent; - ma_job job; - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - /* The first thing to do is set the result to unavailable. This will prevent future page decoding. */ - c89atomic_exchange_i32(&pDataStream->result, MA_UNAVAILABLE); - - /* - We need to post a job to ensure we're not in the middle or decoding or anything. Because the object is owned by the caller, we'll need - to wait for it to complete before returning which means we need an event. - */ - ma_resource_manager_inline_notification_init(pDataStream->pResourceManager, &freeEvent); - - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_STREAM); - job.order = ma_resource_manager_data_stream_next_execution_order(pDataStream); - job.data.resourceManager.freeDataStream.pDataStream = pDataStream; - job.data.resourceManager.freeDataStream.pDoneNotification = &freeEvent; - job.data.resourceManager.freeDataStream.pDoneFence = NULL; - ma_resource_manager_post_job(pDataStream->pResourceManager, &job); - - /* We need to wait for the job to finish processing before we return. */ - ma_resource_manager_inline_notification_wait_and_uninit(&freeEvent); - - return MA_SUCCESS; -} - - -static ma_uint32 ma_resource_manager_data_stream_get_page_size_in_frames(ma_resource_manager_data_stream* pDataStream) -{ - MA_ASSERT(pDataStream != NULL); - MA_ASSERT(pDataStream->isDecoderInitialized == MA_TRUE); - - return MA_RESOURCE_MANAGER_PAGE_SIZE_IN_MILLISECONDS * (pDataStream->decoder.outputSampleRate/1000); -} - -static void* ma_resource_manager_data_stream_get_page_data_pointer(ma_resource_manager_data_stream* pDataStream, ma_uint32 pageIndex, ma_uint32 relativeCursor) -{ - MA_ASSERT(pDataStream != NULL); - MA_ASSERT(pDataStream->isDecoderInitialized == MA_TRUE); - MA_ASSERT(pageIndex == 0 || pageIndex == 1); - - return ma_offset_ptr(pDataStream->pPageData, ((ma_resource_manager_data_stream_get_page_size_in_frames(pDataStream) * pageIndex) + relativeCursor) * ma_get_bytes_per_frame(pDataStream->decoder.outputFormat, pDataStream->decoder.outputChannels)); -} - -static void ma_resource_manager_data_stream_fill_page(ma_resource_manager_data_stream* pDataStream, ma_uint32 pageIndex) -{ - ma_result result = MA_SUCCESS; - ma_uint64 pageSizeInFrames; - ma_uint64 totalFramesReadForThisPage = 0; - void* pPageData = ma_resource_manager_data_stream_get_page_data_pointer(pDataStream, pageIndex, 0); - - pageSizeInFrames = ma_resource_manager_data_stream_get_page_size_in_frames(pDataStream); - - /* The decoder needs to inherit the stream's looping and range state. */ - { - ma_uint64 rangeBeg; - ma_uint64 rangeEnd; - ma_uint64 loopPointBeg; - ma_uint64 loopPointEnd; - - ma_data_source_set_looping(&pDataStream->decoder, ma_resource_manager_data_stream_is_looping(pDataStream)); - - ma_data_source_get_range_in_pcm_frames(pDataStream, &rangeBeg, &rangeEnd); - ma_data_source_set_range_in_pcm_frames(&pDataStream->decoder, rangeBeg, rangeEnd); - - ma_data_source_get_loop_point_in_pcm_frames(pDataStream, &loopPointBeg, &loopPointEnd); - ma_data_source_set_loop_point_in_pcm_frames(&pDataStream->decoder, loopPointBeg, loopPointEnd); - } - - /* Just read straight from the decoder. It will deal with ranges and looping for us. */ - result = ma_data_source_read_pcm_frames(&pDataStream->decoder, pPageData, pageSizeInFrames, &totalFramesReadForThisPage); - if (result == MA_AT_END || totalFramesReadForThisPage < pageSizeInFrames) { - c89atomic_exchange_32(&pDataStream->isDecoderAtEnd, MA_TRUE); - } - - c89atomic_exchange_32(&pDataStream->pageFrameCount[pageIndex], (ma_uint32)totalFramesReadForThisPage); - c89atomic_exchange_32(&pDataStream->isPageValid[pageIndex], MA_TRUE); -} - -static void ma_resource_manager_data_stream_fill_pages(ma_resource_manager_data_stream* pDataStream) -{ - ma_uint32 iPage; - - MA_ASSERT(pDataStream != NULL); - - for (iPage = 0; iPage < 2; iPage += 1) { - ma_resource_manager_data_stream_fill_page(pDataStream, iPage); - } -} - - -static ma_result ma_resource_manager_data_stream_map(ma_resource_manager_data_stream* pDataStream, void** ppFramesOut, ma_uint64* pFrameCount) -{ - ma_uint64 framesAvailable; - ma_uint64 frameCount = 0; - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_stream_result(pDataStream) != MA_UNAVAILABLE); - - if (pFrameCount != NULL) { - frameCount = *pFrameCount; - *pFrameCount = 0; - } - if (ppFramesOut != NULL) { - *ppFramesOut = NULL; - } - - if (pDataStream == NULL || ppFramesOut == NULL || pFrameCount == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_stream_result(pDataStream) != MA_SUCCESS) { - return MA_INVALID_OPERATION; - } - - /* Don't attempt to read while we're in the middle of seeking. Tell the caller that we're busy. */ - if (ma_resource_manager_data_stream_seek_counter(pDataStream) > 0) { - return MA_BUSY; - } - - /* If the page we're on is invalid it means we've caught up to the job thread. */ - if (c89atomic_load_32(&pDataStream->isPageValid[pDataStream->currentPageIndex]) == MA_FALSE) { - framesAvailable = 0; - } else { - /* - The page we're on is valid so we must have some frames available. We need to make sure that we don't overflow into the next page, even if it's valid. The reason is - that the unmap process will only post an update for one page at a time. Keeping mapping tied to page boundaries makes this simpler. - */ - ma_uint32 currentPageFrameCount = c89atomic_load_32(&pDataStream->pageFrameCount[pDataStream->currentPageIndex]); - MA_ASSERT(currentPageFrameCount >= pDataStream->relativeCursor); - - framesAvailable = currentPageFrameCount - pDataStream->relativeCursor; - } - - /* If there's no frames available and the result is set to MA_AT_END we need to return MA_AT_END. */ - if (framesAvailable == 0) { - if (ma_resource_manager_data_stream_is_decoder_at_end(pDataStream)) { - return MA_AT_END; - } else { - return MA_BUSY; /* There are no frames available, but we're not marked as EOF so we might have caught up to the job thread. Need to return MA_BUSY and wait for more data. */ - } - } - - MA_ASSERT(framesAvailable > 0); - - if (frameCount > framesAvailable) { - frameCount = framesAvailable; - } - - *ppFramesOut = ma_resource_manager_data_stream_get_page_data_pointer(pDataStream, pDataStream->currentPageIndex, pDataStream->relativeCursor); - *pFrameCount = frameCount; - - return MA_SUCCESS; -} - -static ma_result ma_resource_manager_data_stream_unmap(ma_resource_manager_data_stream* pDataStream, ma_uint64 frameCount) -{ - ma_uint32 newRelativeCursor; - ma_uint32 pageSizeInFrames; - ma_job job; - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_stream_result(pDataStream) != MA_UNAVAILABLE); - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_stream_result(pDataStream) != MA_SUCCESS) { - return MA_INVALID_OPERATION; - } - - /* The frame count should always fit inside a 32-bit integer. */ - if (frameCount > 0xFFFFFFFF) { - return MA_INVALID_ARGS; - } - - pageSizeInFrames = ma_resource_manager_data_stream_get_page_size_in_frames(pDataStream); - - /* The absolute cursor needs to be updated for ma_resource_manager_data_stream_get_cursor_in_pcm_frames(). */ - ma_resource_manager_data_stream_set_absolute_cursor(pDataStream, c89atomic_load_64(&pDataStream->absoluteCursor) + frameCount); - - /* Here is where we need to check if we need to load a new page, and if so, post a job to load it. */ - newRelativeCursor = pDataStream->relativeCursor + (ma_uint32)frameCount; - - /* If the new cursor has flowed over to the next page we need to mark the old one as invalid and post an event for it. */ - if (newRelativeCursor >= pageSizeInFrames) { - newRelativeCursor -= pageSizeInFrames; - - /* Here is where we post the job start decoding. */ - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_STREAM); - job.order = ma_resource_manager_data_stream_next_execution_order(pDataStream); - job.data.resourceManager.pageDataStream.pDataStream = pDataStream; - job.data.resourceManager.pageDataStream.pageIndex = pDataStream->currentPageIndex; - - /* The page needs to be marked as invalid so that the public API doesn't try reading from it. */ - c89atomic_exchange_32(&pDataStream->isPageValid[pDataStream->currentPageIndex], MA_FALSE); - - /* Before posting the job we need to make sure we set some state. */ - pDataStream->relativeCursor = newRelativeCursor; - pDataStream->currentPageIndex = (pDataStream->currentPageIndex + 1) & 0x01; - return ma_resource_manager_post_job(pDataStream->pResourceManager, &job); - } else { - /* We haven't moved into a new page so we can just move the cursor forward. */ - pDataStream->relativeCursor = newRelativeCursor; - return MA_SUCCESS; - } -} - - -MA_API ma_result ma_resource_manager_data_stream_read_pcm_frames(ma_resource_manager_data_stream* pDataStream, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint64 totalFramesProcessed; - ma_format format; - ma_uint32 channels; - - /* Safety. */ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (frameCount == 0) { - return MA_INVALID_ARGS; - } - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_stream_result(pDataStream) != MA_UNAVAILABLE); - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_stream_result(pDataStream) != MA_SUCCESS) { - return MA_INVALID_OPERATION; - } - - /* Don't attempt to read while we're in the middle of seeking. Tell the caller that we're busy. */ - if (ma_resource_manager_data_stream_seek_counter(pDataStream) > 0) { - return MA_BUSY; - } - - ma_resource_manager_data_stream_get_data_format(pDataStream, &format, &channels, NULL, NULL, 0); - - /* Reading is implemented in terms of map/unmap. We need to run this in a loop because mapping is clamped against page boundaries. */ - totalFramesProcessed = 0; - while (totalFramesProcessed < frameCount) { - void* pMappedFrames; - ma_uint64 mappedFrameCount; - - mappedFrameCount = frameCount - totalFramesProcessed; - result = ma_resource_manager_data_stream_map(pDataStream, &pMappedFrames, &mappedFrameCount); - if (result != MA_SUCCESS) { - break; - } - - /* Copy the mapped data to the output buffer if we have one. It's allowed for pFramesOut to be NULL in which case a relative forward seek is performed. */ - if (pFramesOut != NULL) { - ma_copy_pcm_frames(ma_offset_pcm_frames_ptr(pFramesOut, totalFramesProcessed, format, channels), pMappedFrames, mappedFrameCount, format, channels); - } - - totalFramesProcessed += mappedFrameCount; - - result = ma_resource_manager_data_stream_unmap(pDataStream, mappedFrameCount); - if (result != MA_SUCCESS) { - break; /* This is really bad - will only get an error here if we failed to post a job to the queue for loading the next page. */ - } - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesProcessed; - } - - if (result == MA_SUCCESS && totalFramesProcessed == 0) { - result = MA_AT_END; - } - - return result; -} - -MA_API ma_result ma_resource_manager_data_stream_seek_to_pcm_frame(ma_resource_manager_data_stream* pDataStream, ma_uint64 frameIndex) -{ - ma_job job; - ma_result streamResult; - - streamResult = ma_resource_manager_data_stream_result(pDataStream); - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(streamResult != MA_UNAVAILABLE); - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - if (streamResult != MA_SUCCESS && streamResult != MA_BUSY) { - return MA_INVALID_OPERATION; - } - - /* If we're not already seeking and we're sitting on the same frame, just make this a no-op. */ - if (c89atomic_load_32(&pDataStream->seekCounter) == 0) { - if (c89atomic_load_64(&pDataStream->absoluteCursor) == frameIndex) { - return MA_SUCCESS; - } - } - - - /* Increment the seek counter first to indicate to read_paged_pcm_frames() and map_paged_pcm_frames() that we are in the middle of a seek and MA_BUSY should be returned. */ - c89atomic_fetch_add_32(&pDataStream->seekCounter, 1); - - /* Update the absolute cursor so that ma_resource_manager_data_stream_get_cursor_in_pcm_frames() returns the new position. */ - ma_resource_manager_data_stream_set_absolute_cursor(pDataStream, frameIndex); - - /* - We need to clear our currently loaded pages so that the stream starts playback from the new seek point as soon as possible. These are for the purpose of the public - API and will be ignored by the seek job. The seek job will operate on the assumption that both pages have been marked as invalid and the cursor is at the start of - the first page. - */ - pDataStream->relativeCursor = 0; - pDataStream->currentPageIndex = 0; - c89atomic_exchange_32(&pDataStream->isPageValid[0], MA_FALSE); - c89atomic_exchange_32(&pDataStream->isPageValid[1], MA_FALSE); - - /* Make sure the data stream is not marked as at the end or else if we seek in response to hitting the end, we won't be able to read any more data. */ - c89atomic_exchange_32(&pDataStream->isDecoderAtEnd, MA_FALSE); - - /* - The public API is not allowed to touch the internal decoder so we need to use a job to perform the seek. When seeking, the job thread will assume both pages - are invalid and any content contained within them will be discarded and replaced with newly decoded data. - */ - job = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_SEEK_DATA_STREAM); - job.order = ma_resource_manager_data_stream_next_execution_order(pDataStream); - job.data.resourceManager.seekDataStream.pDataStream = pDataStream; - job.data.resourceManager.seekDataStream.frameIndex = frameIndex; - return ma_resource_manager_post_job(pDataStream->pResourceManager, &job); -} - -MA_API ma_result ma_resource_manager_data_stream_get_data_format(ma_resource_manager_data_stream* pDataStream, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_stream_result(pDataStream) != MA_UNAVAILABLE); - - if (pFormat != NULL) { - *pFormat = ma_format_unknown; - } - - if (pChannels != NULL) { - *pChannels = 0; - } - - if (pSampleRate != NULL) { - *pSampleRate = 0; - } - - if (pChannelMap != NULL) { - MA_ZERO_MEMORY(pChannelMap, sizeof(*pChannelMap) * channelMapCap); - } - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - if (ma_resource_manager_data_stream_result(pDataStream) != MA_SUCCESS) { - return MA_INVALID_OPERATION; - } - - /* - We're being a little bit naughty here and accessing the internal decoder from the public API. The output data format is constant, and we've defined this function - such that the application is responsible for ensuring it's not called while uninitializing so it should be safe. - */ - return ma_data_source_get_data_format(&pDataStream->decoder, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); -} - -MA_API ma_result ma_resource_manager_data_stream_get_cursor_in_pcm_frames(ma_resource_manager_data_stream* pDataStream, ma_uint64* pCursor) -{ - ma_result result; - - if (pCursor == NULL) { - return MA_INVALID_ARGS; - } - - *pCursor = 0; - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(ma_resource_manager_data_stream_result(pDataStream) != MA_UNAVAILABLE); - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - /* - If the stream is in an erroneous state we need to return an invalid operation. We can allow - this to be called when the data stream is in a busy state because the caller may have asked - for an initial seek position and it's convenient to return that as the cursor position. - */ - result = ma_resource_manager_data_stream_result(pDataStream); - if (result != MA_SUCCESS && result != MA_BUSY) { - return MA_INVALID_OPERATION; - } - - *pCursor = c89atomic_load_64(&pDataStream->absoluteCursor); - - return MA_SUCCESS; -} - -MA_API ma_result ma_resource_manager_data_stream_get_length_in_pcm_frames(ma_resource_manager_data_stream* pDataStream, ma_uint64* pLength) -{ - ma_result streamResult; - - if (pLength == NULL) { - return MA_INVALID_ARGS; - } - - *pLength = 0; - - streamResult = ma_resource_manager_data_stream_result(pDataStream); - - /* We cannot be using the data source after it's been uninitialized. */ - MA_ASSERT(streamResult != MA_UNAVAILABLE); - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - if (streamResult != MA_SUCCESS) { - return streamResult; - } - - /* - We most definitely do not want to be calling ma_decoder_get_length_in_pcm_frames() directly. Instead we want to use a cached value that we - calculated when we initialized it on the job thread. - */ - *pLength = pDataStream->totalLengthInPCMFrames; - if (*pLength == 0) { - return MA_NOT_IMPLEMENTED; /* Some decoders may not have a known length. */ - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_resource_manager_data_stream_result(const ma_resource_manager_data_stream* pDataStream) -{ - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - return (ma_result)c89atomic_load_i32(&pDataStream->result); -} - -MA_API ma_result ma_resource_manager_data_stream_set_looping(ma_resource_manager_data_stream* pDataStream, ma_bool32 isLooping) -{ - return ma_data_source_set_looping(pDataStream, isLooping); -} - -MA_API ma_bool32 ma_resource_manager_data_stream_is_looping(const ma_resource_manager_data_stream* pDataStream) -{ - if (pDataStream == NULL) { - return MA_FALSE; - } - - return c89atomic_load_32((ma_bool32*)&pDataStream->isLooping); /* Naughty const-cast. Value won't change from here in practice (maybe from another thread). */ -} - -MA_API ma_result ma_resource_manager_data_stream_get_available_frames(ma_resource_manager_data_stream* pDataStream, ma_uint64* pAvailableFrames) -{ - ma_uint32 pageIndex0; - ma_uint32 pageIndex1; - ma_uint32 relativeCursor; - ma_uint64 availableFrames; - - if (pAvailableFrames == NULL) { - return MA_INVALID_ARGS; - } - - *pAvailableFrames = 0; - - if (pDataStream == NULL) { - return MA_INVALID_ARGS; - } - - pageIndex0 = pDataStream->currentPageIndex; - pageIndex1 = (pDataStream->currentPageIndex + 1) & 0x01; - relativeCursor = pDataStream->relativeCursor; - - availableFrames = 0; - if (c89atomic_load_32(&pDataStream->isPageValid[pageIndex0])) { - availableFrames += c89atomic_load_32(&pDataStream->pageFrameCount[pageIndex0]) - relativeCursor; - if (c89atomic_load_32(&pDataStream->isPageValid[pageIndex1])) { - availableFrames += c89atomic_load_32(&pDataStream->pageFrameCount[pageIndex1]); - } - } - - *pAvailableFrames = availableFrames; - return MA_SUCCESS; -} - - -static ma_result ma_resource_manager_data_source_preinit(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_source* pDataSource) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDataSource); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pResourceManager == NULL) { - return MA_INVALID_ARGS; - } - - pDataSource->flags = pConfig->flags; - - return MA_SUCCESS; -} - -MA_API ma_result ma_resource_manager_data_source_init_ex(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source_config* pConfig, ma_resource_manager_data_source* pDataSource) -{ - ma_result result; - - result = ma_resource_manager_data_source_preinit(pResourceManager, pConfig, pDataSource); - if (result != MA_SUCCESS) { - return result; - } - - /* The data source itself is just a data stream or a data buffer. */ - if ((pConfig->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_init_ex(pResourceManager, pConfig, &pDataSource->backend.stream); - } else { - return ma_resource_manager_data_buffer_init_ex(pResourceManager, pConfig, &pDataSource->backend.buffer); - } -} - -MA_API ma_result ma_resource_manager_data_source_init(ma_resource_manager* pResourceManager, const char* pName, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_source* pDataSource) -{ - ma_resource_manager_data_source_config config; - - config = ma_resource_manager_data_source_config_init(); - config.pFilePath = pName; - config.flags = flags; - config.pNotifications = pNotifications; - - return ma_resource_manager_data_source_init_ex(pResourceManager, &config, pDataSource); -} - -MA_API ma_result ma_resource_manager_data_source_init_w(ma_resource_manager* pResourceManager, const wchar_t* pName, ma_uint32 flags, const ma_resource_manager_pipeline_notifications* pNotifications, ma_resource_manager_data_source* pDataSource) -{ - ma_resource_manager_data_source_config config; - - config = ma_resource_manager_data_source_config_init(); - config.pFilePathW = pName; - config.flags = flags; - config.pNotifications = pNotifications; - - return ma_resource_manager_data_source_init_ex(pResourceManager, &config, pDataSource); -} - -MA_API ma_result ma_resource_manager_data_source_init_copy(ma_resource_manager* pResourceManager, const ma_resource_manager_data_source* pExistingDataSource, ma_resource_manager_data_source* pDataSource) -{ - ma_result result; - ma_resource_manager_data_source_config config; - - if (pExistingDataSource == NULL) { - return MA_INVALID_ARGS; - } - - config = ma_resource_manager_data_source_config_init(); - config.flags = pExistingDataSource->flags; - - result = ma_resource_manager_data_source_preinit(pResourceManager, &config, pDataSource); - if (result != MA_SUCCESS) { - return result; - } - - /* Copying can only be done from data buffers. Streams cannot be copied. */ - if ((pExistingDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return MA_INVALID_OPERATION; - } - - return ma_resource_manager_data_buffer_init_copy(pResourceManager, &pExistingDataSource->backend.buffer, &pDataSource->backend.buffer); -} - -MA_API ma_result ma_resource_manager_data_source_uninit(ma_resource_manager_data_source* pDataSource) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - /* All we need to is uninitialize the underlying data buffer or data stream. */ - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_uninit(&pDataSource->backend.stream); - } else { - return ma_resource_manager_data_buffer_uninit(&pDataSource->backend.buffer); - } -} - -MA_API ma_result ma_resource_manager_data_source_read_pcm_frames(ma_resource_manager_data_source* pDataSource, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - /* Safety. */ - if (pFramesRead != NULL) { - *pFramesRead = 0; - } - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_read_pcm_frames(&pDataSource->backend.stream, pFramesOut, frameCount, pFramesRead); - } else { - return ma_resource_manager_data_buffer_read_pcm_frames(&pDataSource->backend.buffer, pFramesOut, frameCount, pFramesRead); - } -} - -MA_API ma_result ma_resource_manager_data_source_seek_to_pcm_frame(ma_resource_manager_data_source* pDataSource, ma_uint64 frameIndex) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_seek_to_pcm_frame(&pDataSource->backend.stream, frameIndex); - } else { - return ma_resource_manager_data_buffer_seek_to_pcm_frame(&pDataSource->backend.buffer, frameIndex); - } -} - -MA_API ma_result ma_resource_manager_data_source_map(ma_resource_manager_data_source* pDataSource, void** ppFramesOut, ma_uint64* pFrameCount) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_map(&pDataSource->backend.stream, ppFramesOut, pFrameCount); - } else { - return MA_NOT_IMPLEMENTED; /* Mapping not supported with data buffers. */ - } -} - -MA_API ma_result ma_resource_manager_data_source_unmap(ma_resource_manager_data_source* pDataSource, ma_uint64 frameCount) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_unmap(&pDataSource->backend.stream, frameCount); - } else { - return MA_NOT_IMPLEMENTED; /* Mapping not supported with data buffers. */ - } -} - -MA_API ma_result ma_resource_manager_data_source_get_data_format(ma_resource_manager_data_source* pDataSource, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_get_data_format(&pDataSource->backend.stream, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); - } else { - return ma_resource_manager_data_buffer_get_data_format(&pDataSource->backend.buffer, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); - } -} - -MA_API ma_result ma_resource_manager_data_source_get_cursor_in_pcm_frames(ma_resource_manager_data_source* pDataSource, ma_uint64* pCursor) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_get_cursor_in_pcm_frames(&pDataSource->backend.stream, pCursor); - } else { - return ma_resource_manager_data_buffer_get_cursor_in_pcm_frames(&pDataSource->backend.buffer, pCursor); - } -} - -MA_API ma_result ma_resource_manager_data_source_get_length_in_pcm_frames(ma_resource_manager_data_source* pDataSource, ma_uint64* pLength) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_get_length_in_pcm_frames(&pDataSource->backend.stream, pLength); - } else { - return ma_resource_manager_data_buffer_get_length_in_pcm_frames(&pDataSource->backend.buffer, pLength); - } -} - -MA_API ma_result ma_resource_manager_data_source_result(const ma_resource_manager_data_source* pDataSource) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_result(&pDataSource->backend.stream); - } else { - return ma_resource_manager_data_buffer_result(&pDataSource->backend.buffer); - } -} - -MA_API ma_result ma_resource_manager_data_source_set_looping(ma_resource_manager_data_source* pDataSource, ma_bool32 isLooping) -{ - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_set_looping(&pDataSource->backend.stream, isLooping); - } else { - return ma_resource_manager_data_buffer_set_looping(&pDataSource->backend.buffer, isLooping); - } -} - -MA_API ma_bool32 ma_resource_manager_data_source_is_looping(const ma_resource_manager_data_source* pDataSource) -{ - if (pDataSource == NULL) { - return MA_FALSE; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_is_looping(&pDataSource->backend.stream); - } else { - return ma_resource_manager_data_buffer_is_looping(&pDataSource->backend.buffer); - } -} - -MA_API ma_result ma_resource_manager_data_source_get_available_frames(ma_resource_manager_data_source* pDataSource, ma_uint64* pAvailableFrames) -{ - if (pAvailableFrames == NULL) { - return MA_INVALID_ARGS; - } - - *pAvailableFrames = 0; - - if (pDataSource == NULL) { - return MA_INVALID_ARGS; - } - - if ((pDataSource->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_STREAM) != 0) { - return ma_resource_manager_data_stream_get_available_frames(&pDataSource->backend.stream, pAvailableFrames); - } else { - return ma_resource_manager_data_buffer_get_available_frames(&pDataSource->backend.buffer, pAvailableFrames); - } -} - - -MA_API ma_result ma_resource_manager_post_job(ma_resource_manager* pResourceManager, const ma_job* pJob) -{ - if (pResourceManager == NULL) { - return MA_INVALID_ARGS; - } - - return ma_job_queue_post(&pResourceManager->jobQueue, pJob); -} - -MA_API ma_result ma_resource_manager_post_job_quit(ma_resource_manager* pResourceManager) -{ - ma_job job = ma_job_init(MA_JOB_TYPE_QUIT); - return ma_resource_manager_post_job(pResourceManager, &job); -} - -MA_API ma_result ma_resource_manager_next_job(ma_resource_manager* pResourceManager, ma_job* pJob) -{ - if (pResourceManager == NULL) { - return MA_INVALID_ARGS; - } - - return ma_job_queue_next(&pResourceManager->jobQueue, pJob); -} - - -static ma_result ma_job_process__resource_manager__load_data_buffer_node(ma_job* pJob) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager* pResourceManager; - ma_resource_manager_data_buffer_node* pDataBufferNode; - - MA_ASSERT(pJob != NULL); - - pResourceManager = (ma_resource_manager*)pJob->data.resourceManager.loadDataBufferNode.pResourceManager; - MA_ASSERT(pResourceManager != NULL); - - pDataBufferNode = (ma_resource_manager_data_buffer_node*)pJob->data.resourceManager.loadDataBufferNode.pDataBufferNode; - MA_ASSERT(pDataBufferNode != NULL); - MA_ASSERT(pDataBufferNode->isDataOwnedByResourceManager == MA_TRUE); /* The data should always be owned by the resource manager. */ - - /* The data buffer is not getting deleted, but we may be getting executed out of order. If so, we need to push the job back onto the queue and return. */ - if (pJob->order != c89atomic_load_32(&pDataBufferNode->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Attempting to execute out of order. Probably interleaved with a MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER job. */ - } - - /* First thing we need to do is check whether or not the data buffer is getting deleted. If so we just abort. */ - if (ma_resource_manager_data_buffer_node_result(pDataBufferNode) != MA_BUSY) { - result = ma_resource_manager_data_buffer_node_result(pDataBufferNode); /* The data buffer may be getting deleted before it's even been loaded. */ - goto done; - } - - /* - We're ready to start loading. Essentially what we're doing here is initializing the data supply - of the node. Once this is complete, data buffers can have their connectors initialized which - will allow then to have audio data read from them. - - Note that when the data supply type has been moved away from "unknown", that is when other threads - will determine that the node is available for data delivery and the data buffer connectors can be - initialized. Therefore, it's important that it is set after the data supply has been initialized. - */ - if ((pJob->data.resourceManager.loadDataBufferNode.flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_DECODE) != 0) { - /* - Decoding. This is the complex case because we're not going to be doing the entire decoding - process here. Instead it's going to be split of multiple jobs and loaded in pages. The - reason for this is to evenly distribute decoding time across multiple sounds, rather than - having one huge sound hog all the available processing resources. - - The first thing we do is initialize a decoder. This is allocated on the heap and is passed - around to the paging jobs. When the last paging job has completed it's processing, it'll - free the decoder for us. - - This job does not do any actual decoding. It instead just posts a PAGE_DATA_BUFFER_NODE job - which is where the actual decoding work will be done. However, once this job is complete, - the node will be in a state where data buffer connectors can be initialized. - */ - ma_decoder* pDecoder; /* <-- Free'd on the last page decode. */ - ma_job pageDataBufferNodeJob; - - /* Allocate the decoder by initializing a decoded data supply. */ - result = ma_resource_manager_data_buffer_node_init_supply_decoded(pResourceManager, pDataBufferNode, pJob->data.resourceManager.loadDataBufferNode.pFilePath, pJob->data.resourceManager.loadDataBufferNode.pFilePathW, pJob->data.resourceManager.loadDataBufferNode.flags, &pDecoder); - - /* - Don't ever propagate an MA_BUSY result code or else the resource manager will think the - node is just busy decoding rather than in an error state. This should never happen, but - including this logic for safety just in case. - */ - if (result == MA_BUSY) { - result = MA_ERROR; - } - - if (result != MA_SUCCESS) { - if (pJob->data.resourceManager.loadDataBufferNode.pFilePath != NULL) { - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Failed to initialize data supply for \"%s\". %s.\n", pJob->data.resourceManager.loadDataBufferNode.pFilePath, ma_result_description(result)); - } else { - #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(_MSC_VER) - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_WARNING, "Failed to initialize data supply for \"%ls\", %s.\n", pJob->data.resourceManager.loadDataBufferNode.pFilePathW, ma_result_description(result)); - #endif - } - - goto done; - } - - /* - At this point the node's data supply is initialized and other threads can start initializing - their data buffer connectors. However, no data will actually be available until we start to - actually decode it. To do this, we need to post a paging job which is where the decoding - work is done. - - Note that if an error occurred at an earlier point, this section will have been skipped. - */ - pageDataBufferNodeJob = ma_job_init(MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE); - pageDataBufferNodeJob.order = ma_resource_manager_data_buffer_node_next_execution_order(pDataBufferNode); - pageDataBufferNodeJob.data.resourceManager.pageDataBufferNode.pResourceManager = pResourceManager; - pageDataBufferNodeJob.data.resourceManager.pageDataBufferNode.pDataBufferNode = pDataBufferNode; - pageDataBufferNodeJob.data.resourceManager.pageDataBufferNode.pDecoder = pDecoder; - pageDataBufferNodeJob.data.resourceManager.pageDataBufferNode.pDoneNotification = pJob->data.resourceManager.loadDataBufferNode.pDoneNotification; - pageDataBufferNodeJob.data.resourceManager.pageDataBufferNode.pDoneFence = pJob->data.resourceManager.loadDataBufferNode.pDoneFence; - - /* The job has been set up so it can now be posted. */ - result = ma_resource_manager_post_job(pResourceManager, &pageDataBufferNodeJob); - - /* - When we get here, we want to make sure the result code is set to MA_BUSY. The reason for - this is that the result will be copied over to the node's internal result variable. In - this case, since the decoding is still in-progress, we need to make sure the result code - is set to MA_BUSY. - */ - if (result != MA_SUCCESS) { - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_ERROR, "Failed to post MA_JOB_TYPE_RESOURCE_MANAGER_PAGE_DATA_BUFFER_NODE job. %s\n", ma_result_description(result)); - ma_decoder_uninit(pDecoder); - ma_free(pDecoder, &pResourceManager->config.allocationCallbacks); - } else { - result = MA_BUSY; - } - } else { - /* No decoding. This is the simple case. We need only read the file content into memory and we're done. */ - result = ma_resource_manager_data_buffer_node_init_supply_encoded(pResourceManager, pDataBufferNode, pJob->data.resourceManager.loadDataBufferNode.pFilePath, pJob->data.resourceManager.loadDataBufferNode.pFilePathW); - } - - -done: - /* File paths are no longer needed. */ - ma_free(pJob->data.resourceManager.loadDataBufferNode.pFilePath, &pResourceManager->config.allocationCallbacks); - ma_free(pJob->data.resourceManager.loadDataBufferNode.pFilePathW, &pResourceManager->config.allocationCallbacks); - - /* - We need to set the result to at the very end to ensure no other threads try reading the data before we've fully initialized the object. Other threads - are going to be inspecting this variable to determine whether or not they're ready to read data. We can only change the result if it's set to MA_BUSY - because otherwise we may be changing away from an error code which would be bad. An example is if the application creates a data buffer, but then - immediately deletes it before we've got to this point. In this case, pDataBuffer->result will be MA_UNAVAILABLE, and setting it to MA_SUCCESS or any - other error code would cause the buffer to look like it's in a state that it's not. - */ - c89atomic_compare_and_swap_i32(&pDataBufferNode->result, MA_BUSY, result); - - /* At this point initialization is complete and we can signal the notification if any. */ - if (pJob->data.resourceManager.loadDataBufferNode.pInitNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.loadDataBufferNode.pInitNotification); - } - if (pJob->data.resourceManager.loadDataBufferNode.pInitFence != NULL) { - ma_fence_release(pJob->data.resourceManager.loadDataBufferNode.pInitFence); - } - - /* If we have a success result it means we've fully loaded the buffer. This will happen in the non-decoding case. */ - if (result != MA_BUSY) { - if (pJob->data.resourceManager.loadDataBufferNode.pDoneNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.loadDataBufferNode.pDoneNotification); - } - if (pJob->data.resourceManager.loadDataBufferNode.pDoneFence != NULL) { - ma_fence_release(pJob->data.resourceManager.loadDataBufferNode.pDoneFence); - } - } - - /* Increment the node's execution pointer so that the next jobs can be processed. This is how we keep decoding of pages in-order. */ - c89atomic_fetch_add_32(&pDataBufferNode->executionPointer, 1); - return result; -} - -static ma_result ma_job_process__resource_manager__free_data_buffer_node(ma_job* pJob) -{ - ma_resource_manager* pResourceManager; - ma_resource_manager_data_buffer_node* pDataBufferNode; - - MA_ASSERT(pJob != NULL); - - pResourceManager = (ma_resource_manager*)pJob->data.resourceManager.freeDataBufferNode.pResourceManager; - MA_ASSERT(pResourceManager != NULL); - - pDataBufferNode = (ma_resource_manager_data_buffer_node*)pJob->data.resourceManager.freeDataBufferNode.pDataBufferNode; - MA_ASSERT(pDataBufferNode != NULL); - - if (pJob->order != c89atomic_load_32(&pDataBufferNode->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - ma_resource_manager_data_buffer_node_free(pResourceManager, pDataBufferNode); - - /* The event needs to be signalled last. */ - if (pJob->data.resourceManager.freeDataBufferNode.pDoneNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.freeDataBufferNode.pDoneNotification); - } - - if (pJob->data.resourceManager.freeDataBufferNode.pDoneFence != NULL) { - ma_fence_release(pJob->data.resourceManager.freeDataBufferNode.pDoneFence); - } - - c89atomic_fetch_add_32(&pDataBufferNode->executionPointer, 1); - return MA_SUCCESS; -} - -static ma_result ma_job_process__resource_manager__page_data_buffer_node(ma_job* pJob) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager* pResourceManager; - ma_resource_manager_data_buffer_node* pDataBufferNode; - - MA_ASSERT(pJob != NULL); - - pResourceManager = (ma_resource_manager*)pJob->data.resourceManager.pageDataBufferNode.pResourceManager; - MA_ASSERT(pResourceManager != NULL); - - pDataBufferNode = (ma_resource_manager_data_buffer_node*)pJob->data.resourceManager.pageDataBufferNode.pDataBufferNode; - MA_ASSERT(pDataBufferNode != NULL); - - if (pJob->order != c89atomic_load_32(&pDataBufferNode->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - /* Don't do any more decoding if the data buffer has started the uninitialization process. */ - result = ma_resource_manager_data_buffer_node_result(pDataBufferNode); - if (result != MA_BUSY) { - goto done; - } - - /* We're ready to decode the next page. */ - result = ma_resource_manager_data_buffer_node_decode_next_page(pResourceManager, pDataBufferNode, (ma_decoder*)pJob->data.resourceManager.pageDataBufferNode.pDecoder); - - /* - If we have a success code by this point, we want to post another job. We're going to set the - result back to MA_BUSY to make it clear that there's still more to load. - */ - if (result == MA_SUCCESS) { - ma_job newJob; - newJob = *pJob; /* Everything is the same as the input job, except the execution order. */ - newJob.order = ma_resource_manager_data_buffer_node_next_execution_order(pDataBufferNode); /* We need a fresh execution order. */ - - result = ma_resource_manager_post_job(pResourceManager, &newJob); - - /* Since the sound isn't yet fully decoded we want the status to be set to busy. */ - if (result == MA_SUCCESS) { - result = MA_BUSY; - } - } - -done: - /* If there's still more to decode the result will be set to MA_BUSY. Otherwise we can free the decoder. */ - if (result != MA_BUSY) { - ma_decoder_uninit((ma_decoder*)pJob->data.resourceManager.pageDataBufferNode.pDecoder); - ma_free(pJob->data.resourceManager.pageDataBufferNode.pDecoder, &pResourceManager->config.allocationCallbacks); - } - - /* If we reached the end we need to treat it as successful. */ - if (result == MA_AT_END) { - result = MA_SUCCESS; - } - - /* Make sure we set the result of node in case some error occurred. */ - c89atomic_compare_and_swap_i32(&pDataBufferNode->result, MA_BUSY, result); - - /* Signal the notification after setting the result in case the notification callback wants to inspect the result code. */ - if (result != MA_BUSY) { - if (pJob->data.resourceManager.pageDataBufferNode.pDoneNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.pageDataBufferNode.pDoneNotification); - } - - if (pJob->data.resourceManager.pageDataBufferNode.pDoneFence != NULL) { - ma_fence_release(pJob->data.resourceManager.pageDataBufferNode.pDoneFence); - } - } - - c89atomic_fetch_add_32(&pDataBufferNode->executionPointer, 1); - return result; -} - - -static ma_result ma_job_process__resource_manager__load_data_buffer(ma_job* pJob) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager* pResourceManager; - ma_resource_manager_data_buffer* pDataBuffer; - ma_resource_manager_data_supply_type dataSupplyType = ma_resource_manager_data_supply_type_unknown; - ma_bool32 isConnectorInitialized = MA_FALSE; - - /* - All we're doing here is checking if the node has finished loading. If not, we just re-post the job - and keep waiting. Otherwise we increment the execution counter and set the buffer's result code. - */ - MA_ASSERT(pJob != NULL); - - pDataBuffer = (ma_resource_manager_data_buffer*)pJob->data.resourceManager.loadDataBuffer.pDataBuffer; - MA_ASSERT(pDataBuffer != NULL); - - pResourceManager = pDataBuffer->pResourceManager; - - if (pJob->order != c89atomic_load_32(&pDataBuffer->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Attempting to execute out of order. Probably interleaved with a MA_JOB_TYPE_RESOURCE_MANAGER_FREE_DATA_BUFFER job. */ - } - - /* - First thing we need to do is check whether or not the data buffer is getting deleted. If so we - just abort, but making sure we increment the execution pointer. - */ - result = ma_resource_manager_data_buffer_result(pDataBuffer); - if (result != MA_BUSY) { - goto done; /* <-- This will ensure the exucution pointer is incremented. */ - } else { - result = MA_SUCCESS; /* <-- Make sure this is reset. */ - } - - /* Try initializing the connector if we haven't already. */ - isConnectorInitialized = ma_resource_manager_data_buffer_has_connector(pDataBuffer); - if (isConnectorInitialized == MA_FALSE) { - dataSupplyType = ma_resource_manager_data_buffer_node_get_data_supply_type(pDataBuffer->pNode); - - if (dataSupplyType != ma_resource_manager_data_supply_type_unknown) { - /* We can now initialize the connector. If this fails, we need to abort. It's very rare for this to fail. */ - ma_resource_manager_data_source_config dataSourceConfig; /* For setting initial looping state and range. */ - dataSourceConfig = ma_resource_manager_data_source_config_init(); - dataSourceConfig.rangeBegInPCMFrames = pJob->data.resourceManager.loadDataBuffer.rangeBegInPCMFrames; - dataSourceConfig.rangeEndInPCMFrames = pJob->data.resourceManager.loadDataBuffer.rangeEndInPCMFrames; - dataSourceConfig.loopPointBegInPCMFrames = pJob->data.resourceManager.loadDataBuffer.loopPointBegInPCMFrames; - dataSourceConfig.loopPointEndInPCMFrames = pJob->data.resourceManager.loadDataBuffer.loopPointEndInPCMFrames; - dataSourceConfig.isLooping = pJob->data.resourceManager.loadDataBuffer.isLooping; - - result = ma_resource_manager_data_buffer_init_connector(pDataBuffer, &dataSourceConfig, pJob->data.resourceManager.loadDataBuffer.pInitNotification, pJob->data.resourceManager.loadDataBuffer.pInitFence); - if (result != MA_SUCCESS) { - ma_log_postf(ma_resource_manager_get_log(pResourceManager), MA_LOG_LEVEL_ERROR, "Failed to initialize connector for data buffer. %s.\n", ma_result_description(result)); - goto done; - } - } else { - /* Don't have a known data supply type. Most likely the data buffer node is still loading, but it could be that an error occurred. */ - } - } else { - /* The connector is already initialized. Nothing to do here. */ - } - - /* - If the data node is still loading, we need to repost the job and *not* increment the execution - pointer (i.e. we need to not fall through to the "done" label). - - There is a hole between here and the where the data connector is initialized where the data - buffer node may have finished initializing. We need to check for this by checking the result of - the data buffer node and whether or not we had an unknown data supply type at the time of - trying to initialize the data connector. - */ - result = ma_resource_manager_data_buffer_node_result(pDataBuffer->pNode); - if (result == MA_BUSY || (result == MA_SUCCESS && isConnectorInitialized == MA_FALSE && dataSupplyType == ma_resource_manager_data_supply_type_unknown)) { - return ma_resource_manager_post_job(pResourceManager, pJob); - } - -done: - /* Only move away from a busy code so that we don't trash any existing error codes. */ - c89atomic_compare_and_swap_i32(&pDataBuffer->result, MA_BUSY, result); - - /* Only signal the other threads after the result has been set just for cleanliness sake. */ - if (pJob->data.resourceManager.loadDataBuffer.pDoneNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.loadDataBuffer.pDoneNotification); - } - if (pJob->data.resourceManager.loadDataBuffer.pDoneFence != NULL) { - ma_fence_release(pJob->data.resourceManager.loadDataBuffer.pDoneFence); - } - - /* - If at this point the data buffer has not had it's connector initialized, it means the - notification event was never signalled which means we need to signal it here. - */ - if (ma_resource_manager_data_buffer_has_connector(pDataBuffer) == MA_FALSE && result != MA_SUCCESS) { - if (pJob->data.resourceManager.loadDataBuffer.pInitNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.loadDataBuffer.pInitNotification); - } - if (pJob->data.resourceManager.loadDataBuffer.pInitFence != NULL) { - ma_fence_release(pJob->data.resourceManager.loadDataBuffer.pInitFence); - } - } - - c89atomic_fetch_add_32(&pDataBuffer->executionPointer, 1); - return result; -} - -static ma_result ma_job_process__resource_manager__free_data_buffer(ma_job* pJob) -{ - ma_resource_manager* pResourceManager; - ma_resource_manager_data_buffer* pDataBuffer; - - MA_ASSERT(pJob != NULL); - - pDataBuffer = (ma_resource_manager_data_buffer*)pJob->data.resourceManager.freeDataBuffer.pDataBuffer; - MA_ASSERT(pDataBuffer != NULL); - - pResourceManager = pDataBuffer->pResourceManager; - - if (pJob->order != c89atomic_load_32(&pDataBuffer->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - ma_resource_manager_data_buffer_uninit_internal(pDataBuffer); - - /* The event needs to be signalled last. */ - if (pJob->data.resourceManager.freeDataBuffer.pDoneNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.freeDataBuffer.pDoneNotification); - } - - if (pJob->data.resourceManager.freeDataBuffer.pDoneFence != NULL) { - ma_fence_release(pJob->data.resourceManager.freeDataBuffer.pDoneFence); - } - - c89atomic_fetch_add_32(&pDataBuffer->executionPointer, 1); - return MA_SUCCESS; -} - -static ma_result ma_job_process__resource_manager__load_data_stream(ma_job* pJob) -{ - ma_result result = MA_SUCCESS; - ma_decoder_config decoderConfig; - ma_uint32 pageBufferSizeInBytes; - ma_resource_manager* pResourceManager; - ma_resource_manager_data_stream* pDataStream; - - MA_ASSERT(pJob != NULL); - - pDataStream = (ma_resource_manager_data_stream*)pJob->data.resourceManager.loadDataStream.pDataStream; - MA_ASSERT(pDataStream != NULL); - - pResourceManager = pDataStream->pResourceManager; - - if (pJob->order != c89atomic_load_32(&pDataStream->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - if (ma_resource_manager_data_stream_result(pDataStream) != MA_BUSY) { - result = MA_INVALID_OPERATION; /* Most likely the data stream is being uninitialized. */ - goto done; - } - - /* We need to initialize the decoder first so we can determine the size of the pages. */ - decoderConfig = ma_resource_manager__init_decoder_config(pResourceManager); - - if (pJob->data.resourceManager.loadDataStream.pFilePath != NULL) { - result = ma_decoder_init_vfs(pResourceManager->config.pVFS, pJob->data.resourceManager.loadDataStream.pFilePath, &decoderConfig, &pDataStream->decoder); - } else { - result = ma_decoder_init_vfs_w(pResourceManager->config.pVFS, pJob->data.resourceManager.loadDataStream.pFilePathW, &decoderConfig, &pDataStream->decoder); - } - if (result != MA_SUCCESS) { - goto done; - } - - /* Retrieve the total length of the file before marking the decoder as loaded. */ - if ((pDataStream->flags & MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_UNKNOWN_LENGTH) == 0) { - result = ma_decoder_get_length_in_pcm_frames(&pDataStream->decoder, &pDataStream->totalLengthInPCMFrames); - if (result != MA_SUCCESS) { - goto done; /* Failed to retrieve the length. */ - } - } else { - pDataStream->totalLengthInPCMFrames = 0; - } - - /* - Only mark the decoder as initialized when the length of the decoder has been retrieved because that can possibly require a scan over the whole file - and we don't want to have another thread trying to access the decoder while it's scanning. - */ - pDataStream->isDecoderInitialized = MA_TRUE; - - /* We have the decoder so we can now initialize our page buffer. */ - pageBufferSizeInBytes = ma_resource_manager_data_stream_get_page_size_in_frames(pDataStream) * 2 * ma_get_bytes_per_frame(pDataStream->decoder.outputFormat, pDataStream->decoder.outputChannels); - - pDataStream->pPageData = ma_malloc(pageBufferSizeInBytes, &pResourceManager->config.allocationCallbacks); - if (pDataStream->pPageData == NULL) { - ma_decoder_uninit(&pDataStream->decoder); - result = MA_OUT_OF_MEMORY; - goto done; - } - - /* Seek to our initial seek point before filling the initial pages. */ - ma_decoder_seek_to_pcm_frame(&pDataStream->decoder, pJob->data.resourceManager.loadDataStream.initialSeekPoint); - - /* We have our decoder and our page buffer, so now we need to fill our pages. */ - ma_resource_manager_data_stream_fill_pages(pDataStream); - - /* And now we're done. We want to make sure the result is MA_SUCCESS. */ - result = MA_SUCCESS; - -done: - ma_free(pJob->data.resourceManager.loadDataStream.pFilePath, &pResourceManager->config.allocationCallbacks); - ma_free(pJob->data.resourceManager.loadDataStream.pFilePathW, &pResourceManager->config.allocationCallbacks); - - /* We can only change the status away from MA_BUSY. If it's set to anything else it means an error has occurred somewhere or the uninitialization process has started (most likely). */ - c89atomic_compare_and_swap_i32(&pDataStream->result, MA_BUSY, result); - - /* Only signal the other threads after the result has been set just for cleanliness sake. */ - if (pJob->data.resourceManager.loadDataStream.pInitNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.loadDataStream.pInitNotification); - } - if (pJob->data.resourceManager.loadDataStream.pInitFence != NULL) { - ma_fence_release(pJob->data.resourceManager.loadDataStream.pInitFence); - } - - c89atomic_fetch_add_32(&pDataStream->executionPointer, 1); - return result; -} - -static ma_result ma_job_process__resource_manager__free_data_stream(ma_job* pJob) -{ - ma_resource_manager* pResourceManager; - ma_resource_manager_data_stream* pDataStream; - - MA_ASSERT(pJob != NULL); - - pDataStream = (ma_resource_manager_data_stream*)pJob->data.resourceManager.freeDataStream.pDataStream; - MA_ASSERT(pDataStream != NULL); - - pResourceManager = pDataStream->pResourceManager; - - if (pJob->order != c89atomic_load_32(&pDataStream->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - /* If our status is not MA_UNAVAILABLE we have a bug somewhere. */ - MA_ASSERT(ma_resource_manager_data_stream_result(pDataStream) == MA_UNAVAILABLE); - - if (pDataStream->isDecoderInitialized) { - ma_decoder_uninit(&pDataStream->decoder); - } - - if (pDataStream->pPageData != NULL) { - ma_free(pDataStream->pPageData, &pResourceManager->config.allocationCallbacks); - pDataStream->pPageData = NULL; /* Just in case... */ - } - - ma_data_source_uninit(&pDataStream->ds); - - /* The event needs to be signalled last. */ - if (pJob->data.resourceManager.freeDataStream.pDoneNotification != NULL) { - ma_async_notification_signal(pJob->data.resourceManager.freeDataStream.pDoneNotification); - } - if (pJob->data.resourceManager.freeDataStream.pDoneFence != NULL) { - ma_fence_release(pJob->data.resourceManager.freeDataStream.pDoneFence); - } - - /*c89atomic_fetch_add_32(&pDataStream->executionPointer, 1);*/ - return MA_SUCCESS; -} - -static ma_result ma_job_process__resource_manager__page_data_stream(ma_job* pJob) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager* pResourceManager; - ma_resource_manager_data_stream* pDataStream; - - MA_ASSERT(pJob != NULL); - - pDataStream = (ma_resource_manager_data_stream*)pJob->data.resourceManager.pageDataStream.pDataStream; - MA_ASSERT(pDataStream != NULL); - - pResourceManager = pDataStream->pResourceManager; - - if (pJob->order != c89atomic_load_32(&pDataStream->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - /* For streams, the status should be MA_SUCCESS. */ - if (ma_resource_manager_data_stream_result(pDataStream) != MA_SUCCESS) { - result = MA_INVALID_OPERATION; - goto done; - } - - ma_resource_manager_data_stream_fill_page(pDataStream, pJob->data.resourceManager.pageDataStream.pageIndex); - -done: - c89atomic_fetch_add_32(&pDataStream->executionPointer, 1); - return result; -} - -static ma_result ma_job_process__resource_manager__seek_data_stream(ma_job* pJob) -{ - ma_result result = MA_SUCCESS; - ma_resource_manager* pResourceManager; - ma_resource_manager_data_stream* pDataStream; - - MA_ASSERT(pJob != NULL); - - pDataStream = (ma_resource_manager_data_stream*)pJob->data.resourceManager.seekDataStream.pDataStream; - MA_ASSERT(pDataStream != NULL); - - pResourceManager = pDataStream->pResourceManager; - - if (pJob->order != c89atomic_load_32(&pDataStream->executionPointer)) { - return ma_resource_manager_post_job(pResourceManager, pJob); /* Out of order. */ - } - - /* For streams the status should be MA_SUCCESS for this to do anything. */ - if (ma_resource_manager_data_stream_result(pDataStream) != MA_SUCCESS || pDataStream->isDecoderInitialized == MA_FALSE) { - result = MA_INVALID_OPERATION; - goto done; - } - - /* - With seeking we just assume both pages are invalid and the relative frame cursor at position 0. This is basically exactly the same as loading, except - instead of initializing the decoder, we seek to a frame. - */ - ma_decoder_seek_to_pcm_frame(&pDataStream->decoder, pJob->data.resourceManager.seekDataStream.frameIndex); - - /* After seeking we'll need to reload the pages. */ - ma_resource_manager_data_stream_fill_pages(pDataStream); - - /* We need to let the public API know that we're done seeking. */ - c89atomic_fetch_sub_32(&pDataStream->seekCounter, 1); - -done: - c89atomic_fetch_add_32(&pDataStream->executionPointer, 1); - return result; -} - -MA_API ma_result ma_resource_manager_process_job(ma_resource_manager* pResourceManager, ma_job* pJob) -{ - if (pResourceManager == NULL || pJob == NULL) { - return MA_INVALID_ARGS; - } - - return ma_job_process(pJob); -} - -MA_API ma_result ma_resource_manager_process_next_job(ma_resource_manager* pResourceManager) -{ - ma_result result; - ma_job job; - - if (pResourceManager == NULL) { - return MA_INVALID_ARGS; - } - - /* This will return MA_CANCELLED if the next job is a quit job. */ - result = ma_resource_manager_next_job(pResourceManager, &job); - if (result != MA_SUCCESS) { - return result; - } - - return ma_job_process(&job); -} -#else -/* We'll get here if the resource manager is being excluded from the build. We need to define the job processing callbacks as no-ops. */ -static ma_result ma_job_process__resource_manager__load_data_buffer_node(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__free_data_buffer_node(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__page_data_buffer_node(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__load_data_buffer(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__free_data_buffer(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__load_data_stream(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__free_data_stream(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__page_data_stream(ma_job* pJob) { return ma_job_process__noop(pJob); } -static ma_result ma_job_process__resource_manager__seek_data_stream(ma_job* pJob) { return ma_job_process__noop(pJob); } -#endif /* MA_NO_RESOURCE_MANAGER */ - - -#ifndef MA_NO_NODE_GRAPH -/* 10ms @ 48K = 480. Must never exceed 65535. */ -#ifndef MA_DEFAULT_NODE_CACHE_CAP_IN_FRAMES_PER_BUS -#define MA_DEFAULT_NODE_CACHE_CAP_IN_FRAMES_PER_BUS 480 -#endif - - -static ma_result ma_node_read_pcm_frames(ma_node* pNode, ma_uint32 outputBusIndex, float* pFramesOut, ma_uint32 frameCount, ma_uint32* pFramesRead, ma_uint64 globalTime); - -MA_API void ma_debug_fill_pcm_frames_with_sine_wave(float* pFramesOut, ma_uint32 frameCount, ma_format format, ma_uint32 channels, ma_uint32 sampleRate) -{ - #ifndef MA_NO_GENERATION - { - ma_waveform_config waveformConfig; - ma_waveform waveform; - - waveformConfig = ma_waveform_config_init(format, channels, sampleRate, ma_waveform_type_sine, 1.0, 400); - ma_waveform_init(&waveformConfig, &waveform); - ma_waveform_read_pcm_frames(&waveform, pFramesOut, frameCount, NULL); - } - #else - { - (void)pFramesOut; - (void)frameCount; - (void)format; - (void)channels; - (void)sampleRate; - #if defined(MA_DEBUG_OUTPUT) - { - #if _MSC_VER - #pragma message ("ma_debug_fill_pcm_frames_with_sine_wave() will do nothing because MA_NO_GENERATION is enabled.") - #endif - } - #endif - } - #endif -} - - - -MA_API ma_node_graph_config ma_node_graph_config_init(ma_uint32 channels) -{ - ma_node_graph_config config; - - MA_ZERO_OBJECT(&config); - config.channels = channels; - config.nodeCacheCapInFrames = MA_DEFAULT_NODE_CACHE_CAP_IN_FRAMES_PER_BUS; - - return config; -} - - -static void ma_node_graph_set_is_reading(ma_node_graph* pNodeGraph, ma_bool32 isReading) -{ - MA_ASSERT(pNodeGraph != NULL); - c89atomic_exchange_32(&pNodeGraph->isReading, isReading); -} - -#if 0 -static ma_bool32 ma_node_graph_is_reading(ma_node_graph* pNodeGraph) -{ - MA_ASSERT(pNodeGraph != NULL); - return c89atomic_load_32(&pNodeGraph->isReading); -} -#endif - - -static void ma_node_graph_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_node_graph* pNodeGraph = (ma_node_graph*)pNode; - ma_uint64 framesRead; - - ma_node_graph_read_pcm_frames(pNodeGraph, ppFramesOut[0], *pFrameCountOut, &framesRead); - - *pFrameCountOut = (ma_uint32)framesRead; /* Safe cast. */ - - (void)ppFramesIn; - (void)pFrameCountIn; -} - -static ma_node_vtable g_node_graph_node_vtable = -{ - ma_node_graph_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 0, /* 0 input buses. */ - 1, /* 1 output bus. */ - 0 /* Flags. */ -}; - -static void ma_node_graph_endpoint_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - MA_ASSERT(pNode != NULL); - MA_ASSERT(ma_node_get_input_bus_count(pNode) == 1); - MA_ASSERT(ma_node_get_output_bus_count(pNode) == 1); - - /* Input channel count needs to be the same as the output channel count. */ - MA_ASSERT(ma_node_get_input_channels(pNode, 0) == ma_node_get_output_channels(pNode, 0)); - - /* We don't need to do anything here because it's a passthrough. */ - (void)pNode; - (void)ppFramesIn; - (void)pFrameCountIn; - (void)ppFramesOut; - (void)pFrameCountOut; - -#if 0 - /* The data has already been mixed. We just need to move it to the output buffer. */ - if (ppFramesIn != NULL) { - ma_copy_pcm_frames(ppFramesOut[0], ppFramesIn[0], *pFrameCountOut, ma_format_f32, ma_node_get_output_channels(pNode, 0)); - } -#endif -} - -static ma_node_vtable g_node_graph_endpoint_vtable = -{ - ma_node_graph_endpoint_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* 1 input bus. */ - 1, /* 1 output bus. */ - MA_NODE_FLAG_PASSTHROUGH /* Flags. The endpoint is a passthrough. */ -}; - -MA_API ma_result ma_node_graph_init(const ma_node_graph_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_node_graph* pNodeGraph) -{ - ma_result result; - ma_node_config baseConfig; - ma_node_config endpointConfig; - - if (pNodeGraph == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNodeGraph); - pNodeGraph->nodeCacheCapInFrames = pConfig->nodeCacheCapInFrames; - if (pNodeGraph->nodeCacheCapInFrames == 0) { - pNodeGraph->nodeCacheCapInFrames = MA_DEFAULT_NODE_CACHE_CAP_IN_FRAMES_PER_BUS; - } - - - /* Base node so we can use the node graph as a node into another graph. */ - baseConfig = ma_node_config_init(); - baseConfig.vtable = &g_node_graph_node_vtable; - baseConfig.pOutputChannels = &pConfig->channels; - - result = ma_node_init(pNodeGraph, &baseConfig, pAllocationCallbacks, &pNodeGraph->base); - if (result != MA_SUCCESS) { - return result; - } - - - /* Endpoint. */ - endpointConfig = ma_node_config_init(); - endpointConfig.vtable = &g_node_graph_endpoint_vtable; - endpointConfig.pInputChannels = &pConfig->channels; - endpointConfig.pOutputChannels = &pConfig->channels; - - result = ma_node_init(pNodeGraph, &endpointConfig, pAllocationCallbacks, &pNodeGraph->endpoint); - if (result != MA_SUCCESS) { - ma_node_uninit(&pNodeGraph->base, pAllocationCallbacks); - return result; - } - - return MA_SUCCESS; -} - -MA_API void ma_node_graph_uninit(ma_node_graph* pNodeGraph, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pNodeGraph == NULL) { - return; - } - - ma_node_uninit(&pNodeGraph->endpoint, pAllocationCallbacks); -} - -MA_API ma_node* ma_node_graph_get_endpoint(ma_node_graph* pNodeGraph) -{ - if (pNodeGraph == NULL) { - return NULL; - } - - return &pNodeGraph->endpoint; -} - -MA_API ma_result ma_node_graph_read_pcm_frames(ma_node_graph* pNodeGraph, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - ma_result result = MA_SUCCESS; - ma_uint64 totalFramesRead; - ma_uint32 channels; - - if (pFramesRead != NULL) { - *pFramesRead = 0; /* Safety. */ - } - - if (pNodeGraph == NULL) { - return MA_INVALID_ARGS; - } - - channels = ma_node_get_output_channels(&pNodeGraph->endpoint, 0); - - - /* We'll be nice and try to do a full read of all frameCount frames. */ - totalFramesRead = 0; - while (totalFramesRead < frameCount) { - ma_uint32 framesJustRead; - ma_uint64 framesToRead = frameCount - totalFramesRead; - - if (framesToRead > 0xFFFFFFFF) { - framesToRead = 0xFFFFFFFF; - } - - ma_node_graph_set_is_reading(pNodeGraph, MA_TRUE); - { - result = ma_node_read_pcm_frames(&pNodeGraph->endpoint, 0, (float*)ma_offset_pcm_frames_ptr(pFramesOut, totalFramesRead, ma_format_f32, channels), (ma_uint32)framesToRead, &framesJustRead, ma_node_get_time(&pNodeGraph->endpoint)); - } - ma_node_graph_set_is_reading(pNodeGraph, MA_FALSE); - - totalFramesRead += framesJustRead; - - if (result != MA_SUCCESS) { - break; - } - - /* Abort if we weren't able to read any frames or else we risk getting stuck in a loop. */ - if (framesJustRead == 0) { - break; - } - } - - /* Let's go ahead and silence any leftover frames just for some added safety to ensure the caller doesn't try emitting garbage out of the speakers. */ - if (totalFramesRead < frameCount) { - ma_silence_pcm_frames(ma_offset_pcm_frames_ptr(pFramesOut, totalFramesRead, ma_format_f32, channels), (frameCount - totalFramesRead), ma_format_f32, channels); - } - - if (pFramesRead != NULL) { - *pFramesRead = totalFramesRead; - } - - return result; -} - -MA_API ma_uint32 ma_node_graph_get_channels(const ma_node_graph* pNodeGraph) -{ - if (pNodeGraph == NULL) { - return 0; - } - - return ma_node_get_output_channels(&pNodeGraph->endpoint, 0); -} - -MA_API ma_uint64 ma_node_graph_get_time(const ma_node_graph* pNodeGraph) -{ - if (pNodeGraph == NULL) { - return 0; - } - - return ma_node_get_time(&pNodeGraph->endpoint); /* Global time is just the local time of the endpoint. */ -} - -MA_API ma_result ma_node_graph_set_time(ma_node_graph* pNodeGraph, ma_uint64 globalTime) -{ - if (pNodeGraph == NULL) { - return MA_INVALID_ARGS; - } - - return ma_node_set_time(&pNodeGraph->endpoint, globalTime); /* Global time is just the local time of the endpoint. */ -} - - -#define MA_NODE_OUTPUT_BUS_FLAG_HAS_READ 0x01 /* Whether or not this bus ready to read more data. Only used on nodes with multiple output buses. */ - -static ma_result ma_node_output_bus_init(ma_node* pNode, ma_uint32 outputBusIndex, ma_uint32 channels, ma_node_output_bus* pOutputBus) -{ - MA_ASSERT(pOutputBus != NULL); - MA_ASSERT(outputBusIndex < MA_MAX_NODE_BUS_COUNT); - MA_ASSERT(outputBusIndex < ma_node_get_output_bus_count(pNode)); - MA_ASSERT(channels < 256); - - MA_ZERO_OBJECT(pOutputBus); - - if (channels == 0) { - return MA_INVALID_ARGS; - } - - pOutputBus->pNode = pNode; - pOutputBus->outputBusIndex = (ma_uint8)outputBusIndex; - pOutputBus->channels = (ma_uint8)channels; - pOutputBus->flags = MA_NODE_OUTPUT_BUS_FLAG_HAS_READ; /* <-- Important that this flag is set by default. */ - pOutputBus->volume = 1; - - return MA_SUCCESS; -} - -static void ma_node_output_bus_lock(ma_node_output_bus* pOutputBus) -{ - ma_spinlock_lock(&pOutputBus->lock); -} - -static void ma_node_output_bus_unlock(ma_node_output_bus* pOutputBus) -{ - ma_spinlock_unlock(&pOutputBus->lock); -} - - -static ma_uint32 ma_node_output_bus_get_channels(const ma_node_output_bus* pOutputBus) -{ - return pOutputBus->channels; -} - - -static void ma_node_output_bus_set_has_read(ma_node_output_bus* pOutputBus, ma_bool32 hasRead) -{ - if (hasRead) { - c89atomic_fetch_or_32(&pOutputBus->flags, MA_NODE_OUTPUT_BUS_FLAG_HAS_READ); - } else { - c89atomic_fetch_and_32(&pOutputBus->flags, (ma_uint32)~MA_NODE_OUTPUT_BUS_FLAG_HAS_READ); - } -} - -static ma_bool32 ma_node_output_bus_has_read(ma_node_output_bus* pOutputBus) -{ - return (c89atomic_load_32(&pOutputBus->flags) & MA_NODE_OUTPUT_BUS_FLAG_HAS_READ) != 0; -} - - -static void ma_node_output_bus_set_is_attached(ma_node_output_bus* pOutputBus, ma_bool32 isAttached) -{ - c89atomic_exchange_32(&pOutputBus->isAttached, isAttached); -} - -static ma_bool32 ma_node_output_bus_is_attached(ma_node_output_bus* pOutputBus) -{ - return c89atomic_load_32(&pOutputBus->isAttached); -} - - -static ma_result ma_node_output_bus_set_volume(ma_node_output_bus* pOutputBus, float volume) -{ - MA_ASSERT(pOutputBus != NULL); - - if (volume < 0.0f) { - volume = 0.0f; - } - - c89atomic_exchange_f32(&pOutputBus->volume, volume); - - return MA_SUCCESS; -} - -static float ma_node_output_bus_get_volume(const ma_node_output_bus* pOutputBus) -{ - return c89atomic_load_f32((float*)&pOutputBus->volume); -} - - -static ma_result ma_node_input_bus_init(ma_uint32 channels, ma_node_input_bus* pInputBus) -{ - MA_ASSERT(pInputBus != NULL); - MA_ASSERT(channels < 256); - - MA_ZERO_OBJECT(pInputBus); - - if (channels == 0) { - return MA_INVALID_ARGS; - } - - pInputBus->channels = (ma_uint8)channels; - - return MA_SUCCESS; -} - -static void ma_node_input_bus_lock(ma_node_input_bus* pInputBus) -{ - MA_ASSERT(pInputBus != NULL); - - ma_spinlock_lock(&pInputBus->lock); -} - -static void ma_node_input_bus_unlock(ma_node_input_bus* pInputBus) -{ - MA_ASSERT(pInputBus != NULL); - - ma_spinlock_unlock(&pInputBus->lock); -} - - -static void ma_node_input_bus_next_begin(ma_node_input_bus* pInputBus) -{ - c89atomic_fetch_add_32(&pInputBus->nextCounter, 1); -} - -static void ma_node_input_bus_next_end(ma_node_input_bus* pInputBus) -{ - c89atomic_fetch_sub_32(&pInputBus->nextCounter, 1); -} - -static ma_uint32 ma_node_input_bus_get_next_counter(ma_node_input_bus* pInputBus) -{ - return c89atomic_load_32(&pInputBus->nextCounter); -} - - -static ma_uint32 ma_node_input_bus_get_channels(const ma_node_input_bus* pInputBus) -{ - return pInputBus->channels; -} - - -static void ma_node_input_bus_detach__no_output_bus_lock(ma_node_input_bus* pInputBus, ma_node_output_bus* pOutputBus) -{ - MA_ASSERT(pInputBus != NULL); - MA_ASSERT(pOutputBus != NULL); - - /* - Mark the output bus as detached first. This will prevent future iterations on the audio thread - from iterating this output bus. - */ - ma_node_output_bus_set_is_attached(pOutputBus, MA_FALSE); - - /* - We cannot use the output bus lock here since it'll be getting used at a higher level, but we do - still need to use the input bus lock since we'll be updating pointers on two different output - buses. The same rules apply here as the attaching case. Although we're using a lock here, we're - *not* using a lock when iterating over the list in the audio thread. We therefore need to craft - this in a way such that the iteration on the audio thread doesn't break. - - The the first thing to do is swap out the "next" pointer of the previous output bus with the - new "next" output bus. This is the operation that matters for iteration on the audio thread. - After that, the previous pointer on the new "next" pointer needs to be updated, after which - point the linked list will be in a good state. - */ - ma_node_input_bus_lock(pInputBus); - { - ma_node_output_bus* pOldPrev = (ma_node_output_bus*)c89atomic_load_ptr(&pOutputBus->pPrev); - ma_node_output_bus* pOldNext = (ma_node_output_bus*)c89atomic_load_ptr(&pOutputBus->pNext); - - if (pOldPrev != NULL) { - c89atomic_exchange_ptr(&pOldPrev->pNext, pOldNext); /* <-- This is where the output bus is detached from the list. */ - } - if (pOldNext != NULL) { - c89atomic_exchange_ptr(&pOldNext->pPrev, pOldPrev); /* <-- This is required for detachment. */ - } - } - ma_node_input_bus_unlock(pInputBus); - - /* At this point the output bus is detached and the linked list is completely unaware of it. Reset some data for safety. */ - c89atomic_exchange_ptr(&pOutputBus->pNext, NULL); /* Using atomic exchanges here, mainly for the benefit of analysis tools which don't always recognize spinlocks. */ - c89atomic_exchange_ptr(&pOutputBus->pPrev, NULL); /* As above. */ - pOutputBus->pInputNode = NULL; - pOutputBus->inputNodeInputBusIndex = 0; - - - /* - For thread-safety reasons, we don't want to be returning from this straight away. We need to - wait for the audio thread to finish with the output bus. There's two things we need to wait - for. The first is the part that selects the next output bus in the list, and the other is the - part that reads from the output bus. Basically all we're doing is waiting for the input bus - to stop referencing the output bus. - - We're doing this part last because we want the section above to run while the audio thread - is finishing up with the output bus, just for efficiency reasons. We marked the output bus as - detached right at the top of this function which is going to prevent the audio thread from - iterating the output bus again. - */ - - /* Part 1: Wait for the current iteration to complete. */ - while (ma_node_input_bus_get_next_counter(pInputBus) > 0) { - ma_yield(); - } - - /* Part 2: Wait for any reads to complete. */ - while (c89atomic_load_32(&pOutputBus->refCount) > 0) { - ma_yield(); - } - - /* - At this point we're done detaching and we can be guaranteed that the audio thread is not going - to attempt to reference this output bus again (until attached again). - */ -} - -#if 0 /* Not used at the moment, but leaving here in case I need it later. */ -static void ma_node_input_bus_detach(ma_node_input_bus* pInputBus, ma_node_output_bus* pOutputBus) -{ - MA_ASSERT(pInputBus != NULL); - MA_ASSERT(pOutputBus != NULL); - - ma_node_output_bus_lock(pOutputBus); - { - ma_node_input_bus_detach__no_output_bus_lock(pInputBus, pOutputBus); - } - ma_node_output_bus_unlock(pOutputBus); -} -#endif - -static void ma_node_input_bus_attach(ma_node_input_bus* pInputBus, ma_node_output_bus* pOutputBus, ma_node* pNewInputNode, ma_uint32 inputNodeInputBusIndex) -{ - MA_ASSERT(pInputBus != NULL); - MA_ASSERT(pOutputBus != NULL); - - ma_node_output_bus_lock(pOutputBus); - { - ma_node_output_bus* pOldInputNode = (ma_node_output_bus*)c89atomic_load_ptr(&pOutputBus->pInputNode); - - /* Detach from any existing attachment first if necessary. */ - if (pOldInputNode != NULL) { - ma_node_input_bus_detach__no_output_bus_lock(pInputBus, pOutputBus); - } - - /* - At this point we can be sure the output bus is not attached to anything. The linked list in the - old input bus has been updated so that pOutputBus will not get iterated again. - */ - pOutputBus->pInputNode = pNewInputNode; /* No need for an atomic assignment here because modification of this variable always happens within a lock. */ - pOutputBus->inputNodeInputBusIndex = (ma_uint8)inputNodeInputBusIndex; - - /* - Now we need to attach the output bus to the linked list. This involves updating two pointers on - two different output buses so I'm going to go ahead and keep this simple and just use a lock. - There are ways to do this without a lock, but it's just too hard to maintain for it's value. - - Although we're locking here, it's important to remember that we're *not* locking when iterating - and reading audio data since that'll be running on the audio thread. As a result we need to be - careful how we craft this so that we don't break iteration. What we're going to do is always - attach the new item so that it becomes the first item in the list. That way, as we're iterating - we won't break any links in the list and iteration will continue safely. The detaching case will - also be crafted in a way as to not break list iteration. It's important to remember to use - atomic exchanges here since no locking is happening on the audio thread during iteration. - */ - ma_node_input_bus_lock(pInputBus); - { - ma_node_output_bus* pNewPrev = &pInputBus->head; - ma_node_output_bus* pNewNext = (ma_node_output_bus*)c89atomic_load_ptr(&pInputBus->head.pNext); - - /* Update the local output bus. */ - c89atomic_exchange_ptr(&pOutputBus->pPrev, pNewPrev); - c89atomic_exchange_ptr(&pOutputBus->pNext, pNewNext); - - /* Update the other output buses to point back to the local output bus. */ - c89atomic_exchange_ptr(&pInputBus->head.pNext, pOutputBus); /* <-- This is where the output bus is actually attached to the input bus. */ - - /* Do the previous pointer last. This is only used for detachment. */ - if (pNewNext != NULL) { - c89atomic_exchange_ptr(&pNewNext->pPrev, pOutputBus); - } - } - ma_node_input_bus_unlock(pInputBus); - - /* - Mark the node as attached last. This is used to controlling whether or the output bus will be - iterated on the audio thread. Mainly required for detachment purposes. - */ - ma_node_output_bus_set_is_attached(pOutputBus, MA_TRUE); - } - ma_node_output_bus_unlock(pOutputBus); -} - -static ma_node_output_bus* ma_node_input_bus_next(ma_node_input_bus* pInputBus, ma_node_output_bus* pOutputBus) -{ - ma_node_output_bus* pNext; - - MA_ASSERT(pInputBus != NULL); - - if (pOutputBus == NULL) { - return NULL; - } - - ma_node_input_bus_next_begin(pInputBus); - { - pNext = pOutputBus; - for (;;) { - pNext = (ma_node_output_bus*)c89atomic_load_ptr(&pNext->pNext); - if (pNext == NULL) { - break; /* Reached the end. */ - } - - if (ma_node_output_bus_is_attached(pNext) == MA_FALSE) { - continue; /* The node is not attached. Keep checking. */ - } - - /* The next node has been selected. */ - break; - } - - /* We need to increment the reference count of the selected node. */ - if (pNext != NULL) { - c89atomic_fetch_add_32(&pNext->refCount, 1); - } - - /* The previous node is no longer being referenced. */ - c89atomic_fetch_sub_32(&pOutputBus->refCount, 1); - } - ma_node_input_bus_next_end(pInputBus); - - return pNext; -} - -static ma_node_output_bus* ma_node_input_bus_first(ma_node_input_bus* pInputBus) -{ - return ma_node_input_bus_next(pInputBus, &pInputBus->head); -} - - - -static ma_result ma_node_input_bus_read_pcm_frames(ma_node* pInputNode, ma_node_input_bus* pInputBus, float* pFramesOut, ma_uint32 frameCount, ma_uint32* pFramesRead, ma_uint64 globalTime) -{ - ma_result result = MA_SUCCESS; - ma_node_output_bus* pOutputBus; - ma_node_output_bus* pFirst; - ma_uint32 inputChannels; - ma_bool32 doesOutputBufferHaveContent = MA_FALSE; - - (void)pInputNode; /* Not currently used. */ - - /* - This will be called from the audio thread which means we can't be doing any locking. Basically, - this function will not perfom any locking, whereas attaching and detaching will, but crafted in - such a way that we don't need to perform any locking here. The important thing to remember is - to always iterate in a forward direction. - - In order to process any data we need to first read from all input buses. That's where this - function comes in. This iterates over each of the attachments and accumulates/mixes them. We - also convert the channels to the nodes output channel count before mixing. We want to do this - channel conversion so that the caller of this function can invoke the processing callback - without having to do it themselves. - - When we iterate over each of the attachments on the input bus, we need to read as much data as - we can from each of them so that we don't end up with holes between each of the attachments. To - do this, we need to read from each attachment in a loop and read as many frames as we can, up - to `frameCount`. - */ - MA_ASSERT(pInputNode != NULL); - MA_ASSERT(pFramesRead != NULL); /* pFramesRead is critical and must always be specified. On input it's undefined and on output it'll be set to the number of frames actually read. */ - - *pFramesRead = 0; /* Safety. */ - - inputChannels = ma_node_input_bus_get_channels(pInputBus); - - /* - We need to be careful with how we call ma_node_input_bus_first() and ma_node_input_bus_next(). They - are both critical to our lock-free thread-safety system. We can only call ma_node_input_bus_first() - once per iteration, however we have an optimization to checks whether or not it's the first item in - the list. We therefore need to store a pointer to the first item rather than repeatedly calling - ma_node_input_bus_first(). It's safe to keep hold of this pointer, so long as we don't dereference it - after calling ma_node_input_bus_next(), which we won't be. - */ - pFirst = ma_node_input_bus_first(pInputBus); - if (pFirst == NULL) { - return MA_SUCCESS; /* No attachments. Read nothing. */ - } - - for (pOutputBus = pFirst; pOutputBus != NULL; pOutputBus = ma_node_input_bus_next(pInputBus, pOutputBus)) { - ma_uint32 framesProcessed = 0; - ma_bool32 isSilentOutput = MA_FALSE; - - MA_ASSERT(pOutputBus->pNode != NULL); - MA_ASSERT(((ma_node_base*)pOutputBus->pNode)->vtable != NULL); - - isSilentOutput = (((ma_node_base*)pOutputBus->pNode)->vtable->flags & MA_NODE_FLAG_SILENT_OUTPUT) != 0; - - if (pFramesOut != NULL) { - /* Read. */ - float temp[MA_DATA_CONVERTER_STACK_BUFFER_SIZE / sizeof(float)]; - ma_uint32 tempCapInFrames = ma_countof(temp) / inputChannels; - - while (framesProcessed < frameCount) { - float* pRunningFramesOut; - ma_uint32 framesToRead; - ma_uint32 framesJustRead; - - framesToRead = frameCount - framesProcessed; - if (framesToRead > tempCapInFrames) { - framesToRead = tempCapInFrames; - } - - pRunningFramesOut = ma_offset_pcm_frames_ptr_f32(pFramesOut, framesProcessed, inputChannels); - - if (doesOutputBufferHaveContent == MA_FALSE) { - /* Fast path. First attachment. We just read straight into the output buffer (no mixing required). */ - result = ma_node_read_pcm_frames(pOutputBus->pNode, pOutputBus->outputBusIndex, pRunningFramesOut, framesToRead, &framesJustRead, globalTime + framesProcessed); - } else { - /* Slow path. Not the first attachment. Mixing required. */ - result = ma_node_read_pcm_frames(pOutputBus->pNode, pOutputBus->outputBusIndex, temp, framesToRead, &framesJustRead, globalTime + framesProcessed); - if (result == MA_SUCCESS || result == MA_AT_END) { - if (isSilentOutput == MA_FALSE) { /* Don't mix if the node outputs silence. */ - ma_mix_pcm_frames_f32(pRunningFramesOut, temp, framesJustRead, inputChannels, /*volume*/1); - } - } - } - - framesProcessed += framesJustRead; - - /* If we reached the end or otherwise failed to read any data we need to finish up with this output node. */ - if (result != MA_SUCCESS) { - break; - } - - /* If we didn't read anything, abort so we don't get stuck in a loop. */ - if (framesJustRead == 0) { - break; - } - } - - /* If it's the first attachment we didn't do any mixing. Any leftover samples need to be silenced. */ - if (pOutputBus == pFirst && framesProcessed < frameCount) { - ma_silence_pcm_frames(ma_offset_pcm_frames_ptr(pFramesOut, framesProcessed, ma_format_f32, inputChannels), (frameCount - framesProcessed), ma_format_f32, inputChannels); - } - - if (isSilentOutput == MA_FALSE) { - doesOutputBufferHaveContent = MA_TRUE; - } - } else { - /* Seek. */ - ma_node_read_pcm_frames(pOutputBus->pNode, pOutputBus->outputBusIndex, NULL, frameCount, &framesProcessed, globalTime); - } - } - - /* If we didn't output anything, output silence. */ - if (doesOutputBufferHaveContent == MA_FALSE && pFramesOut != NULL) { - ma_silence_pcm_frames(pFramesOut, frameCount, ma_format_f32, inputChannels); - } - - /* In this path we always "process" the entire amount. */ - *pFramesRead = frameCount; - - return result; -} - - -MA_API ma_node_config ma_node_config_init(void) -{ - ma_node_config config; - - MA_ZERO_OBJECT(&config); - config.initialState = ma_node_state_started; /* Nodes are started by default. */ - config.inputBusCount = MA_NODE_BUS_COUNT_UNKNOWN; - config.outputBusCount = MA_NODE_BUS_COUNT_UNKNOWN; - - return config; -} - - - -static ma_result ma_node_detach_full(ma_node* pNode); - -static float* ma_node_get_cached_input_ptr(ma_node* pNode, ma_uint32 inputBusIndex) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_uint32 iInputBus; - float* pBasePtr; - - MA_ASSERT(pNodeBase != NULL); - - /* Input data is stored at the front of the buffer. */ - pBasePtr = pNodeBase->pCachedData; - for (iInputBus = 0; iInputBus < inputBusIndex; iInputBus += 1) { - pBasePtr += pNodeBase->cachedDataCapInFramesPerBus * ma_node_input_bus_get_channels(&pNodeBase->pInputBuses[iInputBus]); - } - - return pBasePtr; -} - -static float* ma_node_get_cached_output_ptr(ma_node* pNode, ma_uint32 outputBusIndex) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_uint32 iInputBus; - ma_uint32 iOutputBus; - float* pBasePtr; - - MA_ASSERT(pNodeBase != NULL); - - /* Cached output data starts after the input data. */ - pBasePtr = pNodeBase->pCachedData; - for (iInputBus = 0; iInputBus < ma_node_get_input_bus_count(pNodeBase); iInputBus += 1) { - pBasePtr += pNodeBase->cachedDataCapInFramesPerBus * ma_node_input_bus_get_channels(&pNodeBase->pInputBuses[iInputBus]); - } - - for (iOutputBus = 0; iOutputBus < outputBusIndex; iOutputBus += 1) { - pBasePtr += pNodeBase->cachedDataCapInFramesPerBus * ma_node_output_bus_get_channels(&pNodeBase->pOutputBuses[iOutputBus]); - } - - return pBasePtr; -} - - -typedef struct -{ - size_t sizeInBytes; - size_t inputBusOffset; - size_t outputBusOffset; - size_t cachedDataOffset; - ma_uint32 inputBusCount; /* So it doesn't have to be calculated twice. */ - ma_uint32 outputBusCount; /* So it doesn't have to be calculated twice. */ -} ma_node_heap_layout; - -static ma_result ma_node_translate_bus_counts(const ma_node_config* pConfig, ma_uint32* pInputBusCount, ma_uint32* pOutputBusCount) -{ - ma_uint32 inputBusCount; - ma_uint32 outputBusCount; - - MA_ASSERT(pConfig != NULL); - MA_ASSERT(pInputBusCount != NULL); - MA_ASSERT(pOutputBusCount != NULL); - - /* Bus counts are determined by the vtable, unless they're set to `MA_NODE_BUS_COUNT_UNKNWON`, in which case they're taken from the config. */ - if (pConfig->vtable->inputBusCount == MA_NODE_BUS_COUNT_UNKNOWN) { - inputBusCount = pConfig->inputBusCount; - } else { - inputBusCount = pConfig->vtable->inputBusCount; - - if (pConfig->inputBusCount != MA_NODE_BUS_COUNT_UNKNOWN && pConfig->inputBusCount != pConfig->vtable->inputBusCount) { - return MA_INVALID_ARGS; /* Invalid configuration. You must not specify a conflicting bus count between the node's config and the vtable. */ - } - } - - if (pConfig->vtable->outputBusCount == MA_NODE_BUS_COUNT_UNKNOWN) { - outputBusCount = pConfig->outputBusCount; - } else { - outputBusCount = pConfig->vtable->outputBusCount; - - if (pConfig->outputBusCount != MA_NODE_BUS_COUNT_UNKNOWN && pConfig->outputBusCount != pConfig->vtable->outputBusCount) { - return MA_INVALID_ARGS; /* Invalid configuration. You must not specify a conflicting bus count between the node's config and the vtable. */ - } - } - - /* Bus counts must be within limits. */ - if (inputBusCount > MA_MAX_NODE_BUS_COUNT || outputBusCount > MA_MAX_NODE_BUS_COUNT) { - return MA_INVALID_ARGS; - } - - - /* We must have channel counts for each bus. */ - if ((inputBusCount > 0 && pConfig->pInputChannels == NULL) || (outputBusCount > 0 && pConfig->pOutputChannels == NULL)) { - return MA_INVALID_ARGS; /* You must specify channel counts for each input and output bus. */ - } - - - /* Some special rules for passthrough nodes. */ - if ((pConfig->vtable->flags & MA_NODE_FLAG_PASSTHROUGH) != 0) { - if ((pConfig->vtable->inputBusCount != 0 && pConfig->vtable->inputBusCount != 1) || pConfig->vtable->outputBusCount != 1) { - return MA_INVALID_ARGS; /* Passthrough nodes must have exactly 1 output bus and either 0 or 1 input bus. */ - } - - if (pConfig->pInputChannels[0] != pConfig->pOutputChannels[0]) { - return MA_INVALID_ARGS; /* Passthrough nodes must have the same number of channels between input and output nodes. */ - } - } - - - *pInputBusCount = inputBusCount; - *pOutputBusCount = outputBusCount; - - return MA_SUCCESS; -} - -static ma_result ma_node_get_heap_layout(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, ma_node_heap_layout* pHeapLayout) -{ - ma_result result; - ma_uint32 inputBusCount; - ma_uint32 outputBusCount; - - MA_ASSERT(pHeapLayout != NULL); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL || pConfig->vtable == NULL || pConfig->vtable->onProcess == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_node_translate_bus_counts(pConfig, &inputBusCount, &outputBusCount); - if (result != MA_SUCCESS) { - return result; - } - - pHeapLayout->sizeInBytes = 0; - - /* Input buses. */ - if (inputBusCount > MA_MAX_NODE_LOCAL_BUS_COUNT) { - pHeapLayout->inputBusOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(sizeof(ma_node_input_bus) * inputBusCount); - } else { - pHeapLayout->inputBusOffset = MA_SIZE_MAX; /* MA_SIZE_MAX indicates that no heap allocation is required for the input bus. */ - } - - /* Output buses. */ - if (outputBusCount > MA_MAX_NODE_LOCAL_BUS_COUNT) { - pHeapLayout->outputBusOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(sizeof(ma_node_output_bus) * outputBusCount); - } else { - pHeapLayout->outputBusOffset = MA_SIZE_MAX; - } - - /* - Cached audio data. - - We need to allocate memory for a caching both input and output data. We have an optimization - where no caching is necessary for specific conditions: - - - The node has 0 inputs and 1 output. - - When a node meets the above conditions, no cache is allocated. - - The size choice for this buffer is a little bit finicky. We don't want to be too wasteful by - allocating too much, but at the same time we want it be large enough so that enough frames can - be processed for each call to ma_node_read_pcm_frames() so that it keeps things efficient. For - now I'm going with 10ms @ 48K which is 480 frames per bus. This is configurable at compile - time. It might also be worth investigating whether or not this can be configured at run time. - */ - if (inputBusCount == 0 && outputBusCount == 1) { - /* Fast path. No cache needed. */ - pHeapLayout->cachedDataOffset = MA_SIZE_MAX; - } else { - /* Slow path. Cache needed. */ - size_t cachedDataSizeInBytes = 0; - ma_uint32 iBus; - - for (iBus = 0; iBus < inputBusCount; iBus += 1) { - cachedDataSizeInBytes += pNodeGraph->nodeCacheCapInFrames * ma_get_bytes_per_frame(ma_format_f32, pConfig->pInputChannels[iBus]); - } - - for (iBus = 0; iBus < outputBusCount; iBus += 1) { - cachedDataSizeInBytes += pNodeGraph->nodeCacheCapInFrames * ma_get_bytes_per_frame(ma_format_f32, pConfig->pOutputChannels[iBus]); - } - - pHeapLayout->cachedDataOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(cachedDataSizeInBytes); - } - - - /* - Not technically part of the heap, but we can output the input and output bus counts so we can - avoid a redundant call to ma_node_translate_bus_counts(). - */ - pHeapLayout->inputBusCount = inputBusCount; - pHeapLayout->outputBusCount = outputBusCount; - - /* Make sure allocation size is aligned. */ - pHeapLayout->sizeInBytes = ma_align_64(pHeapLayout->sizeInBytes); - - return MA_SUCCESS; -} - -MA_API ma_result ma_node_get_heap_size(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_node_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_node_get_heap_layout(pNodeGraph, pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_node_init_preallocated(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, void* pHeap, ma_node* pNode) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_result result; - ma_node_heap_layout heapLayout; - ma_uint32 iInputBus; - ma_uint32 iOutputBus; - - if (pNodeBase == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNodeBase); - - result = ma_node_get_heap_layout(pNodeGraph, pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - pNodeBase->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pNodeBase->pNodeGraph = pNodeGraph; - pNodeBase->vtable = pConfig->vtable; - pNodeBase->state = pConfig->initialState; - pNodeBase->stateTimes[ma_node_state_started] = 0; - pNodeBase->stateTimes[ma_node_state_stopped] = (ma_uint64)(ma_int64)-1; /* Weird casting for VC6 compatibility. */ - pNodeBase->inputBusCount = heapLayout.inputBusCount; - pNodeBase->outputBusCount = heapLayout.outputBusCount; - - if (heapLayout.inputBusOffset != MA_SIZE_MAX) { - pNodeBase->pInputBuses = (ma_node_input_bus*)ma_offset_ptr(pHeap, heapLayout.inputBusOffset); - } else { - pNodeBase->pInputBuses = pNodeBase->_inputBuses; - } - - if (heapLayout.outputBusOffset != MA_SIZE_MAX) { - pNodeBase->pOutputBuses = (ma_node_output_bus*)ma_offset_ptr(pHeap, heapLayout.inputBusOffset); - } else { - pNodeBase->pOutputBuses = pNodeBase->_outputBuses; - } - - if (heapLayout.cachedDataOffset != MA_SIZE_MAX) { - pNodeBase->pCachedData = (float*)ma_offset_ptr(pHeap, heapLayout.cachedDataOffset); - pNodeBase->cachedDataCapInFramesPerBus = pNodeGraph->nodeCacheCapInFrames; - } else { - pNodeBase->pCachedData = NULL; - } - - - - /* We need to run an initialization step for each input and output bus. */ - for (iInputBus = 0; iInputBus < ma_node_get_input_bus_count(pNodeBase); iInputBus += 1) { - result = ma_node_input_bus_init(pConfig->pInputChannels[iInputBus], &pNodeBase->pInputBuses[iInputBus]); - if (result != MA_SUCCESS) { - return result; - } - } - - for (iOutputBus = 0; iOutputBus < ma_node_get_output_bus_count(pNodeBase); iOutputBus += 1) { - result = ma_node_output_bus_init(pNodeBase, iOutputBus, pConfig->pOutputChannels[iOutputBus], &pNodeBase->pOutputBuses[iOutputBus]); - if (result != MA_SUCCESS) { - return result; - } - } - - - /* The cached data needs to be initialized to silence (or a sine wave tone if we're debugging). */ - if (pNodeBase->pCachedData != NULL) { - ma_uint32 iBus; - - #if 1 /* Toggle this between 0 and 1 to turn debugging on or off. 1 = fill with a sine wave for debugging; 0 = fill with silence. */ - /* For safety we'll go ahead and default the buffer to silence. */ - for (iBus = 0; iBus < ma_node_get_input_bus_count(pNodeBase); iBus += 1) { - ma_silence_pcm_frames(ma_node_get_cached_input_ptr(pNode, iBus), pNodeBase->cachedDataCapInFramesPerBus, ma_format_f32, ma_node_input_bus_get_channels(&pNodeBase->pInputBuses[iBus])); - } - for (iBus = 0; iBus < ma_node_get_output_bus_count(pNodeBase); iBus += 1) { - ma_silence_pcm_frames(ma_node_get_cached_output_ptr(pNode, iBus), pNodeBase->cachedDataCapInFramesPerBus, ma_format_f32, ma_node_output_bus_get_channels(&pNodeBase->pOutputBuses[iBus])); - } - #else - /* For debugging. Default to a sine wave. */ - for (iBus = 0; iBus < ma_node_get_input_bus_count(pNodeBase); iBus += 1) { - ma_debug_fill_pcm_frames_with_sine_wave(ma_node_get_cached_input_ptr(pNode, iBus), pNodeBase->cachedDataCapInFramesPerBus, ma_format_f32, ma_node_input_bus_get_channels(&pNodeBase->pInputBuses[iBus]), 48000); - } - for (iBus = 0; iBus < ma_node_get_output_bus_count(pNodeBase); iBus += 1) { - ma_debug_fill_pcm_frames_with_sine_wave(ma_node_get_cached_output_ptr(pNode, iBus), pNodeBase->cachedDataCapInFramesPerBus, ma_format_f32, ma_node_output_bus_get_channels(&pNodeBase->pOutputBuses[iBus]), 48000); - } - #endif - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_node_init(ma_node_graph* pNodeGraph, const ma_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_node* pNode) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_node_get_heap_size(pNodeGraph, pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_node_init_preallocated(pNodeGraph, pConfig, pHeap, pNode); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - ((ma_node_base*)pNode)->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_node_uninit(ma_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - - if (pNodeBase == NULL) { - return; - } - - /* - The first thing we need to do is fully detach the node. This will detach all inputs and - outputs. We need to do this first because it will sever the connection with the node graph and - allow us to complete uninitialization without needing to worry about thread-safety with the - audio thread. The detachment process will wait for any local processing of the node to finish. - */ - ma_node_detach_full(pNode); - - /* - At this point the node should be completely unreferenced by the node graph and we can finish up - the uninitialization process without needing to worry about thread-safety. - */ - if (pNodeBase->_ownsHeap) { - ma_free(pNodeBase->_pHeap, pAllocationCallbacks); - } -} - -MA_API ma_node_graph* ma_node_get_node_graph(const ma_node* pNode) -{ - if (pNode == NULL) { - return NULL; - } - - return ((const ma_node_base*)pNode)->pNodeGraph; -} - -MA_API ma_uint32 ma_node_get_input_bus_count(const ma_node* pNode) -{ - if (pNode == NULL) { - return 0; - } - - return ((ma_node_base*)pNode)->inputBusCount; -} - -MA_API ma_uint32 ma_node_get_output_bus_count(const ma_node* pNode) -{ - if (pNode == NULL) { - return 0; - } - - return ((ma_node_base*)pNode)->outputBusCount; -} - - -MA_API ma_uint32 ma_node_get_input_channels(const ma_node* pNode, ma_uint32 inputBusIndex) -{ - const ma_node_base* pNodeBase = (const ma_node_base*)pNode; - - if (pNode == NULL) { - return 0; - } - - if (inputBusIndex >= ma_node_get_input_bus_count(pNode)) { - return 0; /* Invalid bus index. */ - } - - return ma_node_input_bus_get_channels(&pNodeBase->pInputBuses[inputBusIndex]); -} - -MA_API ma_uint32 ma_node_get_output_channels(const ma_node* pNode, ma_uint32 outputBusIndex) -{ - const ma_node_base* pNodeBase = (const ma_node_base*)pNode; - - if (pNode == NULL) { - return 0; - } - - if (outputBusIndex >= ma_node_get_output_bus_count(pNode)) { - return 0; /* Invalid bus index. */ - } - - return ma_node_output_bus_get_channels(&pNodeBase->pOutputBuses[outputBusIndex]); -} - - -static ma_result ma_node_detach_full(ma_node* pNode) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_uint32 iInputBus; - - if (pNodeBase == NULL) { - return MA_INVALID_ARGS; - } - - /* - Make sure the node is completely detached first. This will not return until the output bus is - guaranteed to no longer be referenced by the audio thread. - */ - ma_node_detach_all_output_buses(pNode); - - /* - At this point all output buses will have been detached from the graph and we can be guaranteed - that none of it's input nodes will be getting processed by the graph. We can detach these - without needing to worry about the audio thread touching them. - */ - for (iInputBus = 0; iInputBus < ma_node_get_input_bus_count(pNode); iInputBus += 1) { - ma_node_input_bus* pInputBus; - ma_node_output_bus* pOutputBus; - - pInputBus = &pNodeBase->pInputBuses[iInputBus]; - - /* - This is important. We cannot be using ma_node_input_bus_first() or ma_node_input_bus_next(). Those - functions are specifically for the audio thread. We'll instead just manually iterate using standard - linked list logic. We don't need to worry about the audio thread referencing these because the step - above severed the connection to the graph. - */ - for (pOutputBus = (ma_node_output_bus*)c89atomic_load_ptr(&pInputBus->head.pNext); pOutputBus != NULL; pOutputBus = (ma_node_output_bus*)c89atomic_load_ptr(&pOutputBus->pNext)) { - ma_node_detach_output_bus(pOutputBus->pNode, pOutputBus->outputBusIndex); /* This won't do any waiting in practice and should be efficient. */ - } - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_node_detach_output_bus(ma_node* pNode, ma_uint32 outputBusIndex) -{ - ma_result result = MA_SUCCESS; - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_node_base* pInputNodeBase; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - if (outputBusIndex >= ma_node_get_output_bus_count(pNode)) { - return MA_INVALID_ARGS; /* Invalid output bus index. */ - } - - /* We need to lock the output bus because we need to inspect the input node and grab it's input bus. */ - ma_node_output_bus_lock(&pNodeBase->pOutputBuses[outputBusIndex]); - { - pInputNodeBase = (ma_node_base*)pNodeBase->pOutputBuses[outputBusIndex].pInputNode; - if (pInputNodeBase != NULL) { - ma_node_input_bus_detach__no_output_bus_lock(&pInputNodeBase->pInputBuses[pNodeBase->pOutputBuses[outputBusIndex].inputNodeInputBusIndex], &pNodeBase->pOutputBuses[outputBusIndex]); - } - } - ma_node_output_bus_unlock(&pNodeBase->pOutputBuses[outputBusIndex]); - - return result; -} - -MA_API ma_result ma_node_detach_all_output_buses(ma_node* pNode) -{ - ma_uint32 iOutputBus; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - for (iOutputBus = 0; iOutputBus < ma_node_get_output_bus_count(pNode); iOutputBus += 1) { - ma_node_detach_output_bus(pNode, iOutputBus); - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_node_attach_output_bus(ma_node* pNode, ma_uint32 outputBusIndex, ma_node* pOtherNode, ma_uint32 otherNodeInputBusIndex) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_node_base* pOtherNodeBase = (ma_node_base*)pOtherNode; - - if (pNodeBase == NULL || pOtherNodeBase == NULL) { - return MA_INVALID_ARGS; - } - - if (pNodeBase == pOtherNodeBase) { - return MA_INVALID_OPERATION; /* Cannot attach a node to itself. */ - } - - if (outputBusIndex >= ma_node_get_output_bus_count(pNode) || otherNodeInputBusIndex >= ma_node_get_input_bus_count(pOtherNode)) { - return MA_INVALID_OPERATION; /* Invalid bus index. */ - } - - /* The output channel count of the output node must be the same as the input channel count of the input node. */ - if (ma_node_get_output_channels(pNode, outputBusIndex) != ma_node_get_input_channels(pOtherNode, otherNodeInputBusIndex)) { - return MA_INVALID_OPERATION; /* Channel count is incompatible. */ - } - - /* This will deal with detaching if the output bus is already attached to something. */ - ma_node_input_bus_attach(&pOtherNodeBase->pInputBuses[otherNodeInputBusIndex], &pNodeBase->pOutputBuses[outputBusIndex], pOtherNode, otherNodeInputBusIndex); - - return MA_SUCCESS; -} - -MA_API ma_result ma_node_set_output_bus_volume(ma_node* pNode, ma_uint32 outputBusIndex, float volume) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - - if (pNodeBase == NULL) { - return MA_INVALID_ARGS; - } - - if (outputBusIndex >= ma_node_get_output_bus_count(pNode)) { - return MA_INVALID_ARGS; /* Invalid bus index. */ - } - - return ma_node_output_bus_set_volume(&pNodeBase->pOutputBuses[outputBusIndex], volume); -} - -MA_API float ma_node_get_output_bus_volume(const ma_node* pNode, ma_uint32 outputBusIndex) -{ - const ma_node_base* pNodeBase = (const ma_node_base*)pNode; - - if (pNodeBase == NULL) { - return 0; - } - - if (outputBusIndex >= ma_node_get_output_bus_count(pNode)) { - return 0; /* Invalid bus index. */ - } - - return ma_node_output_bus_get_volume(&pNodeBase->pOutputBuses[outputBusIndex]); -} - -MA_API ma_result ma_node_set_state(ma_node* pNode, ma_node_state state) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - - if (pNodeBase == NULL) { - return MA_INVALID_ARGS; - } - - c89atomic_exchange_i32(&pNodeBase->state, state); - - return MA_SUCCESS; -} - -MA_API ma_node_state ma_node_get_state(const ma_node* pNode) -{ - const ma_node_base* pNodeBase = (const ma_node_base*)pNode; - - if (pNodeBase == NULL) { - return ma_node_state_stopped; - } - - return (ma_node_state)c89atomic_load_i32(&pNodeBase->state); -} - -MA_API ma_result ma_node_set_state_time(ma_node* pNode, ma_node_state state, ma_uint64 globalTime) -{ - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - /* Validation check for safety since we'll be using this as an index into stateTimes[]. */ - if (state != ma_node_state_started && state != ma_node_state_stopped) { - return MA_INVALID_ARGS; - } - - c89atomic_exchange_64(&((ma_node_base*)pNode)->stateTimes[state], globalTime); - - return MA_SUCCESS; -} - -MA_API ma_uint64 ma_node_get_state_time(const ma_node* pNode, ma_node_state state) -{ - if (pNode == NULL) { - return 0; - } - - /* Validation check for safety since we'll be using this as an index into stateTimes[]. */ - if (state != ma_node_state_started && state != ma_node_state_stopped) { - return 0; - } - - return c89atomic_load_64(&((ma_node_base*)pNode)->stateTimes[state]); -} - -MA_API ma_node_state ma_node_get_state_by_time(const ma_node* pNode, ma_uint64 globalTime) -{ - if (pNode == NULL) { - return ma_node_state_stopped; - } - - return ma_node_get_state_by_time_range(pNode, globalTime, globalTime); -} - -MA_API ma_node_state ma_node_get_state_by_time_range(const ma_node* pNode, ma_uint64 globalTimeBeg, ma_uint64 globalTimeEnd) -{ - ma_node_state state; - - if (pNode == NULL) { - return ma_node_state_stopped; - } - - state = ma_node_get_state(pNode); - - /* An explicitly stopped node is always stopped. */ - if (state == ma_node_state_stopped) { - return ma_node_state_stopped; - } - - /* - Getting here means the node is marked as started, but it may still not be truly started due to - it's start time not having been reached yet. Also, the stop time may have also been reached in - which case it'll be considered stopped. - */ - if (ma_node_get_state_time(pNode, ma_node_state_started) > globalTimeBeg) { - return ma_node_state_stopped; /* Start time has not yet been reached. */ - } - - if (ma_node_get_state_time(pNode, ma_node_state_stopped) <= globalTimeEnd) { - return ma_node_state_stopped; /* Stop time has been reached. */ - } - - /* Getting here means the node is marked as started and is within it's start/stop times. */ - return ma_node_state_started; -} - -MA_API ma_uint64 ma_node_get_time(const ma_node* pNode) -{ - if (pNode == NULL) { - return 0; - } - - return c89atomic_load_64(&((ma_node_base*)pNode)->localTime); -} - -MA_API ma_result ma_node_set_time(ma_node* pNode, ma_uint64 localTime) -{ - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - c89atomic_exchange_64(&((ma_node_base*)pNode)->localTime, localTime); - - return MA_SUCCESS; -} - - - -static void ma_node_process_pcm_frames_internal(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - - MA_ASSERT(pNode != NULL); - - if (pNodeBase->vtable->onProcess) { - pNodeBase->vtable->onProcess(pNode, ppFramesIn, pFrameCountIn, ppFramesOut, pFrameCountOut); - } -} - -static ma_result ma_node_read_pcm_frames(ma_node* pNode, ma_uint32 outputBusIndex, float* pFramesOut, ma_uint32 frameCount, ma_uint32* pFramesRead, ma_uint64 globalTime) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_result result = MA_SUCCESS; - ma_uint32 iInputBus; - ma_uint32 iOutputBus; - ma_uint32 inputBusCount; - ma_uint32 outputBusCount; - ma_uint32 totalFramesRead = 0; - float* ppFramesIn[MA_MAX_NODE_BUS_COUNT]; - float* ppFramesOut[MA_MAX_NODE_BUS_COUNT]; - ma_uint64 globalTimeBeg; - ma_uint64 globalTimeEnd; - ma_uint64 startTime; - ma_uint64 stopTime; - ma_uint32 timeOffsetBeg; - ma_uint32 timeOffsetEnd; - ma_uint32 frameCountIn; - ma_uint32 frameCountOut; - - /* - pFramesRead is mandatory. It must be used to determine how many frames were read. It's normal and - expected that the number of frames read may be different to that requested. Therefore, the caller - must look at this value to correctly determine how many frames were read. - */ - MA_ASSERT(pFramesRead != NULL); /* <-- If you've triggered this assert, you're using this function wrong. You *must* use this variable and inspect it after the call returns. */ - if (pFramesRead == NULL) { - return MA_INVALID_ARGS; - } - - *pFramesRead = 0; /* Safety. */ - - if (pNodeBase == NULL) { - return MA_INVALID_ARGS; - } - - if (outputBusIndex >= ma_node_get_output_bus_count(pNodeBase)) { - return MA_INVALID_ARGS; /* Invalid output bus index. */ - } - - /* Don't do anything if we're in a stopped state. */ - if (ma_node_get_state_by_time_range(pNode, globalTime, globalTime + frameCount) != ma_node_state_started) { - return MA_SUCCESS; /* We're in a stopped state. This is not an error - we just need to not read anything. */ - } - - - globalTimeBeg = globalTime; - globalTimeEnd = globalTime + frameCount; - startTime = ma_node_get_state_time(pNode, ma_node_state_started); - stopTime = ma_node_get_state_time(pNode, ma_node_state_stopped); - - /* - At this point we know that we are inside our start/stop times. However, we may need to adjust - our frame count and output pointer to accomodate since we could be straddling the time period - that this function is getting called for. - - It's possible (and likely) that the start time does not line up with the output buffer. We - therefore need to offset it by a number of frames to accomodate. The same thing applies for - the stop time. - */ - timeOffsetBeg = (globalTimeBeg < startTime) ? (ma_uint32)(globalTimeEnd - startTime) : 0; - timeOffsetEnd = (globalTimeEnd > stopTime) ? (ma_uint32)(globalTimeEnd - stopTime) : 0; - - /* Trim based on the start offset. We need to silence the start of the buffer. */ - if (timeOffsetBeg > 0) { - ma_silence_pcm_frames(pFramesOut, timeOffsetBeg, ma_format_f32, ma_node_get_output_channels(pNode, outputBusIndex)); - pFramesOut += timeOffsetBeg * ma_node_get_output_channels(pNode, outputBusIndex); - frameCount -= timeOffsetBeg; - } - - /* Trim based on the end offset. We don't need to silence the tail section because we'll just have a reduced value written to pFramesRead. */ - if (timeOffsetEnd > 0) { - frameCount -= timeOffsetEnd; - } - - - /* We run on different paths depending on the bus counts. */ - inputBusCount = ma_node_get_input_bus_count(pNode); - outputBusCount = ma_node_get_output_bus_count(pNode); - - /* - Run a simplified path when there are no inputs and one output. In this case there's nothing to - actually read and we can go straight to output. This is a very common scenario because the vast - majority of data source nodes will use this setup so this optimization I think is worthwhile. - */ - if (inputBusCount == 0 && outputBusCount == 1) { - /* Fast path. No need to read from input and no need for any caching. */ - frameCountIn = 0; - frameCountOut = frameCount; /* Just read as much as we can. The callback will return what was actually read. */ - - ppFramesOut[0] = pFramesOut; - - /* - If it's a passthrough we won't be expecting the callback to output anything, so we'll - need to pre-silence the output buffer. - */ - if ((pNodeBase->vtable->flags & MA_NODE_FLAG_PASSTHROUGH) != 0) { - ma_silence_pcm_frames(pFramesOut, frameCount, ma_format_f32, ma_node_get_output_channels(pNode, outputBusIndex)); - } - - ma_node_process_pcm_frames_internal(pNode, NULL, &frameCountIn, ppFramesOut, &frameCountOut); - totalFramesRead = frameCountOut; - } else { - /* Slow path. Need to read input data. */ - if ((pNodeBase->vtable->flags & MA_NODE_FLAG_PASSTHROUGH) != 0) { - /* - Fast path. We're running a passthrough. We need to read directly into the output buffer, but - still fire the callback so that event handling and trigger nodes can do their thing. Since - it's a passthrough there's no need for any kind of caching logic. - */ - MA_ASSERT(outputBusCount == inputBusCount); - MA_ASSERT(outputBusCount == 1); - MA_ASSERT(outputBusIndex == 0); - - /* We just read directly from input bus to output buffer, and then afterwards fire the callback. */ - ppFramesOut[0] = pFramesOut; - ppFramesIn[0] = ppFramesOut[0]; - - result = ma_node_input_bus_read_pcm_frames(pNodeBase, &pNodeBase->pInputBuses[0], ppFramesIn[0], frameCount, &totalFramesRead, globalTime); - if (result == MA_SUCCESS) { - /* Even though it's a passthrough, we still need to fire the callback. */ - frameCountIn = totalFramesRead; - frameCountOut = totalFramesRead; - - if (totalFramesRead > 0) { - ma_node_process_pcm_frames_internal(pNode, (const float**)ppFramesIn, &frameCountIn, ppFramesOut, &frameCountOut); /* From GCC: expected 'const float **' but argument is of type 'float **'. Shouldn't this be implicit? Excplicit cast to silence the warning. */ - } - - /* - A passthrough should never have modified the input and output frame counts. If you're - triggering these assers you need to fix your processing callback. - */ - MA_ASSERT(frameCountIn == totalFramesRead); - MA_ASSERT(frameCountOut == totalFramesRead); - } - } else { - /* Slow path. Need to do caching. */ - ma_uint32 framesToProcessIn; - ma_uint32 framesToProcessOut; - ma_bool32 consumeNullInput = MA_FALSE; - - /* - We use frameCount as a basis for the number of frames to read since that's what's being - requested, however we still need to clamp it to whatever can fit in the cache. - - This will also be used as the basis for determining how many input frames to read. This is - not ideal because it can result in too many input frames being read which introduces latency. - To solve this, nodes can implement an optional callback called onGetRequiredInputFrameCount - which is used as hint to miniaudio as to how many input frames it needs to read at a time. This - callback is completely optional, and if it's not set, miniaudio will assume `frameCount`. - - This function will be called multiple times for each period of time, once for each output node. - We cannot read from each input node each time this function is called. Instead we need to check - whether or not this is first output bus to be read from for this time period, and if so, read - from our input data. - - To determine whether or not we're ready to read data, we check a flag. There will be one flag - for each output. When the flag is set, it means data has been read previously and that we're - ready to advance time forward for our input nodes by reading fresh data. - */ - framesToProcessOut = frameCount; - if (framesToProcessOut > pNodeBase->cachedDataCapInFramesPerBus) { - framesToProcessOut = pNodeBase->cachedDataCapInFramesPerBus; - } - - framesToProcessIn = frameCount; - if (pNodeBase->vtable->onGetRequiredInputFrameCount) { - pNodeBase->vtable->onGetRequiredInputFrameCount(pNode, framesToProcessOut, &framesToProcessIn); /* <-- It does not matter if this fails. */ - } - if (framesToProcessIn > pNodeBase->cachedDataCapInFramesPerBus) { - framesToProcessIn = pNodeBase->cachedDataCapInFramesPerBus; - } - - - MA_ASSERT(framesToProcessIn <= 0xFFFF); - MA_ASSERT(framesToProcessOut <= 0xFFFF); - - if (ma_node_output_bus_has_read(&pNodeBase->pOutputBuses[outputBusIndex])) { - /* Getting here means we need to do another round of processing. */ - pNodeBase->cachedFrameCountOut = 0; - - for (;;) { - frameCountOut = 0; - - /* - We need to prepare our output frame pointers for processing. In the same iteration we need - to mark every output bus as unread so that future calls to this function for different buses - for the current time period don't pull in data when they should instead be reading from cache. - */ - for (iOutputBus = 0; iOutputBus < outputBusCount; iOutputBus += 1) { - ma_node_output_bus_set_has_read(&pNodeBase->pOutputBuses[iOutputBus], MA_FALSE); /* <-- This is what tells the next calls to this function for other output buses for this time period to read from cache instead of pulling in more data. */ - ppFramesOut[iOutputBus] = ma_node_get_cached_output_ptr(pNode, iOutputBus); - } - - /* We only need to read from input buses if there isn't already some data in the cache. */ - if (pNodeBase->cachedFrameCountIn == 0) { - ma_uint32 maxFramesReadIn = 0; - - /* Here is where we pull in data from the input buses. This is what will trigger an advance in time. */ - for (iInputBus = 0; iInputBus < inputBusCount; iInputBus += 1) { - ma_uint32 framesRead; - - /* The first thing to do is get the offset within our bulk allocation to store this input data. */ - ppFramesIn[iInputBus] = ma_node_get_cached_input_ptr(pNode, iInputBus); - - /* Once we've determined our destination pointer we can read. Note that we must inspect the number of frames read and fill any leftovers with silence for safety. */ - result = ma_node_input_bus_read_pcm_frames(pNodeBase, &pNodeBase->pInputBuses[iInputBus], ppFramesIn[iInputBus], framesToProcessIn, &framesRead, globalTime); - if (result != MA_SUCCESS) { - /* It doesn't really matter if we fail because we'll just fill with silence. */ - framesRead = 0; /* Just for safety, but I don't think it's really needed. */ - } - - /* TODO: Minor optimization opportunity here. If no frames were read and the buffer is already filled with silence, no need to re-silence it. */ - /* Any leftover frames need to silenced for safety. */ - if (framesRead < framesToProcessIn) { - ma_silence_pcm_frames(ppFramesIn[iInputBus] + (framesRead * ma_node_get_input_channels(pNodeBase, iInputBus)), (framesToProcessIn - framesRead), ma_format_f32, ma_node_get_input_channels(pNodeBase, iInputBus)); - } - - maxFramesReadIn = ma_max(maxFramesReadIn, framesRead); - } - - /* This was a fresh load of input data so reset our consumption counter. */ - pNodeBase->consumedFrameCountIn = 0; - - /* - We don't want to keep processing if there's nothing to process, so set the number of cached - input frames to the maximum number we read from each attachment (the lesser will be padded - with silence). If we didn't read anything, this will be set to 0 and the entire buffer will - have been assigned to silence. This being equal to 0 is an important property for us because - it allows us to detect when NULL can be passed into the processing callback for the input - buffer for the purpose of continuous processing. - */ - pNodeBase->cachedFrameCountIn = (ma_uint16)maxFramesReadIn; - } else { - /* We don't need to read anything, but we do need to prepare our input frame pointers. */ - for (iInputBus = 0; iInputBus < inputBusCount; iInputBus += 1) { - ppFramesIn[iInputBus] = ma_node_get_cached_input_ptr(pNode, iInputBus) + (pNodeBase->consumedFrameCountIn * ma_node_get_input_channels(pNodeBase, iInputBus)); - } - } - - /* - At this point we have our input data so now we need to do some processing. Sneaky little - optimization here - we can set the pointer to the output buffer for this output bus so - that the final copy into the output buffer is done directly by onProcess(). - */ - if (pFramesOut != NULL) { - ppFramesOut[outputBusIndex] = ma_offset_pcm_frames_ptr_f32(pFramesOut, pNodeBase->cachedFrameCountOut, ma_node_get_output_channels(pNode, outputBusIndex)); - } - - - /* Give the processing function the entire capacity of the output buffer. */ - frameCountOut = (framesToProcessOut - pNodeBase->cachedFrameCountOut); - - /* - We need to treat nodes with continuous processing a little differently. For these ones, - we always want to fire the callback with the requested number of frames, regardless of - pNodeBase->cachedFrameCountIn, which could be 0. Also, we want to check if we can pass - in NULL for the input buffer to the callback. - */ - if ((pNodeBase->vtable->flags & MA_NODE_FLAG_CONTINUOUS_PROCESSING) != 0) { - /* We're using continuous processing. Make sure we specify the whole frame count at all times. */ - frameCountIn = framesToProcessIn; /* Give the processing function as much input data as we've got in the buffer, including any silenced padding from short reads. */ - - if ((pNodeBase->vtable->flags & MA_NODE_FLAG_ALLOW_NULL_INPUT) != 0 && pNodeBase->consumedFrameCountIn == 0 && pNodeBase->cachedFrameCountIn == 0) { - consumeNullInput = MA_TRUE; - } else { - consumeNullInput = MA_FALSE; - } - - /* - Since we're using continuous processing we're always passing in a full frame count - regardless of how much input data was read. If this is greater than what we read as - input, we'll end up with an underflow. We instead need to make sure our cached frame - count is set to the number of frames we'll be passing to the data callback. Not - doing this will result in an underflow when we "consume" the cached data later on. - - Note that this check needs to be done after the "consumeNullInput" check above because - we use the property of cachedFrameCountIn being 0 to determine whether or not we - should be passing in a null pointer to the processing callback for when the node is - configured with MA_NODE_FLAG_ALLOW_NULL_INPUT. - */ - if (pNodeBase->cachedFrameCountIn < (ma_uint16)frameCountIn) { - pNodeBase->cachedFrameCountIn = (ma_uint16)frameCountIn; - } - } else { - frameCountIn = pNodeBase->cachedFrameCountIn; /* Give the processing function as much valid input data as we've got. */ - consumeNullInput = MA_FALSE; - } - - /* - Process data slightly differently depending on whether or not we're consuming NULL - input (checked just above). - */ - if (consumeNullInput) { - ma_node_process_pcm_frames_internal(pNode, NULL, &frameCountIn, ppFramesOut, &frameCountOut); - } else { - /* - We want to skip processing if there's no input data, but we can only do that safely if - we know that there is no chance of any output frames being produced. If continuous - processing is being used, this won't be a problem because the input frame count will - always be non-0. However, if continuous processing is *not* enabled and input and output - data is processed at different rates, we still need to process that last input frame - because there could be a few excess output frames needing to be produced from cached - data. The `MA_NODE_FLAG_DIFFERENT_PROCESSING_RATES` flag is used as the indicator for - determining whether or not we need to process the node even when there are no input - frames available right now. - */ - if (frameCountIn > 0 || (pNodeBase->vtable->flags & MA_NODE_FLAG_DIFFERENT_PROCESSING_RATES) != 0) { - ma_node_process_pcm_frames_internal(pNode, (const float**)ppFramesIn, &frameCountIn, ppFramesOut, &frameCountOut); /* From GCC: expected 'const float **' but argument is of type 'float **'. Shouldn't this be implicit? Excplicit cast to silence the warning. */ - } else { - frameCountOut = 0; /* No data was processed. */ - } - } - - /* - Thanks to our sneaky optimization above we don't need to do any data copying directly into - the output buffer - the onProcess() callback just did that for us. We do, however, need to - apply the number of input and output frames that were processed. Note that due to continuous - processing above, we need to do explicit checks here. If we just consumed a NULL input - buffer it means that no actual input data was processed from the internal buffers and we - don't want to be modifying any counters. - */ - if (consumeNullInput == MA_FALSE) { - pNodeBase->consumedFrameCountIn += (ma_uint16)frameCountIn; - pNodeBase->cachedFrameCountIn -= (ma_uint16)frameCountIn; - } - - /* The cached output frame count is always equal to what we just read. */ - pNodeBase->cachedFrameCountOut += (ma_uint16)frameCountOut; - - /* If we couldn't process any data, we're done. The loop needs to be terminated here or else we'll get stuck in a loop. */ - if (pNodeBase->cachedFrameCountOut == framesToProcessOut || (frameCountOut == 0 && frameCountIn == 0)) { - break; - } - } - } else { - /* - We're not needing to read anything from the input buffer so just read directly from our - already-processed data. - */ - if (pFramesOut != NULL) { - ma_copy_pcm_frames(pFramesOut, ma_node_get_cached_output_ptr(pNodeBase, outputBusIndex), pNodeBase->cachedFrameCountOut, ma_format_f32, ma_node_get_output_channels(pNodeBase, outputBusIndex)); - } - } - - /* The number of frames read is always equal to the number of cached output frames. */ - totalFramesRead = pNodeBase->cachedFrameCountOut; - - /* Now that we've read the data, make sure our read flag is set. */ - ma_node_output_bus_set_has_read(&pNodeBase->pOutputBuses[outputBusIndex], MA_TRUE); - } - } - - /* Apply volume, if necessary. */ - ma_apply_volume_factor_f32(pFramesOut, totalFramesRead * ma_node_get_output_channels(pNodeBase, outputBusIndex), ma_node_output_bus_get_volume(&pNodeBase->pOutputBuses[outputBusIndex])); - - /* Advance our local time forward. */ - c89atomic_fetch_add_64(&pNodeBase->localTime, (ma_uint64)totalFramesRead); - - *pFramesRead = totalFramesRead + timeOffsetBeg; /* Must include the silenced section at the start of the buffer. */ - return result; -} - - - - -/* Data source node. */ -MA_API ma_data_source_node_config ma_data_source_node_config_init(ma_data_source* pDataSource) -{ - ma_data_source_node_config config; - - MA_ZERO_OBJECT(&config); - config.nodeConfig = ma_node_config_init(); - config.pDataSource = pDataSource; - - return config; -} - - -static void ma_data_source_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_data_source_node* pDataSourceNode = (ma_data_source_node*)pNode; - ma_format format; - ma_uint32 channels; - ma_uint32 frameCount; - ma_uint64 framesRead = 0; - - MA_ASSERT(pDataSourceNode != NULL); - MA_ASSERT(pDataSourceNode->pDataSource != NULL); - MA_ASSERT(ma_node_get_input_bus_count(pDataSourceNode) == 0); - MA_ASSERT(ma_node_get_output_bus_count(pDataSourceNode) == 1); - - /* We don't want to read from ppFramesIn at all. Instead we read from the data source. */ - (void)ppFramesIn; - (void)pFrameCountIn; - - frameCount = *pFrameCountOut; - - /* miniaudio should never be calling this with a frame count of zero. */ - MA_ASSERT(frameCount > 0); - - if (ma_data_source_get_data_format(pDataSourceNode->pDataSource, &format, &channels, NULL, NULL, 0) == MA_SUCCESS) { /* <-- Don't care about sample rate here. */ - /* The node graph system requires samples be in floating point format. This is checked in ma_data_source_node_init(). */ - MA_ASSERT(format == ma_format_f32); - (void)format; /* Just to silence some static analysis tools. */ - - ma_data_source_read_pcm_frames(pDataSourceNode->pDataSource, ppFramesOut[0], frameCount, &framesRead); - } - - *pFrameCountOut = (ma_uint32)framesRead; -} - -static ma_node_vtable g_ma_data_source_node_vtable = -{ - ma_data_source_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 0, /* 0 input buses. */ - 1, /* 1 output bus. */ - 0 -}; - -MA_API ma_result ma_data_source_node_init(ma_node_graph* pNodeGraph, const ma_data_source_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_data_source_node* pDataSourceNode) -{ - ma_result result; - ma_format format; /* For validating the format, which must be ma_format_f32. */ - ma_uint32 channels; /* For specifying the channel count of the output bus. */ - ma_node_config baseConfig; - - if (pDataSourceNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDataSourceNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - result = ma_data_source_get_data_format(pConfig->pDataSource, &format, &channels, NULL, NULL, 0); /* Don't care about sample rate. This will check pDataSource for NULL. */ - if (result != MA_SUCCESS) { - return result; - } - - MA_ASSERT(format == ma_format_f32); /* <-- If you've triggered this it means your data source is not outputting floating-point samples. You must configure your data source to use ma_format_f32. */ - if (format != ma_format_f32) { - return MA_INVALID_ARGS; /* Invalid format. */ - } - - /* The channel count is defined by the data source. If the caller has manually changed the channels we just ignore it. */ - baseConfig = pConfig->nodeConfig; - baseConfig.vtable = &g_ma_data_source_node_vtable; /* Explicitly set the vtable here to prevent callers from setting it incorrectly. */ - - /* - The channel count is defined by the data source. It is invalid for the caller to manually set - the channel counts in the config. `ma_data_source_node_config_init()` will have defaulted the - channel count pointer to NULL which is how it must remain. If you trigger any of these asserts - it means you're explicitly setting the channel count. Instead, configure the output channel - count of your data source to be the necessary channel count. - */ - if (baseConfig.pOutputChannels != NULL) { - return MA_INVALID_ARGS; - } - - baseConfig.pOutputChannels = &channels; - - result = ma_node_init(pNodeGraph, &baseConfig, pAllocationCallbacks, &pDataSourceNode->base); - if (result != MA_SUCCESS) { - return result; - } - - pDataSourceNode->pDataSource = pConfig->pDataSource; - - return MA_SUCCESS; -} - -MA_API void ma_data_source_node_uninit(ma_data_source_node* pDataSourceNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_node_uninit(&pDataSourceNode->base, pAllocationCallbacks); -} - -MA_API ma_result ma_data_source_node_set_looping(ma_data_source_node* pDataSourceNode, ma_bool32 isLooping) -{ - if (pDataSourceNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_data_source_set_looping(pDataSourceNode->pDataSource, isLooping); -} - -MA_API ma_bool32 ma_data_source_node_is_looping(ma_data_source_node* pDataSourceNode) -{ - if (pDataSourceNode == NULL) { - return MA_FALSE; - } - - return ma_data_source_is_looping(pDataSourceNode->pDataSource); -} - - - -/* Splitter Node. */ -MA_API ma_splitter_node_config ma_splitter_node_config_init(ma_uint32 channels) -{ - ma_splitter_node_config config; - - MA_ZERO_OBJECT(&config); - config.nodeConfig = ma_node_config_init(); - config.channels = channels; - config.outputBusCount = 2; - - return config; -} - - -static void ma_splitter_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_node_base* pNodeBase = (ma_node_base*)pNode; - ma_uint32 iOutputBus; - ma_uint32 channels; - - MA_ASSERT(pNodeBase != NULL); - MA_ASSERT(ma_node_get_input_bus_count(pNodeBase) == 1); - - /* We don't need to consider the input frame count - it'll be the same as the output frame count and we process everything. */ - (void)pFrameCountIn; - - /* NOTE: This assumes the same number of channels for all inputs and outputs. This was checked in ma_splitter_node_init(). */ - channels = ma_node_get_input_channels(pNodeBase, 0); - - /* Splitting is just copying the first input bus and copying it over to each output bus. */ - for (iOutputBus = 0; iOutputBus < ma_node_get_output_bus_count(pNodeBase); iOutputBus += 1) { - ma_copy_pcm_frames(ppFramesOut[iOutputBus], ppFramesIn[0], *pFrameCountOut, ma_format_f32, channels); - } -} - -static ma_node_vtable g_ma_splitter_node_vtable = -{ - ma_splitter_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* 1 input bus. */ - MA_NODE_BUS_COUNT_UNKNOWN, /* The output bus count is specified on a per-node basis. */ - 0 -}; - -MA_API ma_result ma_splitter_node_init(ma_node_graph* pNodeGraph, const ma_splitter_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_splitter_node* pSplitterNode) -{ - ma_result result; - ma_node_config baseConfig; - ma_uint32 pInputChannels[1]; - ma_uint32 pOutputChannels[MA_MAX_NODE_BUS_COUNT]; - ma_uint32 iOutputBus; - - if (pSplitterNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pSplitterNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->outputBusCount > MA_MAX_NODE_BUS_COUNT) { - return MA_INVALID_ARGS; /* Too many output buses. */ - } - - /* Splitters require the same number of channels between inputs and outputs. */ - pInputChannels[0] = pConfig->channels; - for (iOutputBus = 0; iOutputBus < pConfig->outputBusCount; iOutputBus += 1) { - pOutputChannels[iOutputBus] = pConfig->channels; - } - - baseConfig = pConfig->nodeConfig; - baseConfig.vtable = &g_ma_splitter_node_vtable; - baseConfig.pInputChannels = pInputChannels; - baseConfig.pOutputChannels = pOutputChannels; - baseConfig.outputBusCount = pConfig->outputBusCount; - - result = ma_node_init(pNodeGraph, &baseConfig, pAllocationCallbacks, &pSplitterNode->base); - if (result != MA_SUCCESS) { - return result; /* Failed to initialize the base node. */ - } - - return MA_SUCCESS; -} - -MA_API void ma_splitter_node_uninit(ma_splitter_node* pSplitterNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_node_uninit(pSplitterNode, pAllocationCallbacks); -} - - -/* -Biquad Node -*/ -MA_API ma_biquad_node_config ma_biquad_node_config_init(ma_uint32 channels, float b0, float b1, float b2, float a0, float a1, float a2) -{ - ma_biquad_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.biquad = ma_biquad_config_init(ma_format_f32, channels, b0, b1, b2, a0, a1, a2); - - return config; -} - -static void ma_biquad_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_biquad_node* pLPFNode = (ma_biquad_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_biquad_process_pcm_frames(&pLPFNode->biquad, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_biquad_node_vtable = -{ - ma_biquad_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_biquad_node_init(ma_node_graph* pNodeGraph, const ma_biquad_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_biquad_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->biquad.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_biquad_init(&pConfig->biquad, pAllocationCallbacks, &pNode->biquad); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_biquad_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->biquad.channels; - baseNodeConfig.pOutputChannels = &pConfig->biquad.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_biquad_node_reinit(const ma_biquad_config* pConfig, ma_biquad_node* pNode) -{ - ma_biquad_node* pLPFNode = (ma_biquad_node*)pNode; - - MA_ASSERT(pNode != NULL); - - return ma_biquad_reinit(pConfig, &pLPFNode->biquad); -} - -MA_API void ma_biquad_node_uninit(ma_biquad_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_biquad_node* pLPFNode = (ma_biquad_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_biquad_uninit(&pLPFNode->biquad, pAllocationCallbacks); -} - - - -/* -Low Pass Filter Node -*/ -MA_API ma_lpf_node_config ma_lpf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order) -{ - ma_lpf_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.lpf = ma_lpf_config_init(ma_format_f32, channels, sampleRate, cutoffFrequency, order); - - return config; -} - -static void ma_lpf_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_lpf_node* pLPFNode = (ma_lpf_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_lpf_process_pcm_frames(&pLPFNode->lpf, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_lpf_node_vtable = -{ - ma_lpf_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_lpf_node_init(ma_node_graph* pNodeGraph, const ma_lpf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_lpf_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->lpf.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_lpf_init(&pConfig->lpf, pAllocationCallbacks, &pNode->lpf); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_lpf_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->lpf.channels; - baseNodeConfig.pOutputChannels = &pConfig->lpf.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_lpf_node_reinit(const ma_lpf_config* pConfig, ma_lpf_node* pNode) -{ - ma_lpf_node* pLPFNode = (ma_lpf_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_lpf_reinit(pConfig, &pLPFNode->lpf); -} - -MA_API void ma_lpf_node_uninit(ma_lpf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_lpf_node* pLPFNode = (ma_lpf_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_lpf_uninit(&pLPFNode->lpf, pAllocationCallbacks); -} - - - -/* -High Pass Filter Node -*/ -MA_API ma_hpf_node_config ma_hpf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order) -{ - ma_hpf_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.hpf = ma_hpf_config_init(ma_format_f32, channels, sampleRate, cutoffFrequency, order); - - return config; -} - -static void ma_hpf_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_hpf_node* pHPFNode = (ma_hpf_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_hpf_process_pcm_frames(&pHPFNode->hpf, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_hpf_node_vtable = -{ - ma_hpf_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_hpf_node_init(ma_node_graph* pNodeGraph, const ma_hpf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hpf_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->hpf.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_hpf_init(&pConfig->hpf, pAllocationCallbacks, &pNode->hpf); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_hpf_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->hpf.channels; - baseNodeConfig.pOutputChannels = &pConfig->hpf.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_hpf_node_reinit(const ma_hpf_config* pConfig, ma_hpf_node* pNode) -{ - ma_hpf_node* pHPFNode = (ma_hpf_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_hpf_reinit(pConfig, &pHPFNode->hpf); -} - -MA_API void ma_hpf_node_uninit(ma_hpf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_hpf_node* pHPFNode = (ma_hpf_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_hpf_uninit(&pHPFNode->hpf, pAllocationCallbacks); -} - - - - -/* -Band Pass Filter Node -*/ -MA_API ma_bpf_node_config ma_bpf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double cutoffFrequency, ma_uint32 order) -{ - ma_bpf_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.bpf = ma_bpf_config_init(ma_format_f32, channels, sampleRate, cutoffFrequency, order); - - return config; -} - -static void ma_bpf_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_bpf_node* pBPFNode = (ma_bpf_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_bpf_process_pcm_frames(&pBPFNode->bpf, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_bpf_node_vtable = -{ - ma_bpf_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_bpf_node_init(ma_node_graph* pNodeGraph, const ma_bpf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_bpf_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->bpf.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_bpf_init(&pConfig->bpf, pAllocationCallbacks, &pNode->bpf); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_bpf_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->bpf.channels; - baseNodeConfig.pOutputChannels = &pConfig->bpf.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_bpf_node_reinit(const ma_bpf_config* pConfig, ma_bpf_node* pNode) -{ - ma_bpf_node* pBPFNode = (ma_bpf_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_bpf_reinit(pConfig, &pBPFNode->bpf); -} - -MA_API void ma_bpf_node_uninit(ma_bpf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_bpf_node* pBPFNode = (ma_bpf_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_bpf_uninit(&pBPFNode->bpf, pAllocationCallbacks); -} - - - -/* -Notching Filter Node -*/ -MA_API ma_notch_node_config ma_notch_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double q, double frequency) -{ - ma_notch_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.notch = ma_notch2_config_init(ma_format_f32, channels, sampleRate, q, frequency); - - return config; -} - -static void ma_notch_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_notch_node* pBPFNode = (ma_notch_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_notch2_process_pcm_frames(&pBPFNode->notch, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_notch_node_vtable = -{ - ma_notch_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_notch_node_init(ma_node_graph* pNodeGraph, const ma_notch_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_notch_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->notch.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_notch2_init(&pConfig->notch, pAllocationCallbacks, &pNode->notch); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_notch_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->notch.channels; - baseNodeConfig.pOutputChannels = &pConfig->notch.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_notch_node_reinit(const ma_notch_config* pConfig, ma_notch_node* pNode) -{ - ma_notch_node* pNotchNode = (ma_notch_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_notch2_reinit(pConfig, &pNotchNode->notch); -} - -MA_API void ma_notch_node_uninit(ma_notch_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_notch_node* pNotchNode = (ma_notch_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_notch2_uninit(&pNotchNode->notch, pAllocationCallbacks); -} - - - -/* -Peaking Filter Node -*/ -MA_API ma_peak_node_config ma_peak_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency) -{ - ma_peak_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.peak = ma_peak2_config_init(ma_format_f32, channels, sampleRate, gainDB, q, frequency); - - return config; -} - -static void ma_peak_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_peak_node* pBPFNode = (ma_peak_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_peak2_process_pcm_frames(&pBPFNode->peak, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_peak_node_vtable = -{ - ma_peak_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_peak_node_init(ma_node_graph* pNodeGraph, const ma_peak_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_peak_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->peak.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_peak2_init(&pConfig->peak, pAllocationCallbacks, &pNode->peak); - if (result != MA_SUCCESS) { - ma_node_uninit(pNode, pAllocationCallbacks); - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_peak_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->peak.channels; - baseNodeConfig.pOutputChannels = &pConfig->peak.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_peak_node_reinit(const ma_peak_config* pConfig, ma_peak_node* pNode) -{ - ma_peak_node* pPeakNode = (ma_peak_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_peak2_reinit(pConfig, &pPeakNode->peak); -} - -MA_API void ma_peak_node_uninit(ma_peak_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_peak_node* pPeakNode = (ma_peak_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_peak2_uninit(&pPeakNode->peak, pAllocationCallbacks); -} - - - -/* -Low Shelf Filter Node -*/ -MA_API ma_loshelf_node_config ma_loshelf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency) -{ - ma_loshelf_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.loshelf = ma_loshelf2_config_init(ma_format_f32, channels, sampleRate, gainDB, q, frequency); - - return config; -} - -static void ma_loshelf_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_loshelf_node* pBPFNode = (ma_loshelf_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_loshelf2_process_pcm_frames(&pBPFNode->loshelf, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_loshelf_node_vtable = -{ - ma_loshelf_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_loshelf_node_init(ma_node_graph* pNodeGraph, const ma_loshelf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_loshelf_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->loshelf.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_loshelf2_init(&pConfig->loshelf, pAllocationCallbacks, &pNode->loshelf); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_loshelf_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->loshelf.channels; - baseNodeConfig.pOutputChannels = &pConfig->loshelf.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_loshelf_node_reinit(const ma_loshelf_config* pConfig, ma_loshelf_node* pNode) -{ - ma_loshelf_node* pLoshelfNode = (ma_loshelf_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_loshelf2_reinit(pConfig, &pLoshelfNode->loshelf); -} - -MA_API void ma_loshelf_node_uninit(ma_loshelf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_loshelf_node* pLoshelfNode = (ma_loshelf_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_loshelf2_uninit(&pLoshelfNode->loshelf, pAllocationCallbacks); -} - - - -/* -High Shelf Filter Node -*/ -MA_API ma_hishelf_node_config ma_hishelf_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, double gainDB, double q, double frequency) -{ - ma_hishelf_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.hishelf = ma_hishelf2_config_init(ma_format_f32, channels, sampleRate, gainDB, q, frequency); - - return config; -} - -static void ma_hishelf_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_hishelf_node* pBPFNode = (ma_hishelf_node*)pNode; - - MA_ASSERT(pNode != NULL); - (void)pFrameCountIn; - - ma_hishelf2_process_pcm_frames(&pBPFNode->hishelf, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_hishelf_node_vtable = -{ - ma_hishelf_node_process_pcm_frames, - NULL, /* onGetRequiredInputFrameCount */ - 1, /* One input. */ - 1, /* One output. */ - 0 /* Default flags. */ -}; - -MA_API ma_result ma_hishelf_node_init(ma_node_graph* pNodeGraph, const ma_hishelf_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_hishelf_node* pNode) -{ - ma_result result; - ma_node_config baseNodeConfig; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pNode); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->hishelf.format != ma_format_f32) { - return MA_INVALID_ARGS; /* The format must be f32. */ - } - - result = ma_hishelf2_init(&pConfig->hishelf, pAllocationCallbacks, &pNode->hishelf); - if (result != MA_SUCCESS) { - return result; - } - - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_hishelf_node_vtable; - baseNodeConfig.pInputChannels = &pConfig->hishelf.channels; - baseNodeConfig.pOutputChannels = &pConfig->hishelf.channels; - - result = ma_node_init(pNodeGraph, &baseNodeConfig, pAllocationCallbacks, pNode); - if (result != MA_SUCCESS) { - return result; - } - - return result; -} - -MA_API ma_result ma_hishelf_node_reinit(const ma_hishelf_config* pConfig, ma_hishelf_node* pNode) -{ - ma_hishelf_node* pHishelfNode = (ma_hishelf_node*)pNode; - - if (pNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_hishelf2_reinit(pConfig, &pHishelfNode->hishelf); -} - -MA_API void ma_hishelf_node_uninit(ma_hishelf_node* pNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - ma_hishelf_node* pHishelfNode = (ma_hishelf_node*)pNode; - - if (pNode == NULL) { - return; - } - - ma_node_uninit(pNode, pAllocationCallbacks); - ma_hishelf2_uninit(&pHishelfNode->hishelf, pAllocationCallbacks); -} - - - - -MA_API ma_delay_node_config ma_delay_node_config_init(ma_uint32 channels, ma_uint32 sampleRate, ma_uint32 delayInFrames, float decay) -{ - ma_delay_node_config config; - - config.nodeConfig = ma_node_config_init(); - config.delay = ma_delay_config_init(channels, sampleRate, delayInFrames, decay); - - return config; -} - - -static void ma_delay_node_process_pcm_frames(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_delay_node* pDelayNode = (ma_delay_node*)pNode; - - (void)pFrameCountIn; - - ma_delay_process_pcm_frames(&pDelayNode->delay, ppFramesOut[0], ppFramesIn[0], *pFrameCountOut); -} - -static ma_node_vtable g_ma_delay_node_vtable = -{ - ma_delay_node_process_pcm_frames, - NULL, - 1, /* 1 input channels. */ - 1, /* 1 output channel. */ - MA_NODE_FLAG_CONTINUOUS_PROCESSING /* Delay requires continuous processing to ensure the tail get's processed. */ -}; - -MA_API ma_result ma_delay_node_init(ma_node_graph* pNodeGraph, const ma_delay_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_delay_node* pDelayNode) -{ - ma_result result; - ma_node_config baseConfig; - - if (pDelayNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pDelayNode); - - result = ma_delay_init(&pConfig->delay, pAllocationCallbacks, &pDelayNode->delay); - if (result != MA_SUCCESS) { - return result; - } - - baseConfig = pConfig->nodeConfig; - baseConfig.vtable = &g_ma_delay_node_vtable; - baseConfig.pInputChannels = &pConfig->delay.channels; - baseConfig.pOutputChannels = &pConfig->delay.channels; - - result = ma_node_init(pNodeGraph, &baseConfig, pAllocationCallbacks, &pDelayNode->baseNode); - if (result != MA_SUCCESS) { - ma_delay_uninit(&pDelayNode->delay, pAllocationCallbacks); - return result; - } - - return result; -} - -MA_API void ma_delay_node_uninit(ma_delay_node* pDelayNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - if (pDelayNode == NULL) { - return; - } - - /* The base node is always uninitialized first. */ - ma_node_uninit(pDelayNode, pAllocationCallbacks); - ma_delay_uninit(&pDelayNode->delay, pAllocationCallbacks); -} - -MA_API void ma_delay_node_set_wet(ma_delay_node* pDelayNode, float value) -{ - if (pDelayNode == NULL) { - return; - } - - ma_delay_set_wet(&pDelayNode->delay, value); -} - -MA_API float ma_delay_node_get_wet(const ma_delay_node* pDelayNode) -{ - if (pDelayNode == NULL) { - return 0; - } - - return ma_delay_get_wet(&pDelayNode->delay); -} - -MA_API void ma_delay_node_set_dry(ma_delay_node* pDelayNode, float value) -{ - if (pDelayNode == NULL) { - return; - } - - ma_delay_set_dry(&pDelayNode->delay, value); -} - -MA_API float ma_delay_node_get_dry(const ma_delay_node* pDelayNode) -{ - if (pDelayNode == NULL) { - return 0; - } - - return ma_delay_get_dry(&pDelayNode->delay); -} - -MA_API void ma_delay_node_set_decay(ma_delay_node* pDelayNode, float value) -{ - if (pDelayNode == NULL) { - return; - } - - ma_delay_set_decay(&pDelayNode->delay, value); -} - -MA_API float ma_delay_node_get_decay(const ma_delay_node* pDelayNode) -{ - if (pDelayNode == NULL) { - return 0; - } - - return ma_delay_get_decay(&pDelayNode->delay); -} -#endif /* MA_NO_NODE_GRAPH */ - - -/* SECTION: miniaudio_engine.c */ -#if !defined(MA_NO_ENGINE) && !defined(MA_NO_NODE_GRAPH) -/************************************************************************************************************************************************************** - -Engine - -**************************************************************************************************************************************************************/ -#define MA_SEEK_TARGET_NONE (~(ma_uint64)0) - - -static void ma_sound_set_at_end(ma_sound* pSound, ma_bool32 atEnd) -{ - MA_ASSERT(pSound != NULL); - c89atomic_exchange_32(&pSound->atEnd, atEnd); - - /* Fire any callbacks or events. */ - if (atEnd) { - if (pSound->endCallback != NULL) { - pSound->endCallback(pSound->pEndCallbackUserData, pSound); - } - } -} - -static ma_bool32 ma_sound_get_at_end(const ma_sound* pSound) -{ - MA_ASSERT(pSound != NULL); - return c89atomic_load_32(&pSound->atEnd); -} - - -MA_API ma_engine_node_config ma_engine_node_config_init(ma_engine* pEngine, ma_engine_node_type type, ma_uint32 flags) -{ - ma_engine_node_config config; - - MA_ZERO_OBJECT(&config); - config.pEngine = pEngine; - config.type = type; - config.isPitchDisabled = (flags & MA_SOUND_FLAG_NO_PITCH) != 0; - config.isSpatializationDisabled = (flags & MA_SOUND_FLAG_NO_SPATIALIZATION) != 0; - config.monoExpansionMode = pEngine->monoExpansionMode; - - return config; -} - - -static void ma_engine_node_update_pitch_if_required(ma_engine_node* pEngineNode) -{ - ma_bool32 isUpdateRequired = MA_FALSE; - float newPitch; - - MA_ASSERT(pEngineNode != NULL); - - newPitch = c89atomic_load_explicit_f32(&pEngineNode->pitch, c89atomic_memory_order_acquire); - - if (pEngineNode->oldPitch != newPitch) { - pEngineNode->oldPitch = newPitch; - isUpdateRequired = MA_TRUE; - } - - if (pEngineNode->oldDopplerPitch != pEngineNode->spatializer.dopplerPitch) { - pEngineNode->oldDopplerPitch = pEngineNode->spatializer.dopplerPitch; - isUpdateRequired = MA_TRUE; - } - - if (isUpdateRequired) { - float basePitch = (float)pEngineNode->sampleRate / ma_engine_get_sample_rate(pEngineNode->pEngine); - ma_linear_resampler_set_rate_ratio(&pEngineNode->resampler, basePitch * pEngineNode->oldPitch * pEngineNode->oldDopplerPitch); - } -} - -static ma_bool32 ma_engine_node_is_pitching_enabled(const ma_engine_node* pEngineNode) -{ - MA_ASSERT(pEngineNode != NULL); - - /* Don't try to be clever by skiping resampling in the pitch=1 case or else you'll glitch when moving away from 1. */ - return !c89atomic_load_explicit_32(&pEngineNode->isPitchDisabled, c89atomic_memory_order_acquire); -} - -static ma_bool32 ma_engine_node_is_spatialization_enabled(const ma_engine_node* pEngineNode) -{ - MA_ASSERT(pEngineNode != NULL); - - return !c89atomic_load_explicit_32(&pEngineNode->isSpatializationDisabled, c89atomic_memory_order_acquire); -} - -static ma_uint64 ma_engine_node_get_required_input_frame_count(const ma_engine_node* pEngineNode, ma_uint64 outputFrameCount) -{ - ma_uint64 inputFrameCount = 0; - - if (ma_engine_node_is_pitching_enabled(pEngineNode)) { - ma_result result = ma_linear_resampler_get_required_input_frame_count(&pEngineNode->resampler, outputFrameCount, &inputFrameCount); - if (result != MA_SUCCESS) { - inputFrameCount = 0; - } - } else { - inputFrameCount = outputFrameCount; /* No resampling, so 1:1. */ - } - - return inputFrameCount; -} - -static ma_result ma_engine_node_set_volume(ma_engine_node* pEngineNode, float volume) -{ - if (pEngineNode == NULL) { - return MA_INVALID_ARGS; - } - - /* We should always have an active spatializer because it can be enabled and disabled dynamically. We can just use that for hodling our volume. */ - ma_spatializer_set_master_volume(&pEngineNode->spatializer, volume); - - return MA_SUCCESS; -} - -static ma_result ma_engine_node_get_volume(const ma_engine_node* pEngineNode, float* pVolume) -{ - if (pVolume == NULL) { - return MA_INVALID_ARGS; - } - - *pVolume = 0.0f; - - if (pEngineNode == NULL) { - return MA_INVALID_ARGS; - } - - return ma_spatializer_get_master_volume(&pEngineNode->spatializer, pVolume); -} - - -static void ma_engine_node_process_pcm_frames__general(ma_engine_node* pEngineNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - ma_uint32 frameCountIn; - ma_uint32 frameCountOut; - ma_uint32 totalFramesProcessedIn; - ma_uint32 totalFramesProcessedOut; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_bool32 isPitchingEnabled; - ma_bool32 isFadingEnabled; - ma_bool32 isSpatializationEnabled; - ma_bool32 isPanningEnabled; - - frameCountIn = *pFrameCountIn; - frameCountOut = *pFrameCountOut; - - channelsIn = ma_spatializer_get_input_channels(&pEngineNode->spatializer); - channelsOut = ma_spatializer_get_output_channels(&pEngineNode->spatializer); - - totalFramesProcessedIn = 0; - totalFramesProcessedOut = 0; - - isPitchingEnabled = ma_engine_node_is_pitching_enabled(pEngineNode); - isFadingEnabled = pEngineNode->fader.volumeBeg != 1 || pEngineNode->fader.volumeEnd != 1; - isSpatializationEnabled = ma_engine_node_is_spatialization_enabled(pEngineNode); - isPanningEnabled = pEngineNode->panner.pan != 0 && channelsOut != 1; - - /* Keep going while we've still got data available for processing. */ - while (totalFramesProcessedOut < frameCountOut) { - /* - We need to process in a specific order. We always do resampling first because it's likely - we're going to be increasing the channel count after spatialization. Also, I want to do - fading based on the output sample rate. - - We'll first read into a buffer from the resampler. Then we'll do all processing that - operates on the on the input channel count. We'll then get the spatializer to output to - the output buffer and then do all effects from that point directly in the output buffer - in-place. - - Note that we're always running the resampler. If we try to be clever and skip resampling - when the pitch is 1, we'll get a glitch when we move away from 1, back to 1, and then - away from 1 again. We'll want to implement any pitch=1 optimizations in the resampler - itself. - - There's a small optimization here that we'll utilize since it might be a fairly common - case. When the input and output channel counts are the same, we'll read straight into the - output buffer from the resampler and do everything in-place. - */ - const float* pRunningFramesIn; - float* pRunningFramesOut; - float* pWorkingBuffer; /* This is the buffer that we'll be processing frames in. This is in input channels. */ - float temp[MA_DATA_CONVERTER_STACK_BUFFER_SIZE / sizeof(float)]; - ma_uint32 tempCapInFrames = ma_countof(temp) / channelsIn; - ma_uint32 framesAvailableIn; - ma_uint32 framesAvailableOut; - ma_uint32 framesJustProcessedIn; - ma_uint32 framesJustProcessedOut; - ma_bool32 isWorkingBufferValid = MA_FALSE; - - framesAvailableIn = frameCountIn - totalFramesProcessedIn; - framesAvailableOut = frameCountOut - totalFramesProcessedOut; - - pRunningFramesIn = ma_offset_pcm_frames_const_ptr_f32(ppFramesIn[0], totalFramesProcessedIn, channelsIn); - pRunningFramesOut = ma_offset_pcm_frames_ptr_f32(ppFramesOut[0], totalFramesProcessedOut, channelsOut); - - if (channelsIn == channelsOut) { - /* Fast path. Channel counts are the same. No need for an intermediary input buffer. */ - pWorkingBuffer = pRunningFramesOut; - } else { - /* Slow path. Channel counts are different. Need to use an intermediary input buffer. */ - pWorkingBuffer = temp; - if (framesAvailableOut > tempCapInFrames) { - framesAvailableOut = tempCapInFrames; - } - } - - /* First is resampler. */ - if (isPitchingEnabled) { - ma_uint64 resampleFrameCountIn = framesAvailableIn; - ma_uint64 resampleFrameCountOut = framesAvailableOut; - - ma_linear_resampler_process_pcm_frames(&pEngineNode->resampler, pRunningFramesIn, &resampleFrameCountIn, pWorkingBuffer, &resampleFrameCountOut); - isWorkingBufferValid = MA_TRUE; - - framesJustProcessedIn = (ma_uint32)resampleFrameCountIn; - framesJustProcessedOut = (ma_uint32)resampleFrameCountOut; - } else { - framesJustProcessedIn = ma_min(framesAvailableIn, framesAvailableOut); - framesJustProcessedOut = framesJustProcessedIn; /* When no resampling is being performed, the number of output frames is the same as input frames. */ - } - - /* Fading. */ - if (isFadingEnabled) { - if (isWorkingBufferValid) { - ma_fader_process_pcm_frames(&pEngineNode->fader, pWorkingBuffer, pWorkingBuffer, framesJustProcessedOut); /* In-place processing. */ - } else { - ma_fader_process_pcm_frames(&pEngineNode->fader, pWorkingBuffer, pRunningFramesIn, framesJustProcessedOut); - isWorkingBufferValid = MA_TRUE; - } - } - - /* - If at this point we still haven't actually done anything with the working buffer we need - to just read straight from the input buffer. - */ - if (isWorkingBufferValid == MA_FALSE) { - pWorkingBuffer = (float*)pRunningFramesIn; /* Naughty const cast, but it's safe at this point because we won't ever be writing to it from this point out. */ - } - - /* Spatialization. */ - if (isSpatializationEnabled) { - ma_uint32 iListener; - - /* - When determining the listener to use, we first check to see if the sound is pinned to a - specific listener. If so, we use that. Otherwise we just use the closest listener. - */ - if (pEngineNode->pinnedListenerIndex != MA_LISTENER_INDEX_CLOSEST && pEngineNode->pinnedListenerIndex < ma_engine_get_listener_count(pEngineNode->pEngine)) { - iListener = pEngineNode->pinnedListenerIndex; - } else { - ma_vec3f spatializerPosition = ma_spatializer_get_position(&pEngineNode->spatializer); - iListener = ma_engine_find_closest_listener(pEngineNode->pEngine, spatializerPosition.x, spatializerPosition.y, spatializerPosition.z); - } - - ma_spatializer_process_pcm_frames(&pEngineNode->spatializer, &pEngineNode->pEngine->listeners[iListener], pRunningFramesOut, pWorkingBuffer, framesJustProcessedOut); - } else { - /* No spatialization, but we still need to do channel conversion and master volume. */ - float volume; - ma_engine_node_get_volume(pEngineNode, &volume); /* Should never fail. */ - - if (channelsIn == channelsOut) { - /* No channel conversion required. Just copy straight to the output buffer. */ - ma_copy_and_apply_volume_factor_f32(pRunningFramesOut, pWorkingBuffer, framesJustProcessedOut * channelsOut, volume); - } else { - /* Channel conversion required. TODO: Add support for channel maps here. */ - ma_channel_map_apply_f32(pRunningFramesOut, NULL, channelsOut, pWorkingBuffer, NULL, channelsIn, framesJustProcessedOut, ma_channel_mix_mode_simple, pEngineNode->monoExpansionMode); - ma_apply_volume_factor_f32(pRunningFramesOut, framesJustProcessedOut * channelsOut, volume); - } - } - - /* At this point we can guarantee that the output buffer contains valid data. We can process everything in place now. */ - - /* Panning. */ - if (isPanningEnabled) { - ma_panner_process_pcm_frames(&pEngineNode->panner, pRunningFramesOut, pRunningFramesOut, framesJustProcessedOut); /* In-place processing. */ - } - - /* We're done for this chunk. */ - totalFramesProcessedIn += framesJustProcessedIn; - totalFramesProcessedOut += framesJustProcessedOut; - - /* If we didn't process any output frames this iteration it means we've either run out of input data, or run out of room in the output buffer. */ - if (framesJustProcessedOut == 0) { - break; - } - } - - /* At this point we're done processing. */ - *pFrameCountIn = totalFramesProcessedIn; - *pFrameCountOut = totalFramesProcessedOut; -} - -static void ma_engine_node_process_pcm_frames__sound(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - /* For sounds, we need to first read from the data source. Then we need to apply the engine effects (pan, pitch, fades, etc.). */ - ma_result result = MA_SUCCESS; - ma_sound* pSound = (ma_sound*)pNode; - ma_uint32 frameCount = *pFrameCountOut; - ma_uint32 totalFramesRead = 0; - ma_format dataSourceFormat; - ma_uint32 dataSourceChannels; - ma_uint8 temp[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; - ma_uint32 tempCapInFrames; - ma_uint64 seekTarget; - - /* This is a data source node which means no input buses. */ - (void)ppFramesIn; - (void)pFrameCountIn; - - /* If we're marked at the end we need to stop the sound and do nothing. */ - if (ma_sound_at_end(pSound)) { - ma_sound_stop(pSound); - *pFrameCountOut = 0; - return; - } - - /* If we're seeking, do so now before reading. */ - seekTarget = c89atomic_load_64(&pSound->seekTarget); - if (seekTarget != MA_SEEK_TARGET_NONE) { - ma_data_source_seek_to_pcm_frame(pSound->pDataSource, seekTarget); - - /* Any time-dependant effects need to have their times updated. */ - ma_node_set_time(pSound, seekTarget); - - c89atomic_exchange_64(&pSound->seekTarget, MA_SEEK_TARGET_NONE); - } - - /* - We want to update the pitch once. For sounds, this can be either at the start or at the end. If - we don't force this to only ever be updating once, we could end up in a situation where - retrieving the required input frame count ends up being different to what we actually retrieve. - What could happen is that the required input frame count is calculated, the pitch is update, - and then this processing function is called resulting in a different number of input frames - being processed. Do not call this in ma_engine_node_process_pcm_frames__general() or else - you'll hit the aforementioned bug. - */ - ma_engine_node_update_pitch_if_required(&pSound->engineNode); - - /* - For the convenience of the caller, we're doing to allow data sources to use non-floating-point formats and channel counts that differ - from the main engine. - */ - result = ma_data_source_get_data_format(pSound->pDataSource, &dataSourceFormat, &dataSourceChannels, NULL, NULL, 0); - if (result == MA_SUCCESS) { - tempCapInFrames = sizeof(temp) / ma_get_bytes_per_frame(dataSourceFormat, dataSourceChannels); - - /* Keep reading until we've read as much as was requested or we reach the end of the data source. */ - while (totalFramesRead < frameCount) { - ma_uint32 framesRemaining = frameCount - totalFramesRead; - ma_uint32 framesToRead; - ma_uint64 framesJustRead; - ma_uint32 frameCountIn; - ma_uint32 frameCountOut; - const float* pRunningFramesIn; - float* pRunningFramesOut; - - /* - The first thing we need to do is read into the temporary buffer. We can calculate exactly - how many input frames we'll need after resampling. - */ - framesToRead = (ma_uint32)ma_engine_node_get_required_input_frame_count(&pSound->engineNode, framesRemaining); - if (framesToRead > tempCapInFrames) { - framesToRead = tempCapInFrames; - } - - result = ma_data_source_read_pcm_frames(pSound->pDataSource, temp, framesToRead, &framesJustRead); - - /* If we reached the end of the sound we'll want to mark it as at the end and stop it. This should never be returned for looping sounds. */ - if (result == MA_AT_END) { - ma_sound_set_at_end(pSound, MA_TRUE); /* This will be set to false in ma_sound_start(). */ - } - - pRunningFramesOut = ma_offset_pcm_frames_ptr_f32(ppFramesOut[0], totalFramesRead, ma_engine_get_channels(ma_sound_get_engine(pSound))); - - frameCountIn = (ma_uint32)framesJustRead; - frameCountOut = framesRemaining; - - /* Convert if necessary. */ - if (dataSourceFormat == ma_format_f32) { - /* Fast path. No data conversion necessary. */ - pRunningFramesIn = (float*)temp; - ma_engine_node_process_pcm_frames__general(&pSound->engineNode, &pRunningFramesIn, &frameCountIn, &pRunningFramesOut, &frameCountOut); - } else { - /* Slow path. Need to do sample format conversion to f32. If we give the f32 buffer the same count as the first temp buffer, we're guaranteed it'll be large enough. */ - float tempf32[MA_DATA_CONVERTER_STACK_BUFFER_SIZE]; /* Do not do `MA_DATA_CONVERTER_STACK_BUFFER_SIZE/sizeof(float)` here like we've done in other places. */ - ma_convert_pcm_frames_format(tempf32, ma_format_f32, temp, dataSourceFormat, framesJustRead, dataSourceChannels, ma_dither_mode_none); - - /* Now that we have our samples in f32 format we can process like normal. */ - pRunningFramesIn = tempf32; - ma_engine_node_process_pcm_frames__general(&pSound->engineNode, &pRunningFramesIn, &frameCountIn, &pRunningFramesOut, &frameCountOut); - } - - /* We should have processed all of our input frames since we calculated the required number of input frames at the top. */ - MA_ASSERT(frameCountIn == framesJustRead); - totalFramesRead += (ma_uint32)frameCountOut; /* Safe cast. */ - - if (result != MA_SUCCESS || ma_sound_at_end(pSound)) { - break; /* Might have reached the end. */ - } - } - } - - *pFrameCountOut = totalFramesRead; -} - -static void ma_engine_node_process_pcm_frames__group(ma_node* pNode, const float** ppFramesIn, ma_uint32* pFrameCountIn, float** ppFramesOut, ma_uint32* pFrameCountOut) -{ - /* - Make sure the pitch is updated before trying to read anything. It's important that this is done - only once and not in ma_engine_node_process_pcm_frames__general(). The reason for this is that - ma_engine_node_process_pcm_frames__general() will call ma_engine_node_get_required_input_frame_count(), - and if another thread modifies the pitch just after that call it can result in a glitch due to - the input rate changing. - */ - ma_engine_node_update_pitch_if_required((ma_engine_node*)pNode); - - /* For groups, the input data has already been read and we just need to apply the effect. */ - ma_engine_node_process_pcm_frames__general((ma_engine_node*)pNode, ppFramesIn, pFrameCountIn, ppFramesOut, pFrameCountOut); -} - -static ma_result ma_engine_node_get_required_input_frame_count__group(ma_node* pNode, ma_uint32 outputFrameCount, ma_uint32* pInputFrameCount) -{ - ma_uint64 inputFrameCount; - - MA_ASSERT(pInputFrameCount != NULL); - - /* Our pitch will affect this calculation. We need to update it. */ - ma_engine_node_update_pitch_if_required((ma_engine_node*)pNode); - - inputFrameCount = ma_engine_node_get_required_input_frame_count((ma_engine_node*)pNode, outputFrameCount); - if (inputFrameCount > 0xFFFFFFFF) { - inputFrameCount = 0xFFFFFFFF; /* Will never happen because miniaudio will only ever process in relatively small chunks. */ - } - - *pInputFrameCount = (ma_uint32)inputFrameCount; - - return MA_SUCCESS; -} - - -static ma_node_vtable g_ma_engine_node_vtable__sound = -{ - ma_engine_node_process_pcm_frames__sound, - NULL, /* onGetRequiredInputFrameCount */ - 0, /* Sounds are data source nodes which means they have zero inputs (their input is drawn from the data source itself). */ - 1, /* Sounds have one output bus. */ - 0 /* Default flags. */ -}; - -static ma_node_vtable g_ma_engine_node_vtable__group = -{ - ma_engine_node_process_pcm_frames__group, - ma_engine_node_get_required_input_frame_count__group, - 1, /* Groups have one input bus. */ - 1, /* Groups have one output bus. */ - MA_NODE_FLAG_DIFFERENT_PROCESSING_RATES /* The engine node does resampling so should let miniaudio know about it. */ -}; - - - -static ma_node_config ma_engine_node_base_node_config_init(const ma_engine_node_config* pConfig) -{ - ma_node_config baseNodeConfig; - - if (pConfig->type == ma_engine_node_type_sound) { - /* Sound. */ - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_engine_node_vtable__sound; - baseNodeConfig.initialState = ma_node_state_stopped; /* Sounds are stopped by default. */ - } else { - /* Group. */ - baseNodeConfig = ma_node_config_init(); - baseNodeConfig.vtable = &g_ma_engine_node_vtable__group; - baseNodeConfig.initialState = ma_node_state_started; /* Groups are started by default. */ - } - - return baseNodeConfig; -} - -static ma_spatializer_config ma_engine_node_spatializer_config_init(const ma_node_config* pBaseNodeConfig) -{ - return ma_spatializer_config_init(pBaseNodeConfig->pInputChannels[0], pBaseNodeConfig->pOutputChannels[0]); -} - -typedef struct -{ - size_t sizeInBytes; - size_t baseNodeOffset; - size_t resamplerOffset; - size_t spatializerOffset; -} ma_engine_node_heap_layout; - -static ma_result ma_engine_node_get_heap_layout(const ma_engine_node_config* pConfig, ma_engine_node_heap_layout* pHeapLayout) -{ - ma_result result; - size_t tempHeapSize; - ma_node_config baseNodeConfig; - ma_linear_resampler_config resamplerConfig; - ma_spatializer_config spatializerConfig; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_channel defaultStereoChannelMap[2] = {MA_CHANNEL_SIDE_LEFT, MA_CHANNEL_SIDE_RIGHT}; /* <-- Consistent with the default channel map of a stereo listener. Means channel conversion can run on a fast path. */ - - MA_ASSERT(pHeapLayout); - - MA_ZERO_OBJECT(pHeapLayout); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - if (pConfig->pEngine == NULL) { - return MA_INVALID_ARGS; /* An engine must be specified. */ - } - - pHeapLayout->sizeInBytes = 0; - - channelsIn = (pConfig->channelsIn != 0) ? pConfig->channelsIn : ma_engine_get_channels(pConfig->pEngine); - channelsOut = (pConfig->channelsOut != 0) ? pConfig->channelsOut : ma_engine_get_channels(pConfig->pEngine); - - - /* Base node. */ - baseNodeConfig = ma_engine_node_base_node_config_init(pConfig); - baseNodeConfig.pInputChannels = &channelsIn; - baseNodeConfig.pOutputChannels = &channelsOut; - - result = ma_node_get_heap_size(ma_engine_get_node_graph(pConfig->pEngine), &baseNodeConfig, &tempHeapSize); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the size of the heap for the base node. */ - } - - pHeapLayout->baseNodeOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(tempHeapSize); - - - /* Resmapler. */ - resamplerConfig = ma_linear_resampler_config_init(ma_format_f32, channelsIn, 1, 1); /* Input and output sample rates don't affect the calculation of the heap size. */ - resamplerConfig.lpfOrder = 0; - - result = ma_linear_resampler_get_heap_size(&resamplerConfig, &tempHeapSize); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the size of the heap for the resampler. */ - } - - pHeapLayout->resamplerOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(tempHeapSize); - - - /* Spatializer. */ - spatializerConfig = ma_engine_node_spatializer_config_init(&baseNodeConfig); - - if (spatializerConfig.channelsIn == 2) { - spatializerConfig.pChannelMapIn = defaultStereoChannelMap; - } - - result = ma_spatializer_get_heap_size(&spatializerConfig, &tempHeapSize); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the size of the heap for the spatializer. */ - } - - pHeapLayout->spatializerOffset = pHeapLayout->sizeInBytes; - pHeapLayout->sizeInBytes += ma_align_64(tempHeapSize); - - - return MA_SUCCESS; -} - -MA_API ma_result ma_engine_node_get_heap_size(const ma_engine_node_config* pConfig, size_t* pHeapSizeInBytes) -{ - ma_result result; - ma_engine_node_heap_layout heapLayout; - - if (pHeapSizeInBytes == NULL) { - return MA_INVALID_ARGS; - } - - *pHeapSizeInBytes = 0; - - result = ma_engine_node_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - *pHeapSizeInBytes = heapLayout.sizeInBytes; - - return MA_SUCCESS; -} - -MA_API ma_result ma_engine_node_init_preallocated(const ma_engine_node_config* pConfig, void* pHeap, ma_engine_node* pEngineNode) -{ - ma_result result; - ma_engine_node_heap_layout heapLayout; - ma_node_config baseNodeConfig; - ma_linear_resampler_config resamplerConfig; - ma_fader_config faderConfig; - ma_spatializer_config spatializerConfig; - ma_panner_config pannerConfig; - ma_uint32 channelsIn; - ma_uint32 channelsOut; - ma_channel defaultStereoChannelMap[2] = {MA_CHANNEL_SIDE_LEFT, MA_CHANNEL_SIDE_RIGHT}; /* <-- Consistent with the default channel map of a stereo listener. Means channel conversion can run on a fast path. */ - - if (pEngineNode == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pEngineNode); - - result = ma_engine_node_get_heap_layout(pConfig, &heapLayout); - if (result != MA_SUCCESS) { - return result; - } - - if (pConfig->pinnedListenerIndex != MA_LISTENER_INDEX_CLOSEST && pConfig->pinnedListenerIndex >= ma_engine_get_listener_count(pConfig->pEngine)) { - return MA_INVALID_ARGS; /* Invalid listener. */ - } - - pEngineNode->_pHeap = pHeap; - MA_ZERO_MEMORY(pHeap, heapLayout.sizeInBytes); - - pEngineNode->pEngine = pConfig->pEngine; - pEngineNode->sampleRate = (pConfig->sampleRate > 0) ? pConfig->sampleRate : ma_engine_get_sample_rate(pEngineNode->pEngine); - pEngineNode->monoExpansionMode = pConfig->monoExpansionMode; - pEngineNode->pitch = 1; - pEngineNode->oldPitch = 1; - pEngineNode->oldDopplerPitch = 1; - pEngineNode->isPitchDisabled = pConfig->isPitchDisabled; - pEngineNode->isSpatializationDisabled = pConfig->isSpatializationDisabled; - pEngineNode->pinnedListenerIndex = pConfig->pinnedListenerIndex; - - channelsIn = (pConfig->channelsIn != 0) ? pConfig->channelsIn : ma_engine_get_channels(pConfig->pEngine); - channelsOut = (pConfig->channelsOut != 0) ? pConfig->channelsOut : ma_engine_get_channels(pConfig->pEngine); - - /* - If the sample rate of the sound is different to the engine, make sure pitching is enabled so that the resampler - is activated. Not doing this will result in the sound not being resampled if MA_SOUND_FLAG_NO_PITCH is used. - */ - if (pEngineNode->sampleRate != ma_engine_get_sample_rate(pEngineNode->pEngine)) { - pEngineNode->isPitchDisabled = MA_FALSE; - } - - - /* Base node. */ - baseNodeConfig = ma_engine_node_base_node_config_init(pConfig); - baseNodeConfig.pInputChannels = &channelsIn; - baseNodeConfig.pOutputChannels = &channelsOut; - - result = ma_node_init_preallocated(&pConfig->pEngine->nodeGraph, &baseNodeConfig, ma_offset_ptr(pHeap, heapLayout.baseNodeOffset), &pEngineNode->baseNode); - if (result != MA_SUCCESS) { - goto error0; - } - - - /* - We can now initialize the effects we need in order to implement the engine node. There's a - defined order of operations here, mainly centered around when we convert our channels from the - data source's native channel count to the engine's channel count. As a rule, we want to do as - much computation as possible before spatialization because there's a chance that will increase - the channel count, thereby increasing the amount of work needing to be done to process. - */ - - /* We'll always do resampling first. */ - resamplerConfig = ma_linear_resampler_config_init(ma_format_f32, baseNodeConfig.pInputChannels[0], pEngineNode->sampleRate, ma_engine_get_sample_rate(pEngineNode->pEngine)); - resamplerConfig.lpfOrder = 0; /* <-- Need to disable low-pass filtering for pitch shifting for now because there's cases where the biquads are becoming unstable. Need to figure out a better fix for this. */ - - result = ma_linear_resampler_init_preallocated(&resamplerConfig, ma_offset_ptr(pHeap, heapLayout.resamplerOffset), &pEngineNode->resampler); - if (result != MA_SUCCESS) { - goto error1; - } - - - /* After resampling will come the fader. */ - faderConfig = ma_fader_config_init(ma_format_f32, baseNodeConfig.pInputChannels[0], ma_engine_get_sample_rate(pEngineNode->pEngine)); - - result = ma_fader_init(&faderConfig, &pEngineNode->fader); - if (result != MA_SUCCESS) { - goto error2; - } - - - /* - Spatialization comes next. We spatialize based ont he node's output channel count. It's up the caller to - ensure channels counts link up correctly in the node graph. - */ - spatializerConfig = ma_engine_node_spatializer_config_init(&baseNodeConfig); - spatializerConfig.gainSmoothTimeInFrames = pEngineNode->pEngine->gainSmoothTimeInFrames; - - if (spatializerConfig.channelsIn == 2) { - spatializerConfig.pChannelMapIn = defaultStereoChannelMap; - } - - result = ma_spatializer_init_preallocated(&spatializerConfig, ma_offset_ptr(pHeap, heapLayout.spatializerOffset), &pEngineNode->spatializer); - if (result != MA_SUCCESS) { - goto error2; - } - - - /* - After spatialization comes panning. We need to do this after spatialization because otherwise we wouldn't - be able to pan mono sounds. - */ - pannerConfig = ma_panner_config_init(ma_format_f32, baseNodeConfig.pOutputChannels[0]); - - result = ma_panner_init(&pannerConfig, &pEngineNode->panner); - if (result != MA_SUCCESS) { - goto error3; - } - - return MA_SUCCESS; - - /* No need for allocation callbacks here because we use a preallocated heap. */ -error3: ma_spatializer_uninit(&pEngineNode->spatializer, NULL); -error2: ma_linear_resampler_uninit(&pEngineNode->resampler, NULL); -error1: ma_node_uninit(&pEngineNode->baseNode, NULL); -error0: return result; -} - -MA_API ma_result ma_engine_node_init(const ma_engine_node_config* pConfig, const ma_allocation_callbacks* pAllocationCallbacks, ma_engine_node* pEngineNode) -{ - ma_result result; - size_t heapSizeInBytes; - void* pHeap; - - result = ma_engine_node_get_heap_size(pConfig, &heapSizeInBytes); - if (result != MA_SUCCESS) { - return result; - } - - if (heapSizeInBytes > 0) { - pHeap = ma_malloc(heapSizeInBytes, pAllocationCallbacks); - if (pHeap == NULL) { - return MA_OUT_OF_MEMORY; - } - } else { - pHeap = NULL; - } - - result = ma_engine_node_init_preallocated(pConfig, pHeap, pEngineNode); - if (result != MA_SUCCESS) { - ma_free(pHeap, pAllocationCallbacks); - return result; - } - - pEngineNode->_ownsHeap = MA_TRUE; - return MA_SUCCESS; -} - -MA_API void ma_engine_node_uninit(ma_engine_node* pEngineNode, const ma_allocation_callbacks* pAllocationCallbacks) -{ - /* - The base node always needs to be uninitialized first to ensure it's detached from the graph completely before we - destroy anything that might be in the middle of being used by the processing function. - */ - ma_node_uninit(&pEngineNode->baseNode, pAllocationCallbacks); - - /* Now that the node has been uninitialized we can safely uninitialize the rest. */ - ma_spatializer_uninit(&pEngineNode->spatializer, pAllocationCallbacks); - ma_linear_resampler_uninit(&pEngineNode->resampler, pAllocationCallbacks); - - /* Free the heap last. */ - if (pEngineNode->_ownsHeap) { - ma_free(pEngineNode->_pHeap, pAllocationCallbacks); - } -} - - -MA_API ma_sound_config ma_sound_config_init(void) -{ - return ma_sound_config_init_2(NULL); -} - -MA_API ma_sound_config ma_sound_config_init_2(ma_engine* pEngine) -{ - ma_sound_config config; - - MA_ZERO_OBJECT(&config); - - if (pEngine != NULL) { - config.monoExpansionMode = pEngine->monoExpansionMode; - } else { - config.monoExpansionMode = ma_mono_expansion_mode_default; - } - - config.rangeEndInPCMFrames = ~((ma_uint64)0); - config.loopPointEndInPCMFrames = ~((ma_uint64)0); - - return config; -} - -MA_API ma_sound_group_config ma_sound_group_config_init(void) -{ - return ma_sound_group_config_init_2(NULL); -} - -MA_API ma_sound_group_config ma_sound_group_config_init_2(ma_engine* pEngine) -{ - ma_sound_group_config config; - - MA_ZERO_OBJECT(&config); - - if (pEngine != NULL) { - config.monoExpansionMode = pEngine->monoExpansionMode; - } else { - config.monoExpansionMode = ma_mono_expansion_mode_default; - } - - return config; -} - - -MA_API ma_engine_config ma_engine_config_init(void) -{ - ma_engine_config config; - - MA_ZERO_OBJECT(&config); - config.listenerCount = 1; /* Always want at least one listener. */ - config.monoExpansionMode = ma_mono_expansion_mode_default; - - return config; -} - - -#if !defined(MA_NO_DEVICE_IO) -static void ma_engine_data_callback_internal(ma_device* pDevice, void* pFramesOut, const void* pFramesIn, ma_uint32 frameCount) -{ - ma_engine* pEngine = (ma_engine*)pDevice->pUserData; - - (void)pFramesIn; - - /* - Experiment: Try processing a resource manager job if we're on the Emscripten build. - - This serves two purposes: - - 1) It ensures jobs are actually processed at some point since we cannot guarantee that the - caller is doing the right thing and calling ma_resource_manager_process_next_job(); and - - 2) It's an attempt at working around an issue where processing jobs on the Emscripten main - loop doesn't work as well as it should. When trying to load sounds without the `DECODE` - flag or with the `ASYNC` flag, the sound data is just not able to be loaded in time - before the callback is processed. I think it's got something to do with the single- - threaded nature of Web, but I'm not entirely sure. - */ - #if !defined(MA_NO_RESOURCE_MANAGER) && defined(MA_EMSCRIPTEN) - { - if (pEngine->pResourceManager != NULL) { - if ((pEngine->pResourceManager->config.flags & MA_RESOURCE_MANAGER_FLAG_NO_THREADING) != 0) { - ma_resource_manager_process_next_job(pEngine->pResourceManager); - } - } - } - #endif - - ma_engine_read_pcm_frames(pEngine, pFramesOut, frameCount, NULL); -} -#endif - -MA_API ma_result ma_engine_init(const ma_engine_config* pConfig, ma_engine* pEngine) -{ - ma_result result; - ma_node_graph_config nodeGraphConfig; - ma_engine_config engineConfig; - ma_spatializer_listener_config listenerConfig; - ma_uint32 iListener; - - if (pEngine == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pEngine); - - /* The config is allowed to be NULL in which case we use defaults for everything. */ - if (pConfig != NULL) { - engineConfig = *pConfig; - } else { - engineConfig = ma_engine_config_init(); - } - - pEngine->monoExpansionMode = engineConfig.monoExpansionMode; - ma_allocation_callbacks_init_copy(&pEngine->allocationCallbacks, &engineConfig.allocationCallbacks); - - #if !defined(MA_NO_RESOURCE_MANAGER) - { - pEngine->pResourceManager = engineConfig.pResourceManager; - } - #endif - - #if !defined(MA_NO_DEVICE_IO) - { - pEngine->pDevice = engineConfig.pDevice; - - /* If we don't have a device, we need one. */ - if (pEngine->pDevice == NULL && engineConfig.noDevice == MA_FALSE) { - ma_device_config deviceConfig; - - pEngine->pDevice = (ma_device*)ma_malloc(sizeof(*pEngine->pDevice), &pEngine->allocationCallbacks); - if (pEngine->pDevice == NULL) { - return MA_OUT_OF_MEMORY; - } - - deviceConfig = ma_device_config_init(ma_device_type_playback); - deviceConfig.playback.pDeviceID = engineConfig.pPlaybackDeviceID; - deviceConfig.playback.format = ma_format_f32; - deviceConfig.playback.channels = engineConfig.channels; - deviceConfig.sampleRate = engineConfig.sampleRate; - deviceConfig.dataCallback = ma_engine_data_callback_internal; - deviceConfig.pUserData = pEngine; - deviceConfig.notificationCallback = engineConfig.notificationCallback; - deviceConfig.periodSizeInFrames = engineConfig.periodSizeInFrames; - deviceConfig.periodSizeInMilliseconds = engineConfig.periodSizeInMilliseconds; - deviceConfig.noPreSilencedOutputBuffer = MA_TRUE; /* We'll always be outputting to every frame in the callback so there's no need for a pre-silenced buffer. */ - deviceConfig.noClip = MA_TRUE; /* The engine will do clipping itself. */ - - if (engineConfig.pContext == NULL) { - ma_context_config contextConfig = ma_context_config_init(); - contextConfig.allocationCallbacks = pEngine->allocationCallbacks; - contextConfig.pLog = engineConfig.pLog; - - /* If the engine config does not specify a log, use the resource manager's if we have one. */ - #ifndef MA_NO_RESOURCE_MANAGER - { - if (contextConfig.pLog == NULL && engineConfig.pResourceManager != NULL) { - contextConfig.pLog = ma_resource_manager_get_log(engineConfig.pResourceManager); - } - } - #endif - - result = ma_device_init_ex(NULL, 0, &contextConfig, &deviceConfig, pEngine->pDevice); - } else { - result = ma_device_init(engineConfig.pContext, &deviceConfig, pEngine->pDevice); - } - - if (result != MA_SUCCESS) { - ma_free(pEngine->pDevice, &pEngine->allocationCallbacks); - pEngine->pDevice = NULL; - return result; - } - - pEngine->ownsDevice = MA_TRUE; - } - - /* Update the channel count and sample rate of the engine config so we can reference it below. */ - if (pEngine->pDevice != NULL) { - engineConfig.channels = pEngine->pDevice->playback.channels; - engineConfig.sampleRate = pEngine->pDevice->sampleRate; - } - } - #endif - - if (engineConfig.channels == 0 || engineConfig.sampleRate == 0) { - return MA_INVALID_ARGS; - } - - pEngine->sampleRate = engineConfig.sampleRate; - - /* The engine always uses either the log that was passed into the config, or the context's log is available. */ - if (engineConfig.pLog != NULL) { - pEngine->pLog = engineConfig.pLog; - } else { - #if !defined(MA_NO_DEVICE_IO) - { - pEngine->pLog = ma_device_get_log(pEngine->pDevice); - } - #else - { - pEngine->pLog = NULL; - } - #endif - } - - - /* The engine is a node graph. This needs to be initialized after we have the device so we can can determine the channel count. */ - nodeGraphConfig = ma_node_graph_config_init(engineConfig.channels); - nodeGraphConfig.nodeCacheCapInFrames = (engineConfig.periodSizeInFrames > 0xFFFF) ? 0xFFFF : (ma_uint16)engineConfig.periodSizeInFrames; - - result = ma_node_graph_init(&nodeGraphConfig, &pEngine->allocationCallbacks, &pEngine->nodeGraph); - if (result != MA_SUCCESS) { - goto on_error_1; - } - - - /* We need at least one listener. */ - if (engineConfig.listenerCount == 0) { - engineConfig.listenerCount = 1; - } - - if (engineConfig.listenerCount > MA_ENGINE_MAX_LISTENERS) { - result = MA_INVALID_ARGS; /* Too many listeners. */ - goto on_error_1; - } - - for (iListener = 0; iListener < engineConfig.listenerCount; iListener += 1) { - listenerConfig = ma_spatializer_listener_config_init(ma_node_graph_get_channels(&pEngine->nodeGraph)); - - /* - If we're using a device, use the device's channel map for the listener. Otherwise just use - miniaudio's default channel map. - */ - #if !defined(MA_NO_DEVICE_IO) - { - if (pEngine->pDevice != NULL) { - /* - Temporarily disabled. There is a subtle bug here where front-left and front-right - will be used by the device's channel map, but this is not what we want to use for - spatialization. Instead we want to use side-left and side-right. I need to figure - out a better solution for this. For now, disabling the use of device channel maps. - */ - /*listenerConfig.pChannelMapOut = pEngine->pDevice->playback.channelMap;*/ - } - } - #endif - - result = ma_spatializer_listener_init(&listenerConfig, &pEngine->allocationCallbacks, &pEngine->listeners[iListener]); /* TODO: Change this to a pre-allocated heap. */ - if (result != MA_SUCCESS) { - goto on_error_2; - } - - pEngine->listenerCount += 1; - } - - - /* Gain smoothing for spatialized sounds. */ - pEngine->gainSmoothTimeInFrames = engineConfig.gainSmoothTimeInFrames; - if (pEngine->gainSmoothTimeInFrames == 0) { - ma_uint32 gainSmoothTimeInMilliseconds = engineConfig.gainSmoothTimeInMilliseconds; - if (gainSmoothTimeInMilliseconds == 0) { - gainSmoothTimeInMilliseconds = 8; - } - - pEngine->gainSmoothTimeInFrames = (gainSmoothTimeInMilliseconds * ma_engine_get_sample_rate(pEngine)) / 1000; /* 8ms by default. */ - } - - - /* We need a resource manager. */ - #ifndef MA_NO_RESOURCE_MANAGER - { - if (pEngine->pResourceManager == NULL) { - ma_resource_manager_config resourceManagerConfig; - - pEngine->pResourceManager = (ma_resource_manager*)ma_malloc(sizeof(*pEngine->pResourceManager), &pEngine->allocationCallbacks); - if (pEngine->pResourceManager == NULL) { - result = MA_OUT_OF_MEMORY; - goto on_error_2; - } - - resourceManagerConfig = ma_resource_manager_config_init(); - resourceManagerConfig.pLog = pEngine->pLog; /* Always use the engine's log for internally-managed resource managers. */ - resourceManagerConfig.decodedFormat = ma_format_f32; - resourceManagerConfig.decodedChannels = 0; /* Leave the decoded channel count as 0 so we can get good spatialization. */ - resourceManagerConfig.decodedSampleRate = ma_engine_get_sample_rate(pEngine); - ma_allocation_callbacks_init_copy(&resourceManagerConfig.allocationCallbacks, &pEngine->allocationCallbacks); - resourceManagerConfig.pVFS = engineConfig.pResourceManagerVFS; - - /* The Emscripten build cannot use threads. */ - #if defined(MA_EMSCRIPTEN) - { - resourceManagerConfig.jobThreadCount = 0; - resourceManagerConfig.flags |= MA_RESOURCE_MANAGER_FLAG_NO_THREADING; - } - #endif - - result = ma_resource_manager_init(&resourceManagerConfig, pEngine->pResourceManager); - if (result != MA_SUCCESS) { - goto on_error_3; - } - - pEngine->ownsResourceManager = MA_TRUE; - } - } - #endif - - /* Setup some stuff for inlined sounds. That is sounds played with ma_engine_play_sound(). */ - pEngine->inlinedSoundLock = 0; - pEngine->pInlinedSoundHead = NULL; - - /* Start the engine if required. This should always be the last step. */ - #if !defined(MA_NO_DEVICE_IO) - { - if (engineConfig.noAutoStart == MA_FALSE && pEngine->pDevice != NULL) { - result = ma_engine_start(pEngine); - if (result != MA_SUCCESS) { - goto on_error_4; /* Failed to start the engine. */ - } - } - } - #endif - - return MA_SUCCESS; - -#if !defined(MA_NO_DEVICE_IO) -on_error_4: -#endif -#if !defined(MA_NO_RESOURCE_MANAGER) -on_error_3: - if (pEngine->ownsResourceManager) { - ma_free(pEngine->pResourceManager, &pEngine->allocationCallbacks); - } -#endif /* MA_NO_RESOURCE_MANAGER */ -on_error_2: - for (iListener = 0; iListener < pEngine->listenerCount; iListener += 1) { - ma_spatializer_listener_uninit(&pEngine->listeners[iListener], &pEngine->allocationCallbacks); - } - - ma_node_graph_uninit(&pEngine->nodeGraph, &pEngine->allocationCallbacks); -on_error_1: - #if !defined(MA_NO_DEVICE_IO) - { - if (pEngine->ownsDevice) { - ma_device_uninit(pEngine->pDevice); - ma_free(pEngine->pDevice, &pEngine->allocationCallbacks); - } - } - #endif - - return result; -} - -MA_API void ma_engine_uninit(ma_engine* pEngine) -{ - ma_uint32 iListener; - - if (pEngine == NULL) { - return; - } - - /* The device must be uninitialized before the node graph to ensure the audio thread doesn't try accessing it. */ - #if !defined(MA_NO_DEVICE_IO) - { - if (pEngine->ownsDevice) { - ma_device_uninit(pEngine->pDevice); - ma_free(pEngine->pDevice, &pEngine->allocationCallbacks); - } else { - if (pEngine->pDevice != NULL) { - ma_device_stop(pEngine->pDevice); - } - } - } - #endif - - /* - All inlined sounds need to be deleted. I'm going to use a lock here just to future proof in case - I want to do some kind of garbage collection later on. - */ - ma_spinlock_lock(&pEngine->inlinedSoundLock); - { - for (;;) { - ma_sound_inlined* pSoundToDelete = pEngine->pInlinedSoundHead; - if (pSoundToDelete == NULL) { - break; /* Done. */ - } - - pEngine->pInlinedSoundHead = pSoundToDelete->pNext; - - ma_sound_uninit(&pSoundToDelete->sound); - ma_free(pSoundToDelete, &pEngine->allocationCallbacks); - } - } - ma_spinlock_unlock(&pEngine->inlinedSoundLock); - - for (iListener = 0; iListener < pEngine->listenerCount; iListener += 1) { - ma_spatializer_listener_uninit(&pEngine->listeners[iListener], &pEngine->allocationCallbacks); - } - - /* Make sure the node graph is uninitialized after the audio thread has been shutdown to prevent accessing of the node graph after being uninitialized. */ - ma_node_graph_uninit(&pEngine->nodeGraph, &pEngine->allocationCallbacks); - - /* Uninitialize the resource manager last to ensure we don't have a thread still trying to access it. */ -#ifndef MA_NO_RESOURCE_MANAGER - if (pEngine->ownsResourceManager) { - ma_resource_manager_uninit(pEngine->pResourceManager); - ma_free(pEngine->pResourceManager, &pEngine->allocationCallbacks); - } -#endif -} - -MA_API ma_result ma_engine_read_pcm_frames(ma_engine* pEngine, void* pFramesOut, ma_uint64 frameCount, ma_uint64* pFramesRead) -{ - return ma_node_graph_read_pcm_frames(&pEngine->nodeGraph, pFramesOut, frameCount, pFramesRead); -} - -MA_API ma_node_graph* ma_engine_get_node_graph(ma_engine* pEngine) -{ - if (pEngine == NULL) { - return NULL; - } - - return &pEngine->nodeGraph; -} - -#if !defined(MA_NO_RESOURCE_MANAGER) -MA_API ma_resource_manager* ma_engine_get_resource_manager(ma_engine* pEngine) -{ - if (pEngine == NULL) { - return NULL; - } - - #if !defined(MA_NO_RESOURCE_MANAGER) - { - return pEngine->pResourceManager; - } - #else - { - return NULL; - } - #endif -} -#endif - -MA_API ma_device* ma_engine_get_device(ma_engine* pEngine) -{ - if (pEngine == NULL) { - return NULL; - } - - #if !defined(MA_NO_DEVICE_IO) - { - return pEngine->pDevice; - } - #else - { - return NULL; - } - #endif -} - -MA_API ma_log* ma_engine_get_log(ma_engine* pEngine) -{ - if (pEngine == NULL) { - return NULL; - } - - if (pEngine->pLog != NULL) { - return pEngine->pLog; - } else { - #if !defined(MA_NO_DEVICE_IO) - { - return ma_device_get_log(ma_engine_get_device(pEngine)); - } - #else - { - return NULL; - } - #endif - } -} - -MA_API ma_node* ma_engine_get_endpoint(ma_engine* pEngine) -{ - return ma_node_graph_get_endpoint(&pEngine->nodeGraph); -} - -MA_API ma_uint64 ma_engine_get_time(const ma_engine* pEngine) -{ - return ma_node_graph_get_time(&pEngine->nodeGraph); -} - -MA_API ma_result ma_engine_set_time(ma_engine* pEngine, ma_uint64 globalTime) -{ - return ma_node_graph_set_time(&pEngine->nodeGraph, globalTime); -} - -MA_API ma_uint32 ma_engine_get_channels(const ma_engine* pEngine) -{ - return ma_node_graph_get_channels(&pEngine->nodeGraph); -} - -MA_API ma_uint32 ma_engine_get_sample_rate(const ma_engine* pEngine) -{ - if (pEngine == NULL) { - return 0; - } - - return pEngine->sampleRate; -} - - -MA_API ma_result ma_engine_start(ma_engine* pEngine) -{ - ma_result result; - - if (pEngine == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_DEVICE_IO) - { - if (pEngine->pDevice != NULL) { - result = ma_device_start(pEngine->pDevice); - } else { - result = MA_INVALID_OPERATION; /* The engine is running without a device which means there's no real notion of "starting" the engine. */ - } - } - #else - { - result = MA_INVALID_OPERATION; /* Device IO is disabled, so there's no real notion of "starting" the engine. */ - } - #endif - - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_engine_stop(ma_engine* pEngine) -{ - ma_result result; - - if (pEngine == NULL) { - return MA_INVALID_ARGS; - } - - #if !defined(MA_NO_DEVICE_IO) - { - if (pEngine->pDevice != NULL) { - result = ma_device_stop(pEngine->pDevice); - } else { - result = MA_INVALID_OPERATION; /* The engine is running without a device which means there's no real notion of "stopping" the engine. */ - } - } - #else - { - result = MA_INVALID_OPERATION; /* Device IO is disabled, so there's no real notion of "stopping" the engine. */ - } - #endif - - if (result != MA_SUCCESS) { - return result; - } - - return MA_SUCCESS; -} - -MA_API ma_result ma_engine_set_volume(ma_engine* pEngine, float volume) -{ - if (pEngine == NULL) { - return MA_INVALID_ARGS; - } - - return ma_node_set_output_bus_volume(ma_node_graph_get_endpoint(&pEngine->nodeGraph), 0, volume); -} - -MA_API ma_result ma_engine_set_gain_db(ma_engine* pEngine, float gainDB) -{ - if (pEngine == NULL) { - return MA_INVALID_ARGS; - } - - return ma_node_set_output_bus_volume(ma_node_graph_get_endpoint(&pEngine->nodeGraph), 0, ma_volume_db_to_linear(gainDB)); -} - - -MA_API ma_uint32 ma_engine_get_listener_count(const ma_engine* pEngine) -{ - if (pEngine == NULL) { - return 0; - } - - return pEngine->listenerCount; -} - -MA_API ma_uint32 ma_engine_find_closest_listener(const ma_engine* pEngine, float absolutePosX, float absolutePosY, float absolutePosZ) -{ - ma_uint32 iListener; - ma_uint32 iListenerClosest; - float closestLen2 = MA_FLT_MAX; - - if (pEngine == NULL || pEngine->listenerCount == 1) { - return 0; - } - - iListenerClosest = 0; - for (iListener = 0; iListener < pEngine->listenerCount; iListener += 1) { - if (ma_engine_listener_is_enabled(pEngine, iListener)) { - float len2 = ma_vec3f_len2(ma_vec3f_sub(ma_spatializer_listener_get_position(&pEngine->listeners[iListener]), ma_vec3f_init_3f(absolutePosX, absolutePosY, absolutePosZ))); - if (closestLen2 > len2) { - closestLen2 = len2; - iListenerClosest = iListener; - } - } - } - - MA_ASSERT(iListenerClosest < 255); - return iListenerClosest; -} - -MA_API void ma_engine_listener_set_position(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return; - } - - ma_spatializer_listener_set_position(&pEngine->listeners[listenerIndex], x, y, z); -} - -MA_API ma_vec3f ma_engine_listener_get_position(const ma_engine* pEngine, ma_uint32 listenerIndex) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_spatializer_listener_get_position(&pEngine->listeners[listenerIndex]); -} - -MA_API void ma_engine_listener_set_direction(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return; - } - - ma_spatializer_listener_set_direction(&pEngine->listeners[listenerIndex], x, y, z); -} - -MA_API ma_vec3f ma_engine_listener_get_direction(const ma_engine* pEngine, ma_uint32 listenerIndex) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return ma_vec3f_init_3f(0, 0, -1); - } - - return ma_spatializer_listener_get_direction(&pEngine->listeners[listenerIndex]); -} - -MA_API void ma_engine_listener_set_velocity(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return; - } - - ma_spatializer_listener_set_velocity(&pEngine->listeners[listenerIndex], x, y, z); -} - -MA_API ma_vec3f ma_engine_listener_get_velocity(const ma_engine* pEngine, ma_uint32 listenerIndex) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_spatializer_listener_get_velocity(&pEngine->listeners[listenerIndex]); -} - -MA_API void ma_engine_listener_set_cone(ma_engine* pEngine, ma_uint32 listenerIndex, float innerAngleInRadians, float outerAngleInRadians, float outerGain) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return; - } - - ma_spatializer_listener_set_cone(&pEngine->listeners[listenerIndex], innerAngleInRadians, outerAngleInRadians, outerGain); -} - -MA_API void ma_engine_listener_get_cone(const ma_engine* pEngine, ma_uint32 listenerIndex, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain) -{ - if (pInnerAngleInRadians != NULL) { - *pInnerAngleInRadians = 0; - } - - if (pOuterAngleInRadians != NULL) { - *pOuterAngleInRadians = 0; - } - - if (pOuterGain != NULL) { - *pOuterGain = 0; - } - - ma_spatializer_listener_get_cone(&pEngine->listeners[listenerIndex], pInnerAngleInRadians, pOuterAngleInRadians, pOuterGain); -} - -MA_API void ma_engine_listener_set_world_up(ma_engine* pEngine, ma_uint32 listenerIndex, float x, float y, float z) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return; - } - - ma_spatializer_listener_set_world_up(&pEngine->listeners[listenerIndex], x, y, z); -} - -MA_API ma_vec3f ma_engine_listener_get_world_up(const ma_engine* pEngine, ma_uint32 listenerIndex) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return ma_vec3f_init_3f(0, 1, 0); - } - - return ma_spatializer_listener_get_world_up(&pEngine->listeners[listenerIndex]); -} - -MA_API void ma_engine_listener_set_enabled(ma_engine* pEngine, ma_uint32 listenerIndex, ma_bool32 isEnabled) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return; - } - - ma_spatializer_listener_set_enabled(&pEngine->listeners[listenerIndex], isEnabled); -} - -MA_API ma_bool32 ma_engine_listener_is_enabled(const ma_engine* pEngine, ma_uint32 listenerIndex) -{ - if (pEngine == NULL || listenerIndex >= pEngine->listenerCount) { - return MA_FALSE; - } - - return ma_spatializer_listener_is_enabled(&pEngine->listeners[listenerIndex]); -} - - -#ifndef MA_NO_RESOURCE_MANAGER -MA_API ma_result ma_engine_play_sound_ex(ma_engine* pEngine, const char* pFilePath, ma_node* pNode, ma_uint32 nodeInputBusIndex) -{ - ma_result result = MA_SUCCESS; - ma_sound_inlined* pSound = NULL; - ma_sound_inlined* pNextSound = NULL; - - if (pEngine == NULL || pFilePath == NULL) { - return MA_INVALID_ARGS; - } - - /* Attach to the endpoint node if nothing is specicied. */ - if (pNode == NULL) { - pNode = ma_node_graph_get_endpoint(&pEngine->nodeGraph); - nodeInputBusIndex = 0; - } - - /* - We want to check if we can recycle an already-allocated inlined sound. Since this is just a - helper I'm not *too* concerned about performance here and I'm happy to use a lock to keep - the implementation simple. Maybe this can be optimized later if there's enough demand, but - if this function is being used it probably means the caller doesn't really care too much. - - What we do is check the atEnd flag. When this is true, we can recycle the sound. Otherwise - we just keep iterating. If we reach the end without finding a sound to recycle we just - allocate a new one. This doesn't scale well for a massive number of sounds being played - simultaneously as we don't ever actually free the sound objects. Some kind of garbage - collection routine might be valuable for this which I'll think about. - */ - ma_spinlock_lock(&pEngine->inlinedSoundLock); - { - ma_uint32 soundFlags = 0; - - for (pNextSound = pEngine->pInlinedSoundHead; pNextSound != NULL; pNextSound = pNextSound->pNext) { - if (ma_sound_at_end(&pNextSound->sound)) { - /* - The sound is at the end which means it's available for recycling. All we need to do - is uninitialize it and reinitialize it. All we're doing is recycling memory. - */ - pSound = pNextSound; - c89atomic_fetch_sub_32(&pEngine->inlinedSoundCount, 1); - break; - } - } - - if (pSound != NULL) { - /* - We actually want to detach the sound from the list here. The reason is because we want the sound - to be in a consistent state at the non-recycled case to simplify the logic below. - */ - if (pEngine->pInlinedSoundHead == pSound) { - pEngine->pInlinedSoundHead = pSound->pNext; - } - - if (pSound->pPrev != NULL) { - pSound->pPrev->pNext = pSound->pNext; - } - if (pSound->pNext != NULL) { - pSound->pNext->pPrev = pSound->pPrev; - } - - /* Now the previous sound needs to be uninitialized. */ - ma_sound_uninit(&pNextSound->sound); - } else { - /* No sound available for recycling. Allocate one now. */ - pSound = (ma_sound_inlined*)ma_malloc(sizeof(*pSound), &pEngine->allocationCallbacks); - } - - if (pSound != NULL) { /* Safety check for the allocation above. */ - /* - At this point we should have memory allocated for the inlined sound. We just need - to initialize it like a normal sound now. - */ - soundFlags |= MA_SOUND_FLAG_ASYNC; /* For inlined sounds we don't want to be sitting around waiting for stuff to load so force an async load. */ - soundFlags |= MA_SOUND_FLAG_NO_DEFAULT_ATTACHMENT; /* We want specific control over where the sound is attached in the graph. We'll attach it manually just before playing the sound. */ - soundFlags |= MA_SOUND_FLAG_NO_PITCH; /* Pitching isn't usable with inlined sounds, so disable it to save on speed. */ - soundFlags |= MA_SOUND_FLAG_NO_SPATIALIZATION; /* Not currently doing spatialization with inlined sounds, but this might actually change later. For now disable spatialization. Will be removed if we ever add support for spatialization here. */ - - result = ma_sound_init_from_file(pEngine, pFilePath, soundFlags, NULL, NULL, &pSound->sound); - if (result == MA_SUCCESS) { - /* Now attach the sound to the graph. */ - result = ma_node_attach_output_bus(pSound, 0, pNode, nodeInputBusIndex); - if (result == MA_SUCCESS) { - /* At this point the sound should be loaded and we can go ahead and add it to the list. The new item becomes the new head. */ - pSound->pNext = pEngine->pInlinedSoundHead; - pSound->pPrev = NULL; - - pEngine->pInlinedSoundHead = pSound; /* <-- This is what attaches the sound to the list. */ - if (pSound->pNext != NULL) { - pSound->pNext->pPrev = pSound; - } - } else { - ma_free(pSound, &pEngine->allocationCallbacks); - } - } else { - ma_free(pSound, &pEngine->allocationCallbacks); - } - } else { - result = MA_OUT_OF_MEMORY; - } - } - ma_spinlock_unlock(&pEngine->inlinedSoundLock); - - if (result != MA_SUCCESS) { - return result; - } - - /* Finally we can start playing the sound. */ - result = ma_sound_start(&pSound->sound); - if (result != MA_SUCCESS) { - /* Failed to start the sound. We need to mark it for recycling and return an error. */ - c89atomic_exchange_32(&pSound->sound.atEnd, MA_TRUE); - return result; - } - - c89atomic_fetch_add_32(&pEngine->inlinedSoundCount, 1); - return result; -} - -MA_API ma_result ma_engine_play_sound(ma_engine* pEngine, const char* pFilePath, ma_sound_group* pGroup) -{ - return ma_engine_play_sound_ex(pEngine, pFilePath, pGroup, 0); -} -#endif - - -static ma_result ma_sound_preinit(ma_engine* pEngine, ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pSound); - pSound->seekTarget = MA_SEEK_TARGET_NONE; - - if (pEngine == NULL) { - return MA_INVALID_ARGS; - } - - return MA_SUCCESS; -} - -static ma_result ma_sound_init_from_data_source_internal(ma_engine* pEngine, const ma_sound_config* pConfig, ma_sound* pSound) -{ - ma_result result; - ma_engine_node_config engineNodeConfig; - ma_engine_node_type type; /* Will be set to ma_engine_node_type_group if no data source is specified. */ - - /* Do not clear pSound to zero here - that's done at a higher level with ma_sound_preinit(). */ - MA_ASSERT(pEngine != NULL); - MA_ASSERT(pSound != NULL); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - pSound->pDataSource = pConfig->pDataSource; - - if (pConfig->pDataSource != NULL) { - type = ma_engine_node_type_sound; - } else { - type = ma_engine_node_type_group; - } - - /* - Sounds are engine nodes. Before we can initialize this we need to determine the channel count. - If we can't do this we need to abort. It's up to the caller to ensure they're using a data - source that provides this information upfront. - */ - engineNodeConfig = ma_engine_node_config_init(pEngine, type, pConfig->flags); - engineNodeConfig.channelsIn = pConfig->channelsIn; - engineNodeConfig.channelsOut = pConfig->channelsOut; - engineNodeConfig.monoExpansionMode = pConfig->monoExpansionMode; - - /* If we're loading from a data source the input channel count needs to be the data source's native channel count. */ - if (pConfig->pDataSource != NULL) { - result = ma_data_source_get_data_format(pConfig->pDataSource, NULL, &engineNodeConfig.channelsIn, &engineNodeConfig.sampleRate, NULL, 0); - if (result != MA_SUCCESS) { - return result; /* Failed to retrieve the channel count. */ - } - - if (engineNodeConfig.channelsIn == 0) { - return MA_INVALID_OPERATION; /* Invalid channel count. */ - } - - if (engineNodeConfig.channelsOut == MA_SOUND_SOURCE_CHANNEL_COUNT) { - engineNodeConfig.channelsOut = engineNodeConfig.channelsIn; - } - } - - - /* Getting here means we should have a valid channel count and we can initialize the engine node. */ - result = ma_engine_node_init(&engineNodeConfig, &pEngine->allocationCallbacks, &pSound->engineNode); - if (result != MA_SUCCESS) { - return result; - } - - /* If no attachment is specified, attach the sound straight to the endpoint. */ - if (pConfig->pInitialAttachment == NULL) { - /* No group. Attach straight to the endpoint by default, unless the caller has requested that it not. */ - if ((pConfig->flags & MA_SOUND_FLAG_NO_DEFAULT_ATTACHMENT) == 0) { - result = ma_node_attach_output_bus(pSound, 0, ma_node_graph_get_endpoint(&pEngine->nodeGraph), 0); - } - } else { - /* An attachment is specified. Attach to it by default. The sound has only a single output bus, and the config will specify which input bus to attach to. */ - result = ma_node_attach_output_bus(pSound, 0, pConfig->pInitialAttachment, pConfig->initialAttachmentInputBusIndex); - } - - if (result != MA_SUCCESS) { - ma_engine_node_uninit(&pSound->engineNode, &pEngine->allocationCallbacks); - return result; - } - - - /* Apply initial range and looping state to the data source if applicable. */ - if (pConfig->rangeBegInPCMFrames != 0 || pConfig->rangeEndInPCMFrames != ~((ma_uint64)0)) { - ma_data_source_set_range_in_pcm_frames(ma_sound_get_data_source(pSound), pConfig->rangeBegInPCMFrames, pConfig->rangeEndInPCMFrames); - } - - if (pConfig->loopPointBegInPCMFrames != 0 || pConfig->loopPointEndInPCMFrames != ~((ma_uint64)0)) { - ma_data_source_set_range_in_pcm_frames(ma_sound_get_data_source(pSound), pConfig->loopPointBegInPCMFrames, pConfig->loopPointEndInPCMFrames); - } - - ma_sound_set_looping(pSound, pConfig->isLooping); - - return MA_SUCCESS; -} - -#ifndef MA_NO_RESOURCE_MANAGER -MA_API ma_result ma_sound_init_from_file_internal(ma_engine* pEngine, const ma_sound_config* pConfig, ma_sound* pSound) -{ - ma_result result = MA_SUCCESS; - ma_uint32 flags; - ma_sound_config config; - ma_resource_manager_pipeline_notifications notifications; - - /* - The engine requires knowledge of the channel count of the underlying data source before it can - initialize the sound. Therefore, we need to make the resource manager wait until initialization - of the underlying data source to be initialized so we can get access to the channel count. To - do this, the MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT is forced. - - Because we're initializing the data source before the sound, there's a chance the notification - will get triggered before this function returns. This is OK, so long as the caller is aware of - it and can avoid accessing the sound from within the notification. - */ - flags = pConfig->flags | MA_RESOURCE_MANAGER_DATA_SOURCE_FLAG_WAIT_INIT; - - pSound->pResourceManagerDataSource = (ma_resource_manager_data_source*)ma_malloc(sizeof(*pSound->pResourceManagerDataSource), &pEngine->allocationCallbacks); - if (pSound->pResourceManagerDataSource == NULL) { - return MA_OUT_OF_MEMORY; - } - - /* Removed in 0.12. Set pDoneFence on the notifications. */ - notifications = pConfig->initNotifications; - if (pConfig->pDoneFence != NULL && notifications.done.pFence == NULL) { - notifications.done.pFence = pConfig->pDoneFence; - } - - /* - We must wrap everything around the fence if one was specified. This ensures ma_fence_wait() does - not return prematurely before the sound has finished initializing. - */ - if (notifications.done.pFence) { ma_fence_acquire(notifications.done.pFence); } - { - ma_resource_manager_data_source_config resourceManagerDataSourceConfig = ma_resource_manager_data_source_config_init(); - resourceManagerDataSourceConfig.pFilePath = pConfig->pFilePath; - resourceManagerDataSourceConfig.pFilePathW = pConfig->pFilePathW; - resourceManagerDataSourceConfig.flags = flags; - resourceManagerDataSourceConfig.pNotifications = ¬ifications; - resourceManagerDataSourceConfig.initialSeekPointInPCMFrames = pConfig->initialSeekPointInPCMFrames; - resourceManagerDataSourceConfig.rangeBegInPCMFrames = pConfig->rangeBegInPCMFrames; - resourceManagerDataSourceConfig.rangeEndInPCMFrames = pConfig->rangeEndInPCMFrames; - resourceManagerDataSourceConfig.loopPointBegInPCMFrames = pConfig->loopPointBegInPCMFrames; - resourceManagerDataSourceConfig.loopPointEndInPCMFrames = pConfig->loopPointEndInPCMFrames; - resourceManagerDataSourceConfig.isLooping = pConfig->isLooping; - - result = ma_resource_manager_data_source_init_ex(pEngine->pResourceManager, &resourceManagerDataSourceConfig, pSound->pResourceManagerDataSource); - if (result != MA_SUCCESS) { - goto done; - } - - pSound->ownsDataSource = MA_TRUE; /* <-- Important. Not setting this will result in the resource manager data source never getting uninitialized. */ - - /* We need to use a slightly customized version of the config so we'll need to make a copy. */ - config = *pConfig; - config.pFilePath = NULL; - config.pFilePathW = NULL; - config.pDataSource = pSound->pResourceManagerDataSource; - - result = ma_sound_init_from_data_source_internal(pEngine, &config, pSound); - if (result != MA_SUCCESS) { - ma_resource_manager_data_source_uninit(pSound->pResourceManagerDataSource); - ma_free(pSound->pResourceManagerDataSource, &pEngine->allocationCallbacks); - MA_ZERO_OBJECT(pSound); - goto done; - } - } -done: - if (notifications.done.pFence) { ma_fence_release(notifications.done.pFence); } - return result; -} - -MA_API ma_result ma_sound_init_from_file(ma_engine* pEngine, const char* pFilePath, ma_uint32 flags, ma_sound_group* pGroup, ma_fence* pDoneFence, ma_sound* pSound) -{ - ma_sound_config config; - - if (pFilePath == NULL) { - return MA_INVALID_ARGS; - } - - config = ma_sound_config_init_2(pEngine); - config.pFilePath = pFilePath; - config.flags = flags; - config.pInitialAttachment = pGroup; - config.pDoneFence = pDoneFence; - - return ma_sound_init_ex(pEngine, &config, pSound); -} - -MA_API ma_result ma_sound_init_from_file_w(ma_engine* pEngine, const wchar_t* pFilePath, ma_uint32 flags, ma_sound_group* pGroup, ma_fence* pDoneFence, ma_sound* pSound) -{ - ma_sound_config config; - - if (pFilePath == NULL) { - return MA_INVALID_ARGS; - } - - config = ma_sound_config_init_2(pEngine); - config.pFilePathW = pFilePath; - config.flags = flags; - config.pInitialAttachment = pGroup; - config.pDoneFence = pDoneFence; - - return ma_sound_init_ex(pEngine, &config, pSound); -} - -MA_API ma_result ma_sound_init_copy(ma_engine* pEngine, const ma_sound* pExistingSound, ma_uint32 flags, ma_sound_group* pGroup, ma_sound* pSound) -{ - ma_result result; - ma_sound_config config; - - result = ma_sound_preinit(pEngine, pSound); - if (result != MA_SUCCESS) { - return result; - } - - if (pExistingSound == NULL) { - return MA_INVALID_ARGS; - } - - /* Cloning only works for data buffers (not streams) that are loaded from the resource manager. */ - if (pExistingSound->pResourceManagerDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - /* - We need to make a clone of the data source. If the data source is not a data buffer (i.e. a stream) - the this will fail. - */ - pSound->pResourceManagerDataSource = (ma_resource_manager_data_source*)ma_malloc(sizeof(*pSound->pResourceManagerDataSource), &pEngine->allocationCallbacks); - if (pSound->pResourceManagerDataSource == NULL) { - return MA_OUT_OF_MEMORY; - } - - result = ma_resource_manager_data_source_init_copy(pEngine->pResourceManager, pExistingSound->pResourceManagerDataSource, pSound->pResourceManagerDataSource); - if (result != MA_SUCCESS) { - ma_free(pSound->pResourceManagerDataSource, &pEngine->allocationCallbacks); - return result; - } - - config = ma_sound_config_init_2(pEngine); - config.pDataSource = pSound->pResourceManagerDataSource; - config.flags = flags; - config.pInitialAttachment = pGroup; - config.monoExpansionMode = pExistingSound->engineNode.monoExpansionMode; - - result = ma_sound_init_from_data_source_internal(pEngine, &config, pSound); - if (result != MA_SUCCESS) { - ma_resource_manager_data_source_uninit(pSound->pResourceManagerDataSource); - ma_free(pSound->pResourceManagerDataSource, &pEngine->allocationCallbacks); - MA_ZERO_OBJECT(pSound); - return result; - } - - return MA_SUCCESS; -} -#endif - -MA_API ma_result ma_sound_init_from_data_source(ma_engine* pEngine, ma_data_source* pDataSource, ma_uint32 flags, ma_sound_group* pGroup, ma_sound* pSound) -{ - ma_sound_config config = ma_sound_config_init_2(pEngine); - config.pDataSource = pDataSource; - config.flags = flags; - config.pInitialAttachment = pGroup; - return ma_sound_init_ex(pEngine, &config, pSound); -} - -MA_API ma_result ma_sound_init_ex(ma_engine* pEngine, const ma_sound_config* pConfig, ma_sound* pSound) -{ - ma_result result; - - result = ma_sound_preinit(pEngine, pSound); - if (result != MA_SUCCESS) { - return result; - } - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - pSound->endCallback = pConfig->endCallback; - pSound->pEndCallbackUserData = pConfig->pEndCallbackUserData; - - /* We need to load the sound differently depending on whether or not we're loading from a file. */ -#ifndef MA_NO_RESOURCE_MANAGER - if (pConfig->pFilePath != NULL || pConfig->pFilePathW != NULL) { - return ma_sound_init_from_file_internal(pEngine, pConfig, pSound); - } else -#endif - { - /* - Getting here means we're not loading from a file. We may be loading from an already-initialized - data source, or none at all. If we aren't specifying any data source, we'll be initializing the - the equivalent to a group. ma_data_source_init_from_data_source_internal() will deal with this - for us, so no special treatment required here. - */ - return ma_sound_init_from_data_source_internal(pEngine, pConfig, pSound); - } -} - -MA_API void ma_sound_uninit(ma_sound* pSound) -{ - if (pSound == NULL) { - return; - } - - /* - Always uninitialize the node first. This ensures it's detached from the graph and does not return until it has done - so which makes thread safety beyond this point trivial. - */ - ma_engine_node_uninit(&pSound->engineNode, &pSound->engineNode.pEngine->allocationCallbacks); - - /* Once the sound is detached from the group we can guarantee that it won't be referenced by the mixer thread which means it's safe for us to destroy the data source. */ -#ifndef MA_NO_RESOURCE_MANAGER - if (pSound->ownsDataSource) { - ma_resource_manager_data_source_uninit(pSound->pResourceManagerDataSource); - ma_free(pSound->pResourceManagerDataSource, &pSound->engineNode.pEngine->allocationCallbacks); - pSound->pDataSource = NULL; - } -#else - MA_ASSERT(pSound->ownsDataSource == MA_FALSE); -#endif -} - -MA_API ma_engine* ma_sound_get_engine(const ma_sound* pSound) -{ - if (pSound == NULL) { - return NULL; - } - - return pSound->engineNode.pEngine; -} - -MA_API ma_data_source* ma_sound_get_data_source(const ma_sound* pSound) -{ - if (pSound == NULL) { - return NULL; - } - - return pSound->pDataSource; -} - -MA_API ma_result ma_sound_start(ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* If the sound is already playing, do nothing. */ - if (ma_sound_is_playing(pSound)) { - return MA_SUCCESS; - } - - /* If the sound is at the end it means we want to start from the start again. */ - if (ma_sound_at_end(pSound)) { - ma_result result = ma_data_source_seek_to_pcm_frame(pSound->pDataSource, 0); - if (result != MA_SUCCESS && result != MA_NOT_IMPLEMENTED) { - return result; /* Failed to seek back to the start. */ - } - - /* Make sure we clear the end indicator. */ - c89atomic_exchange_32(&pSound->atEnd, MA_FALSE); - } - - /* Make sure the sound is started. If there's a start delay, the sound won't actually start until the start time is reached. */ - ma_node_set_state(pSound, ma_node_state_started); - - return MA_SUCCESS; -} - -MA_API ma_result ma_sound_stop(ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* This will stop the sound immediately. Use ma_sound_set_stop_time() to stop the sound at a specific time. */ - ma_node_set_state(pSound, ma_node_state_stopped); - - return MA_SUCCESS; -} - -MA_API void ma_sound_set_volume(ma_sound* pSound, float volume) -{ - if (pSound == NULL) { - return; - } - - ma_engine_node_set_volume(&pSound->engineNode, volume); -} - -MA_API float ma_sound_get_volume(const ma_sound* pSound) -{ - float volume = 0; - - if (pSound == NULL) { - return 0; - } - - ma_engine_node_get_volume(&pSound->engineNode, &volume); - - return volume; -} - -MA_API void ma_sound_set_pan(ma_sound* pSound, float pan) -{ - if (pSound == NULL) { - return; - } - - ma_panner_set_pan(&pSound->engineNode.panner, pan); -} - -MA_API float ma_sound_get_pan(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_panner_get_pan(&pSound->engineNode.panner); -} - -MA_API void ma_sound_set_pan_mode(ma_sound* pSound, ma_pan_mode panMode) -{ - if (pSound == NULL) { - return; - } - - ma_panner_set_mode(&pSound->engineNode.panner, panMode); -} - -MA_API ma_pan_mode ma_sound_get_pan_mode(const ma_sound* pSound) -{ - if (pSound == NULL) { - return ma_pan_mode_balance; - } - - return ma_panner_get_mode(&pSound->engineNode.panner); -} - -MA_API void ma_sound_set_pitch(ma_sound* pSound, float pitch) -{ - if (pSound == NULL) { - return; - } - - if (pitch <= 0) { - return; - } - - c89atomic_exchange_explicit_f32(&pSound->engineNode.pitch, pitch, c89atomic_memory_order_release); -} - -MA_API float ma_sound_get_pitch(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return c89atomic_load_f32(&pSound->engineNode.pitch); /* Naughty const-cast for this. */ -} - -MA_API void ma_sound_set_spatialization_enabled(ma_sound* pSound, ma_bool32 enabled) -{ - if (pSound == NULL) { - return; - } - - c89atomic_exchange_explicit_32(&pSound->engineNode.isSpatializationDisabled, !enabled, c89atomic_memory_order_release); -} - -MA_API ma_bool32 ma_sound_is_spatialization_enabled(const ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_FALSE; - } - - return ma_engine_node_is_spatialization_enabled(&pSound->engineNode); -} - -MA_API void ma_sound_set_pinned_listener_index(ma_sound* pSound, ma_uint32 listenerIndex) -{ - if (pSound == NULL || listenerIndex >= ma_engine_get_listener_count(ma_sound_get_engine(pSound))) { - return; - } - - c89atomic_exchange_explicit_32(&pSound->engineNode.pinnedListenerIndex, listenerIndex, c89atomic_memory_order_release); -} - -MA_API ma_uint32 ma_sound_get_pinned_listener_index(const ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_LISTENER_INDEX_CLOSEST; - } - - return c89atomic_load_explicit_32(&pSound->engineNode.pinnedListenerIndex, c89atomic_memory_order_acquire); -} - -MA_API ma_uint32 ma_sound_get_listener_index(const ma_sound* pSound) -{ - ma_uint32 listenerIndex; - - if (pSound == NULL) { - return 0; - } - - listenerIndex = ma_sound_get_pinned_listener_index(pSound); - if (listenerIndex == MA_LISTENER_INDEX_CLOSEST) { - ma_vec3f position = ma_sound_get_position(pSound); - return ma_engine_find_closest_listener(ma_sound_get_engine(pSound), position.x, position.y, position.z); - } - - return listenerIndex; -} - -MA_API ma_vec3f ma_sound_get_direction_to_listener(const ma_sound* pSound) -{ - ma_vec3f relativePos; - ma_engine* pEngine; - - if (pSound == NULL) { - return ma_vec3f_init_3f(0, 0, -1); - } - - pEngine = ma_sound_get_engine(pSound); - if (pEngine == NULL) { - return ma_vec3f_init_3f(0, 0, -1); - } - - ma_spatializer_get_relative_position_and_direction(&pSound->engineNode.spatializer, &pEngine->listeners[ma_sound_get_listener_index(pSound)], &relativePos, NULL); - - return ma_vec3f_normalize(ma_vec3f_neg(relativePos)); -} - -MA_API void ma_sound_set_position(ma_sound* pSound, float x, float y, float z) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_position(&pSound->engineNode.spatializer, x, y, z); -} - -MA_API ma_vec3f ma_sound_get_position(const ma_sound* pSound) -{ - if (pSound == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_spatializer_get_position(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_direction(ma_sound* pSound, float x, float y, float z) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_direction(&pSound->engineNode.spatializer, x, y, z); -} - -MA_API ma_vec3f ma_sound_get_direction(const ma_sound* pSound) -{ - if (pSound == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_spatializer_get_direction(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_velocity(ma_sound* pSound, float x, float y, float z) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_velocity(&pSound->engineNode.spatializer, x, y, z); -} - -MA_API ma_vec3f ma_sound_get_velocity(const ma_sound* pSound) -{ - if (pSound == NULL) { - return ma_vec3f_init_3f(0, 0, 0); - } - - return ma_spatializer_get_velocity(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_attenuation_model(ma_sound* pSound, ma_attenuation_model attenuationModel) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_attenuation_model(&pSound->engineNode.spatializer, attenuationModel); -} - -MA_API ma_attenuation_model ma_sound_get_attenuation_model(const ma_sound* pSound) -{ - if (pSound == NULL) { - return ma_attenuation_model_none; - } - - return ma_spatializer_get_attenuation_model(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_positioning(ma_sound* pSound, ma_positioning positioning) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_positioning(&pSound->engineNode.spatializer, positioning); -} - -MA_API ma_positioning ma_sound_get_positioning(const ma_sound* pSound) -{ - if (pSound == NULL) { - return ma_positioning_absolute; - } - - return ma_spatializer_get_positioning(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_rolloff(ma_sound* pSound, float rolloff) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_rolloff(&pSound->engineNode.spatializer, rolloff); -} - -MA_API float ma_sound_get_rolloff(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_spatializer_get_rolloff(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_min_gain(ma_sound* pSound, float minGain) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_min_gain(&pSound->engineNode.spatializer, minGain); -} - -MA_API float ma_sound_get_min_gain(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_spatializer_get_min_gain(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_max_gain(ma_sound* pSound, float maxGain) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_max_gain(&pSound->engineNode.spatializer, maxGain); -} - -MA_API float ma_sound_get_max_gain(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_spatializer_get_max_gain(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_min_distance(ma_sound* pSound, float minDistance) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_min_distance(&pSound->engineNode.spatializer, minDistance); -} - -MA_API float ma_sound_get_min_distance(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_spatializer_get_min_distance(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_max_distance(ma_sound* pSound, float maxDistance) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_max_distance(&pSound->engineNode.spatializer, maxDistance); -} - -MA_API float ma_sound_get_max_distance(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_spatializer_get_max_distance(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_cone(ma_sound* pSound, float innerAngleInRadians, float outerAngleInRadians, float outerGain) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_cone(&pSound->engineNode.spatializer, innerAngleInRadians, outerAngleInRadians, outerGain); -} - -MA_API void ma_sound_get_cone(const ma_sound* pSound, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain) -{ - if (pInnerAngleInRadians != NULL) { - *pInnerAngleInRadians = 0; - } - - if (pOuterAngleInRadians != NULL) { - *pOuterAngleInRadians = 0; - } - - if (pOuterGain != NULL) { - *pOuterGain = 0; - } - - ma_spatializer_get_cone(&pSound->engineNode.spatializer, pInnerAngleInRadians, pOuterAngleInRadians, pOuterGain); -} - -MA_API void ma_sound_set_doppler_factor(ma_sound* pSound, float dopplerFactor) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_doppler_factor(&pSound->engineNode.spatializer, dopplerFactor); -} - -MA_API float ma_sound_get_doppler_factor(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_spatializer_get_doppler_factor(&pSound->engineNode.spatializer); -} - -MA_API void ma_sound_set_directional_attenuation_factor(ma_sound* pSound, float directionalAttenuationFactor) -{ - if (pSound == NULL) { - return; - } - - ma_spatializer_set_directional_attenuation_factor(&pSound->engineNode.spatializer, directionalAttenuationFactor); -} - -MA_API float ma_sound_get_directional_attenuation_factor(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 1; - } - - return ma_spatializer_get_directional_attenuation_factor(&pSound->engineNode.spatializer); -} - - -MA_API void ma_sound_set_fade_in_pcm_frames(ma_sound* pSound, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInFrames) -{ - if (pSound == NULL) { - return; - } - - ma_fader_set_fade(&pSound->engineNode.fader, volumeBeg, volumeEnd, fadeLengthInFrames); -} - -MA_API void ma_sound_set_fade_in_milliseconds(ma_sound* pSound, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInMilliseconds) -{ - if (pSound == NULL) { - return; - } - - ma_sound_set_fade_in_pcm_frames(pSound, volumeBeg, volumeEnd, (fadeLengthInMilliseconds * pSound->engineNode.fader.config.sampleRate) / 1000); -} - -MA_API float ma_sound_get_current_fade_volume(const ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - return ma_fader_get_current_volume(&pSound->engineNode.fader); -} - -MA_API void ma_sound_set_start_time_in_pcm_frames(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInFrames) -{ - if (pSound == NULL) { - return; - } - - ma_node_set_state_time(pSound, ma_node_state_started, absoluteGlobalTimeInFrames); -} - -MA_API void ma_sound_set_start_time_in_milliseconds(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInMilliseconds) -{ - if (pSound == NULL) { - return; - } - - ma_sound_set_start_time_in_pcm_frames(pSound, absoluteGlobalTimeInMilliseconds * ma_engine_get_sample_rate(ma_sound_get_engine(pSound)) / 1000); -} - -MA_API void ma_sound_set_stop_time_in_pcm_frames(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInFrames) -{ - if (pSound == NULL) { - return; - } - - ma_node_set_state_time(pSound, ma_node_state_stopped, absoluteGlobalTimeInFrames); -} - -MA_API void ma_sound_set_stop_time_in_milliseconds(ma_sound* pSound, ma_uint64 absoluteGlobalTimeInMilliseconds) -{ - if (pSound == NULL) { - return; - } - - ma_sound_set_stop_time_in_pcm_frames(pSound, absoluteGlobalTimeInMilliseconds * ma_engine_get_sample_rate(ma_sound_get_engine(pSound)) / 1000); -} - -MA_API ma_bool32 ma_sound_is_playing(const ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_FALSE; - } - - return ma_node_get_state_by_time(pSound, ma_engine_get_time(ma_sound_get_engine(pSound))) == ma_node_state_started; -} - -MA_API ma_uint64 ma_sound_get_time_in_pcm_frames(const ma_sound* pSound) -{ - if (pSound == NULL) { - return 0; - } - - return ma_node_get_time(pSound); -} - -MA_API void ma_sound_set_looping(ma_sound* pSound, ma_bool32 isLooping) -{ - if (pSound == NULL) { - return; - } - - /* Looping is only a valid concept if the sound is backed by a data source. */ - if (pSound->pDataSource == NULL) { - return; - } - - /* The looping state needs to be applied to the data source in order for any looping to actually happen. */ - ma_data_source_set_looping(pSound->pDataSource, isLooping); -} - -MA_API ma_bool32 ma_sound_is_looping(const ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_FALSE; - } - - /* There is no notion of looping for sounds that are not backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_FALSE; - } - - return ma_data_source_is_looping(pSound->pDataSource); -} - -MA_API ma_bool32 ma_sound_at_end(const ma_sound* pSound) -{ - if (pSound == NULL) { - return MA_FALSE; - } - - /* There is no notion of an end of a sound if it's not backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_FALSE; - } - - return ma_sound_get_at_end(pSound); -} - -MA_API ma_result ma_sound_seek_to_pcm_frame(ma_sound* pSound, ma_uint64 frameIndex) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* Seeking is only valid for sounds that are backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - /* We can't be seeking while reading at the same time. We just set the seek target and get the mixing thread to do the actual seek. */ - c89atomic_exchange_64(&pSound->seekTarget, frameIndex); - - return MA_SUCCESS; -} - -MA_API ma_result ma_sound_get_data_format(ma_sound* pSound, ma_format* pFormat, ma_uint32* pChannels, ma_uint32* pSampleRate, ma_channel* pChannelMap, size_t channelMapCap) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* The data format is retrieved directly from the data source if the sound is backed by one. Otherwise we pull it from the node. */ - if (pSound->pDataSource == NULL) { - ma_uint32 channels; - - if (pFormat != NULL) { - *pFormat = ma_format_f32; - } - - channels = ma_node_get_input_channels(&pSound->engineNode, 0); - if (pChannels != NULL) { - *pChannels = channels; - } - - if (pSampleRate != NULL) { - *pSampleRate = pSound->engineNode.resampler.config.sampleRateIn; - } - - if (pChannelMap != NULL) { - ma_channel_map_init_standard(ma_standard_channel_map_default, pChannelMap, channelMapCap, channels); - } - - return MA_SUCCESS; - } else { - return ma_data_source_get_data_format(pSound->pDataSource, pFormat, pChannels, pSampleRate, pChannelMap, channelMapCap); - } -} - -MA_API ma_result ma_sound_get_cursor_in_pcm_frames(ma_sound* pSound, ma_uint64* pCursor) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* The notion of a cursor is only valid for sounds that are backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - return ma_data_source_get_cursor_in_pcm_frames(pSound->pDataSource, pCursor); -} - -MA_API ma_result ma_sound_get_length_in_pcm_frames(ma_sound* pSound, ma_uint64* pLength) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* The notion of a sound length is only valid for sounds that are backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - return ma_data_source_get_length_in_pcm_frames(pSound->pDataSource, pLength); -} - -MA_API ma_result ma_sound_get_cursor_in_seconds(ma_sound* pSound, float* pCursor) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* The notion of a cursor is only valid for sounds that are backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - return ma_data_source_get_cursor_in_seconds(pSound->pDataSource, pCursor); -} - -MA_API ma_result ma_sound_get_length_in_seconds(ma_sound* pSound, float* pLength) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* The notion of a sound length is only valid for sounds that are backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - return ma_data_source_get_length_in_seconds(pSound->pDataSource, pLength); -} - -MA_API ma_result ma_sound_set_end_callback(ma_sound* pSound, ma_sound_end_proc callback, void* pUserData) -{ - if (pSound == NULL) { - return MA_INVALID_ARGS; - } - - /* The notion of an end is only valid for sounds that are backed by a data source. */ - if (pSound->pDataSource == NULL) { - return MA_INVALID_OPERATION; - } - - pSound->endCallback = callback; - pSound->pEndCallbackUserData = pUserData; - - return MA_SUCCESS; -} - - -MA_API ma_result ma_sound_group_init(ma_engine* pEngine, ma_uint32 flags, ma_sound_group* pParentGroup, ma_sound_group* pGroup) -{ - ma_sound_group_config config = ma_sound_group_config_init_2(pEngine); - config.flags = flags; - config.pInitialAttachment = pParentGroup; - return ma_sound_group_init_ex(pEngine, &config, pGroup); -} - -MA_API ma_result ma_sound_group_init_ex(ma_engine* pEngine, const ma_sound_group_config* pConfig, ma_sound_group* pGroup) -{ - ma_sound_config soundConfig; - - if (pGroup == NULL) { - return MA_INVALID_ARGS; - } - - MA_ZERO_OBJECT(pGroup); - - if (pConfig == NULL) { - return MA_INVALID_ARGS; - } - - /* A sound group is just a sound without a data source. */ - soundConfig = *pConfig; - soundConfig.pFilePath = NULL; - soundConfig.pFilePathW = NULL; - soundConfig.pDataSource = NULL; - - /* - Groups need to have spatialization disabled by default because I think it'll be pretty rare - that programs will want to spatialize groups (but not unheard of). Certainly it feels like - disabling this by default feels like the right option. Spatialization can be enabled with a - call to ma_sound_group_set_spatialization_enabled(). - */ - soundConfig.flags |= MA_SOUND_FLAG_NO_SPATIALIZATION; - - return ma_sound_init_ex(pEngine, &soundConfig, pGroup); -} - -MA_API void ma_sound_group_uninit(ma_sound_group* pGroup) -{ - ma_sound_uninit(pGroup); -} - -MA_API ma_engine* ma_sound_group_get_engine(const ma_sound_group* pGroup) -{ - return ma_sound_get_engine(pGroup); -} - -MA_API ma_result ma_sound_group_start(ma_sound_group* pGroup) -{ - return ma_sound_start(pGroup); -} - -MA_API ma_result ma_sound_group_stop(ma_sound_group* pGroup) -{ - return ma_sound_stop(pGroup); -} - -MA_API void ma_sound_group_set_volume(ma_sound_group* pGroup, float volume) -{ - ma_sound_set_volume(pGroup, volume); -} - -MA_API float ma_sound_group_get_volume(const ma_sound_group* pGroup) -{ - return ma_sound_get_volume(pGroup); -} - -MA_API void ma_sound_group_set_pan(ma_sound_group* pGroup, float pan) -{ - ma_sound_set_pan(pGroup, pan); -} - -MA_API float ma_sound_group_get_pan(const ma_sound_group* pGroup) -{ - return ma_sound_get_pan(pGroup); -} - -MA_API void ma_sound_group_set_pan_mode(ma_sound_group* pGroup, ma_pan_mode panMode) -{ - ma_sound_set_pan_mode(pGroup, panMode); -} - -MA_API ma_pan_mode ma_sound_group_get_pan_mode(const ma_sound_group* pGroup) -{ - return ma_sound_get_pan_mode(pGroup); -} - -MA_API void ma_sound_group_set_pitch(ma_sound_group* pGroup, float pitch) -{ - ma_sound_set_pitch(pGroup, pitch); -} - -MA_API float ma_sound_group_get_pitch(const ma_sound_group* pGroup) -{ - return ma_sound_get_pitch(pGroup); -} - -MA_API void ma_sound_group_set_spatialization_enabled(ma_sound_group* pGroup, ma_bool32 enabled) -{ - ma_sound_set_spatialization_enabled(pGroup, enabled); -} - -MA_API ma_bool32 ma_sound_group_is_spatialization_enabled(const ma_sound_group* pGroup) -{ - return ma_sound_is_spatialization_enabled(pGroup); -} - -MA_API void ma_sound_group_set_pinned_listener_index(ma_sound_group* pGroup, ma_uint32 listenerIndex) -{ - ma_sound_set_pinned_listener_index(pGroup, listenerIndex); -} - -MA_API ma_uint32 ma_sound_group_get_pinned_listener_index(const ma_sound_group* pGroup) -{ - return ma_sound_get_pinned_listener_index(pGroup); -} - -MA_API ma_uint32 ma_sound_group_get_listener_index(const ma_sound_group* pGroup) -{ - return ma_sound_get_listener_index(pGroup); -} - -MA_API ma_vec3f ma_sound_group_get_direction_to_listener(const ma_sound_group* pGroup) -{ - return ma_sound_get_direction_to_listener(pGroup); -} - -MA_API void ma_sound_group_set_position(ma_sound_group* pGroup, float x, float y, float z) -{ - ma_sound_set_position(pGroup, x, y, z); -} - -MA_API ma_vec3f ma_sound_group_get_position(const ma_sound_group* pGroup) -{ - return ma_sound_get_position(pGroup); -} - -MA_API void ma_sound_group_set_direction(ma_sound_group* pGroup, float x, float y, float z) -{ - ma_sound_set_direction(pGroup, x, y, z); -} - -MA_API ma_vec3f ma_sound_group_get_direction(const ma_sound_group* pGroup) -{ - return ma_sound_get_direction(pGroup); -} - -MA_API void ma_sound_group_set_velocity(ma_sound_group* pGroup, float x, float y, float z) -{ - ma_sound_set_velocity(pGroup, x, y, z); -} - -MA_API ma_vec3f ma_sound_group_get_velocity(const ma_sound_group* pGroup) -{ - return ma_sound_get_velocity(pGroup); -} - -MA_API void ma_sound_group_set_attenuation_model(ma_sound_group* pGroup, ma_attenuation_model attenuationModel) -{ - ma_sound_set_attenuation_model(pGroup, attenuationModel); -} - -MA_API ma_attenuation_model ma_sound_group_get_attenuation_model(const ma_sound_group* pGroup) -{ - return ma_sound_get_attenuation_model(pGroup); -} - -MA_API void ma_sound_group_set_positioning(ma_sound_group* pGroup, ma_positioning positioning) -{ - ma_sound_set_positioning(pGroup, positioning); -} - -MA_API ma_positioning ma_sound_group_get_positioning(const ma_sound_group* pGroup) -{ - return ma_sound_get_positioning(pGroup); -} - -MA_API void ma_sound_group_set_rolloff(ma_sound_group* pGroup, float rolloff) -{ - ma_sound_set_rolloff(pGroup, rolloff); -} - -MA_API float ma_sound_group_get_rolloff(const ma_sound_group* pGroup) -{ - return ma_sound_get_rolloff(pGroup); -} - -MA_API void ma_sound_group_set_min_gain(ma_sound_group* pGroup, float minGain) -{ - ma_sound_set_min_gain(pGroup, minGain); -} - -MA_API float ma_sound_group_get_min_gain(const ma_sound_group* pGroup) -{ - return ma_sound_get_min_gain(pGroup); -} - -MA_API void ma_sound_group_set_max_gain(ma_sound_group* pGroup, float maxGain) -{ - ma_sound_set_max_gain(pGroup, maxGain); -} - -MA_API float ma_sound_group_get_max_gain(const ma_sound_group* pGroup) -{ - return ma_sound_get_max_gain(pGroup); -} - -MA_API void ma_sound_group_set_min_distance(ma_sound_group* pGroup, float minDistance) -{ - ma_sound_set_min_distance(pGroup, minDistance); -} - -MA_API float ma_sound_group_get_min_distance(const ma_sound_group* pGroup) -{ - return ma_sound_get_min_distance(pGroup); -} - -MA_API void ma_sound_group_set_max_distance(ma_sound_group* pGroup, float maxDistance) -{ - ma_sound_set_max_distance(pGroup, maxDistance); -} - -MA_API float ma_sound_group_get_max_distance(const ma_sound_group* pGroup) -{ - return ma_sound_get_max_distance(pGroup); -} - -MA_API void ma_sound_group_set_cone(ma_sound_group* pGroup, float innerAngleInRadians, float outerAngleInRadians, float outerGain) -{ - ma_sound_set_cone(pGroup, innerAngleInRadians, outerAngleInRadians, outerGain); -} - -MA_API void ma_sound_group_get_cone(const ma_sound_group* pGroup, float* pInnerAngleInRadians, float* pOuterAngleInRadians, float* pOuterGain) -{ - ma_sound_get_cone(pGroup, pInnerAngleInRadians, pOuterAngleInRadians, pOuterGain); -} - -MA_API void ma_sound_group_set_doppler_factor(ma_sound_group* pGroup, float dopplerFactor) -{ - ma_sound_set_doppler_factor(pGroup, dopplerFactor); -} - -MA_API float ma_sound_group_get_doppler_factor(const ma_sound_group* pGroup) -{ - return ma_sound_get_doppler_factor(pGroup); -} - -MA_API void ma_sound_group_set_directional_attenuation_factor(ma_sound_group* pGroup, float directionalAttenuationFactor) -{ - ma_sound_set_directional_attenuation_factor(pGroup, directionalAttenuationFactor); -} - -MA_API float ma_sound_group_get_directional_attenuation_factor(const ma_sound_group* pGroup) -{ - return ma_sound_get_directional_attenuation_factor(pGroup); -} - -MA_API void ma_sound_group_set_fade_in_pcm_frames(ma_sound_group* pGroup, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInFrames) -{ - ma_sound_set_fade_in_pcm_frames(pGroup, volumeBeg, volumeEnd, fadeLengthInFrames); -} - -MA_API void ma_sound_group_set_fade_in_milliseconds(ma_sound_group* pGroup, float volumeBeg, float volumeEnd, ma_uint64 fadeLengthInMilliseconds) -{ - ma_sound_set_fade_in_milliseconds(pGroup, volumeBeg, volumeEnd, fadeLengthInMilliseconds); -} - -MA_API float ma_sound_group_get_current_fade_volume(ma_sound_group* pGroup) -{ - return ma_sound_get_current_fade_volume(pGroup); -} - -MA_API void ma_sound_group_set_start_time_in_pcm_frames(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInFrames) -{ - ma_sound_set_start_time_in_pcm_frames(pGroup, absoluteGlobalTimeInFrames); -} - -MA_API void ma_sound_group_set_start_time_in_milliseconds(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInMilliseconds) -{ - ma_sound_set_start_time_in_milliseconds(pGroup, absoluteGlobalTimeInMilliseconds); -} - -MA_API void ma_sound_group_set_stop_time_in_pcm_frames(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInFrames) -{ - ma_sound_set_stop_time_in_pcm_frames(pGroup, absoluteGlobalTimeInFrames); -} - -MA_API void ma_sound_group_set_stop_time_in_milliseconds(ma_sound_group* pGroup, ma_uint64 absoluteGlobalTimeInMilliseconds) -{ - ma_sound_set_stop_time_in_milliseconds(pGroup, absoluteGlobalTimeInMilliseconds); -} - -MA_API ma_bool32 ma_sound_group_is_playing(const ma_sound_group* pGroup) -{ - return ma_sound_is_playing(pGroup); -} - -MA_API ma_uint64 ma_sound_group_get_time_in_pcm_frames(const ma_sound_group* pGroup) -{ - return ma_sound_get_time_in_pcm_frames(pGroup); -} -#endif /* MA_NO_ENGINE */ -/* END SECTION: miniaudio_engine.c */ - - - -/************************************************************************************************************************************************************** -*************************************************************************************************************************************************************** - -Auto Generated -============== -All code below is auto-generated from a tool. This mostly consists of decoding backend implementations such as dr_wav, dr_flac, etc. If you find a bug in the -code below please report the bug to the respective repository for the relevant project (probably dr_libs). - -*************************************************************************************************************************************************************** -**************************************************************************************************************************************************************/ -#if !defined(MA_NO_WAV) && (!defined(MA_NO_DECODING) || !defined(MA_NO_ENCODING)) -#if !defined(DR_WAV_IMPLEMENTATION) && !defined(DRWAV_IMPLEMENTATION) /* For backwards compatibility. Will be removed in version 0.11 for cleanliness. */ -/* dr_wav_c begin */ -#ifndef dr_wav_c -#define dr_wav_c -#ifdef __MRC__ -#pragma options opt off -#endif -#include -#include -#include -#ifndef DR_WAV_NO_STDIO -#include -#ifndef DR_WAV_NO_WCHAR -#include -#endif -#endif -#ifndef DRWAV_ASSERT -#include -#define DRWAV_ASSERT(expression) assert(expression) -#endif -#ifndef DRWAV_MALLOC -#define DRWAV_MALLOC(sz) malloc((sz)) -#endif -#ifndef DRWAV_REALLOC -#define DRWAV_REALLOC(p, sz) realloc((p), (sz)) -#endif -#ifndef DRWAV_FREE -#define DRWAV_FREE(p) free((p)) -#endif -#ifndef DRWAV_COPY_MEMORY -#define DRWAV_COPY_MEMORY(dst, src, sz) memcpy((dst), (src), (sz)) -#endif -#ifndef DRWAV_ZERO_MEMORY -#define DRWAV_ZERO_MEMORY(p, sz) memset((p), 0, (sz)) -#endif -#ifndef DRWAV_ZERO_OBJECT -#define DRWAV_ZERO_OBJECT(p) DRWAV_ZERO_MEMORY((p), sizeof(*p)) -#endif -#define drwav_countof(x) (sizeof(x) / sizeof(x[0])) -#define drwav_align(x, a) ((((x) + (a) - 1) / (a)) * (a)) -#define drwav_min(a, b) (((a) < (b)) ? (a) : (b)) -#define drwav_max(a, b) (((a) > (b)) ? (a) : (b)) -#define drwav_clamp(x, lo, hi) (drwav_max((lo), drwav_min((hi), (x)))) -#define drwav_offset_ptr(p, offset) (((drwav_uint8*)(p)) + (offset)) -#define DRWAV_MAX_SIMD_VECTOR_SIZE 64 -#if defined(__x86_64__) || defined(_M_X64) - #define DRWAV_X64 -#elif defined(__i386) || defined(_M_IX86) - #define DRWAV_X86 -#elif defined(__arm__) || defined(_M_ARM) - #define DRWAV_ARM -#endif -#ifdef _MSC_VER - #define DRWAV_INLINE __forceinline -#elif defined(__GNUC__) - #if defined(__STRICT_ANSI__) - #define DRWAV_GNUC_INLINE_HINT __inline__ - #else - #define DRWAV_GNUC_INLINE_HINT inline - #endif - #if (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 2)) || defined(__clang__) - #define DRWAV_INLINE DRWAV_GNUC_INLINE_HINT __attribute__((always_inline)) - #else - #define DRWAV_INLINE DRWAV_GNUC_INLINE_HINT - #endif -#elif defined(__WATCOMC__) - #define DRWAV_INLINE __inline -#else - #define DRWAV_INLINE -#endif -#if defined(SIZE_MAX) - #define DRWAV_SIZE_MAX SIZE_MAX -#else - #if defined(_WIN64) || defined(_LP64) || defined(__LP64__) - #define DRWAV_SIZE_MAX ((drwav_uint64)0xFFFFFFFFFFFFFFFF) - #else - #define DRWAV_SIZE_MAX 0xFFFFFFFF - #endif -#endif -#if defined(_MSC_VER) && _MSC_VER >= 1400 - #define DRWAV_HAS_BYTESWAP16_INTRINSIC - #define DRWAV_HAS_BYTESWAP32_INTRINSIC - #define DRWAV_HAS_BYTESWAP64_INTRINSIC -#elif defined(__clang__) - #if defined(__has_builtin) - #if __has_builtin(__builtin_bswap16) - #define DRWAV_HAS_BYTESWAP16_INTRINSIC - #endif - #if __has_builtin(__builtin_bswap32) - #define DRWAV_HAS_BYTESWAP32_INTRINSIC - #endif - #if __has_builtin(__builtin_bswap64) - #define DRWAV_HAS_BYTESWAP64_INTRINSIC - #endif - #endif -#elif defined(__GNUC__) - #if ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)) - #define DRWAV_HAS_BYTESWAP32_INTRINSIC - #define DRWAV_HAS_BYTESWAP64_INTRINSIC - #endif - #if ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8)) - #define DRWAV_HAS_BYTESWAP16_INTRINSIC - #endif -#endif -DRWAV_API void drwav_version(drwav_uint32* pMajor, drwav_uint32* pMinor, drwav_uint32* pRevision) -{ - if (pMajor) { - *pMajor = DRWAV_VERSION_MAJOR; - } - if (pMinor) { - *pMinor = DRWAV_VERSION_MINOR; - } - if (pRevision) { - *pRevision = DRWAV_VERSION_REVISION; - } -} -DRWAV_API const char* drwav_version_string(void) -{ - return DRWAV_VERSION_STRING; -} -#ifndef DRWAV_MAX_SAMPLE_RATE -#define DRWAV_MAX_SAMPLE_RATE 384000 -#endif -#ifndef DRWAV_MAX_CHANNELS -#define DRWAV_MAX_CHANNELS 256 -#endif -#ifndef DRWAV_MAX_BITS_PER_SAMPLE -#define DRWAV_MAX_BITS_PER_SAMPLE 64 -#endif -static const drwav_uint8 drwavGUID_W64_RIFF[16] = {0x72,0x69,0x66,0x66, 0x2E,0x91, 0xCF,0x11, 0xA5,0xD6, 0x28,0xDB,0x04,0xC1,0x00,0x00}; -static const drwav_uint8 drwavGUID_W64_WAVE[16] = {0x77,0x61,0x76,0x65, 0xF3,0xAC, 0xD3,0x11, 0x8C,0xD1, 0x00,0xC0,0x4F,0x8E,0xDB,0x8A}; -static const drwav_uint8 drwavGUID_W64_FMT [16] = {0x66,0x6D,0x74,0x20, 0xF3,0xAC, 0xD3,0x11, 0x8C,0xD1, 0x00,0xC0,0x4F,0x8E,0xDB,0x8A}; -static const drwav_uint8 drwavGUID_W64_FACT[16] = {0x66,0x61,0x63,0x74, 0xF3,0xAC, 0xD3,0x11, 0x8C,0xD1, 0x00,0xC0,0x4F,0x8E,0xDB,0x8A}; -static const drwav_uint8 drwavGUID_W64_DATA[16] = {0x64,0x61,0x74,0x61, 0xF3,0xAC, 0xD3,0x11, 0x8C,0xD1, 0x00,0xC0,0x4F,0x8E,0xDB,0x8A}; -static DRWAV_INLINE int drwav__is_little_endian(void) -{ -#if defined(DRWAV_X86) || defined(DRWAV_X64) - return DRWAV_TRUE; -#elif defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN - return DRWAV_TRUE; -#else - int n = 1; - return (*(char*)&n) == 1; -#endif -} -static DRWAV_INLINE void drwav_bytes_to_guid(const drwav_uint8* data, drwav_uint8* guid) -{ - int i; - for (i = 0; i < 16; ++i) { - guid[i] = data[i]; - } -} -static DRWAV_INLINE drwav_uint16 drwav__bswap16(drwav_uint16 n) -{ -#ifdef DRWAV_HAS_BYTESWAP16_INTRINSIC - #if defined(_MSC_VER) - return _byteswap_ushort(n); - #elif defined(__GNUC__) || defined(__clang__) - return __builtin_bswap16(n); - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & 0xFF00) >> 8) | - ((n & 0x00FF) << 8); -#endif -} -static DRWAV_INLINE drwav_uint32 drwav__bswap32(drwav_uint32 n) -{ -#ifdef DRWAV_HAS_BYTESWAP32_INTRINSIC - #if defined(_MSC_VER) - return _byteswap_ulong(n); - #elif defined(__GNUC__) || defined(__clang__) - #if defined(DRWAV_ARM) && (defined(__ARM_ARCH) && __ARM_ARCH >= 6) && !defined(DRWAV_64BIT) - drwav_uint32 r; - __asm__ __volatile__ ( - #if defined(DRWAV_64BIT) - "rev %w[out], %w[in]" : [out]"=r"(r) : [in]"r"(n) - #else - "rev %[out], %[in]" : [out]"=r"(r) : [in]"r"(n) - #endif - ); - return r; - #else - return __builtin_bswap32(n); - #endif - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & 0xFF000000) >> 24) | - ((n & 0x00FF0000) >> 8) | - ((n & 0x0000FF00) << 8) | - ((n & 0x000000FF) << 24); -#endif -} -static DRWAV_INLINE drwav_uint64 drwav__bswap64(drwav_uint64 n) -{ -#ifdef DRWAV_HAS_BYTESWAP64_INTRINSIC - #if defined(_MSC_VER) - return _byteswap_uint64(n); - #elif defined(__GNUC__) || defined(__clang__) - return __builtin_bswap64(n); - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & ((drwav_uint64)0xFF000000 << 32)) >> 56) | - ((n & ((drwav_uint64)0x00FF0000 << 32)) >> 40) | - ((n & ((drwav_uint64)0x0000FF00 << 32)) >> 24) | - ((n & ((drwav_uint64)0x000000FF << 32)) >> 8) | - ((n & ((drwav_uint64)0xFF000000 )) << 8) | - ((n & ((drwav_uint64)0x00FF0000 )) << 24) | - ((n & ((drwav_uint64)0x0000FF00 )) << 40) | - ((n & ((drwav_uint64)0x000000FF )) << 56); -#endif -} -static DRWAV_INLINE drwav_int16 drwav__bswap_s16(drwav_int16 n) -{ - return (drwav_int16)drwav__bswap16((drwav_uint16)n); -} -static DRWAV_INLINE void drwav__bswap_samples_s16(drwav_int16* pSamples, drwav_uint64 sampleCount) -{ - drwav_uint64 iSample; - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamples[iSample] = drwav__bswap_s16(pSamples[iSample]); - } -} -static DRWAV_INLINE void drwav__bswap_s24(drwav_uint8* p) -{ - drwav_uint8 t; - t = p[0]; - p[0] = p[2]; - p[2] = t; -} -static DRWAV_INLINE void drwav__bswap_samples_s24(drwav_uint8* pSamples, drwav_uint64 sampleCount) -{ - drwav_uint64 iSample; - for (iSample = 0; iSample < sampleCount; iSample += 1) { - drwav_uint8* pSample = pSamples + (iSample*3); - drwav__bswap_s24(pSample); - } -} -static DRWAV_INLINE drwav_int32 drwav__bswap_s32(drwav_int32 n) -{ - return (drwav_int32)drwav__bswap32((drwav_uint32)n); -} -static DRWAV_INLINE void drwav__bswap_samples_s32(drwav_int32* pSamples, drwav_uint64 sampleCount) -{ - drwav_uint64 iSample; - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamples[iSample] = drwav__bswap_s32(pSamples[iSample]); - } -} -static DRWAV_INLINE float drwav__bswap_f32(float n) -{ - union { - drwav_uint32 i; - float f; - } x; - x.f = n; - x.i = drwav__bswap32(x.i); - return x.f; -} -static DRWAV_INLINE void drwav__bswap_samples_f32(float* pSamples, drwav_uint64 sampleCount) -{ - drwav_uint64 iSample; - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamples[iSample] = drwav__bswap_f32(pSamples[iSample]); - } -} -static DRWAV_INLINE double drwav__bswap_f64(double n) -{ - union { - drwav_uint64 i; - double f; - } x; - x.f = n; - x.i = drwav__bswap64(x.i); - return x.f; -} -static DRWAV_INLINE void drwav__bswap_samples_f64(double* pSamples, drwav_uint64 sampleCount) -{ - drwav_uint64 iSample; - for (iSample = 0; iSample < sampleCount; iSample += 1) { - pSamples[iSample] = drwav__bswap_f64(pSamples[iSample]); - } -} -static DRWAV_INLINE void drwav__bswap_samples_pcm(void* pSamples, drwav_uint64 sampleCount, drwav_uint32 bytesPerSample) -{ - switch (bytesPerSample) - { - case 1: - { - } break; - case 2: - { - drwav__bswap_samples_s16((drwav_int16*)pSamples, sampleCount); - } break; - case 3: - { - drwav__bswap_samples_s24((drwav_uint8*)pSamples, sampleCount); - } break; - case 4: - { - drwav__bswap_samples_s32((drwav_int32*)pSamples, sampleCount); - } break; - default: - { - DRWAV_ASSERT(DRWAV_FALSE); - } break; - } -} -static DRWAV_INLINE void drwav__bswap_samples_ieee(void* pSamples, drwav_uint64 sampleCount, drwav_uint32 bytesPerSample) -{ - switch (bytesPerSample) - { - #if 0 - case 2: - { - drwav__bswap_samples_f16((drwav_float16*)pSamples, sampleCount); - } break; - #endif - case 4: - { - drwav__bswap_samples_f32((float*)pSamples, sampleCount); - } break; - case 8: - { - drwav__bswap_samples_f64((double*)pSamples, sampleCount); - } break; - default: - { - DRWAV_ASSERT(DRWAV_FALSE); - } break; - } -} -static DRWAV_INLINE void drwav__bswap_samples(void* pSamples, drwav_uint64 sampleCount, drwav_uint32 bytesPerSample, drwav_uint16 format) -{ - switch (format) - { - case DR_WAVE_FORMAT_PCM: - { - drwav__bswap_samples_pcm(pSamples, sampleCount, bytesPerSample); - } break; - case DR_WAVE_FORMAT_IEEE_FLOAT: - { - drwav__bswap_samples_ieee(pSamples, sampleCount, bytesPerSample); - } break; - case DR_WAVE_FORMAT_ALAW: - case DR_WAVE_FORMAT_MULAW: - { - drwav__bswap_samples_s16((drwav_int16*)pSamples, sampleCount); - } break; - case DR_WAVE_FORMAT_ADPCM: - case DR_WAVE_FORMAT_DVI_ADPCM: - default: - { - DRWAV_ASSERT(DRWAV_FALSE); - } break; - } -} -DRWAV_PRIVATE void* drwav__malloc_default(size_t sz, void* pUserData) -{ - (void)pUserData; - return DRWAV_MALLOC(sz); -} -DRWAV_PRIVATE void* drwav__realloc_default(void* p, size_t sz, void* pUserData) -{ - (void)pUserData; - return DRWAV_REALLOC(p, sz); -} -DRWAV_PRIVATE void drwav__free_default(void* p, void* pUserData) -{ - (void)pUserData; - DRWAV_FREE(p); -} -DRWAV_PRIVATE void* drwav__malloc_from_callbacks(size_t sz, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks == NULL) { - return NULL; - } - if (pAllocationCallbacks->onMalloc != NULL) { - return pAllocationCallbacks->onMalloc(sz, pAllocationCallbacks->pUserData); - } - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(NULL, sz, pAllocationCallbacks->pUserData); - } - return NULL; -} -DRWAV_PRIVATE void* drwav__realloc_from_callbacks(void* p, size_t szNew, size_t szOld, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks == NULL) { - return NULL; - } - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(p, szNew, pAllocationCallbacks->pUserData); - } - if (pAllocationCallbacks->onMalloc != NULL && pAllocationCallbacks->onFree != NULL) { - void* p2; - p2 = pAllocationCallbacks->onMalloc(szNew, pAllocationCallbacks->pUserData); - if (p2 == NULL) { - return NULL; - } - if (p != NULL) { - DRWAV_COPY_MEMORY(p2, p, szOld); - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } - return p2; - } - return NULL; -} -DRWAV_PRIVATE void drwav__free_from_callbacks(void* p, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (p == NULL || pAllocationCallbacks == NULL) { - return; - } - if (pAllocationCallbacks->onFree != NULL) { - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } -} -DRWAV_PRIVATE drwav_allocation_callbacks drwav_copy_allocation_callbacks_or_defaults(const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - return *pAllocationCallbacks; - } else { - drwav_allocation_callbacks allocationCallbacks; - allocationCallbacks.pUserData = NULL; - allocationCallbacks.onMalloc = drwav__malloc_default; - allocationCallbacks.onRealloc = drwav__realloc_default; - allocationCallbacks.onFree = drwav__free_default; - return allocationCallbacks; - } -} -static DRWAV_INLINE drwav_bool32 drwav__is_compressed_format_tag(drwav_uint16 formatTag) -{ - return - formatTag == DR_WAVE_FORMAT_ADPCM || - formatTag == DR_WAVE_FORMAT_DVI_ADPCM; -} -DRWAV_PRIVATE unsigned int drwav__chunk_padding_size_riff(drwav_uint64 chunkSize) -{ - return (unsigned int)(chunkSize % 2); -} -DRWAV_PRIVATE unsigned int drwav__chunk_padding_size_w64(drwav_uint64 chunkSize) -{ - return (unsigned int)(chunkSize % 8); -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__msadpcm(drwav* pWav, drwav_uint64 samplesToRead, drwav_int16* pBufferOut); -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__ima(drwav* pWav, drwav_uint64 samplesToRead, drwav_int16* pBufferOut); -DRWAV_PRIVATE drwav_bool32 drwav_init_write__internal(drwav* pWav, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount); -DRWAV_PRIVATE drwav_result drwav__read_chunk_header(drwav_read_proc onRead, void* pUserData, drwav_container container, drwav_uint64* pRunningBytesReadOut, drwav_chunk_header* pHeaderOut) -{ - if (container == drwav_container_riff || container == drwav_container_rf64) { - drwav_uint8 sizeInBytes[4]; - if (onRead(pUserData, pHeaderOut->id.fourcc, 4) != 4) { - return DRWAV_AT_END; - } - if (onRead(pUserData, sizeInBytes, 4) != 4) { - return DRWAV_INVALID_FILE; - } - pHeaderOut->sizeInBytes = drwav_bytes_to_u32(sizeInBytes); - pHeaderOut->paddingSize = drwav__chunk_padding_size_riff(pHeaderOut->sizeInBytes); - *pRunningBytesReadOut += 8; - } else { - drwav_uint8 sizeInBytes[8]; - if (onRead(pUserData, pHeaderOut->id.guid, 16) != 16) { - return DRWAV_AT_END; - } - if (onRead(pUserData, sizeInBytes, 8) != 8) { - return DRWAV_INVALID_FILE; - } - pHeaderOut->sizeInBytes = drwav_bytes_to_u64(sizeInBytes) - 24; - pHeaderOut->paddingSize = drwav__chunk_padding_size_w64(pHeaderOut->sizeInBytes); - *pRunningBytesReadOut += 24; - } - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE drwav_bool32 drwav__seek_forward(drwav_seek_proc onSeek, drwav_uint64 offset, void* pUserData) -{ - drwav_uint64 bytesRemainingToSeek = offset; - while (bytesRemainingToSeek > 0) { - if (bytesRemainingToSeek > 0x7FFFFFFF) { - if (!onSeek(pUserData, 0x7FFFFFFF, drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - bytesRemainingToSeek -= 0x7FFFFFFF; - } else { - if (!onSeek(pUserData, (int)bytesRemainingToSeek, drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - bytesRemainingToSeek = 0; - } - } - return DRWAV_TRUE; -} -DRWAV_PRIVATE drwav_bool32 drwav__seek_from_start(drwav_seek_proc onSeek, drwav_uint64 offset, void* pUserData) -{ - if (offset <= 0x7FFFFFFF) { - return onSeek(pUserData, (int)offset, drwav_seek_origin_start); - } - if (!onSeek(pUserData, 0x7FFFFFFF, drwav_seek_origin_start)) { - return DRWAV_FALSE; - } - offset -= 0x7FFFFFFF; - for (;;) { - if (offset <= 0x7FFFFFFF) { - return onSeek(pUserData, (int)offset, drwav_seek_origin_current); - } - if (!onSeek(pUserData, 0x7FFFFFFF, drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - offset -= 0x7FFFFFFF; - } -} -DRWAV_PRIVATE drwav_bool32 drwav__read_fmt(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, drwav_container container, drwav_uint64* pRunningBytesReadOut, drwav_fmt* fmtOut) -{ - drwav_chunk_header header; - drwav_uint8 fmt[16]; - if (drwav__read_chunk_header(onRead, pUserData, container, pRunningBytesReadOut, &header) != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - while (((container == drwav_container_riff || container == drwav_container_rf64) && !drwav_fourcc_equal(header.id.fourcc, "fmt ")) || (container == drwav_container_w64 && !drwav_guid_equal(header.id.guid, drwavGUID_W64_FMT))) { - if (!drwav__seek_forward(onSeek, header.sizeInBytes + header.paddingSize, pUserData)) { - return DRWAV_FALSE; - } - *pRunningBytesReadOut += header.sizeInBytes + header.paddingSize; - if (drwav__read_chunk_header(onRead, pUserData, container, pRunningBytesReadOut, &header) != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - } - if (container == drwav_container_riff || container == drwav_container_rf64) { - if (!drwav_fourcc_equal(header.id.fourcc, "fmt ")) { - return DRWAV_FALSE; - } - } else { - if (!drwav_guid_equal(header.id.guid, drwavGUID_W64_FMT)) { - return DRWAV_FALSE; - } - } - if (onRead(pUserData, fmt, sizeof(fmt)) != sizeof(fmt)) { - return DRWAV_FALSE; - } - *pRunningBytesReadOut += sizeof(fmt); - fmtOut->formatTag = drwav_bytes_to_u16(fmt + 0); - fmtOut->channels = drwav_bytes_to_u16(fmt + 2); - fmtOut->sampleRate = drwav_bytes_to_u32(fmt + 4); - fmtOut->avgBytesPerSec = drwav_bytes_to_u32(fmt + 8); - fmtOut->blockAlign = drwav_bytes_to_u16(fmt + 12); - fmtOut->bitsPerSample = drwav_bytes_to_u16(fmt + 14); - fmtOut->extendedSize = 0; - fmtOut->validBitsPerSample = 0; - fmtOut->channelMask = 0; - DRWAV_ZERO_MEMORY(fmtOut->subFormat, sizeof(fmtOut->subFormat)); - if (header.sizeInBytes > 16) { - drwav_uint8 fmt_cbSize[2]; - int bytesReadSoFar = 0; - if (onRead(pUserData, fmt_cbSize, sizeof(fmt_cbSize)) != sizeof(fmt_cbSize)) { - return DRWAV_FALSE; - } - *pRunningBytesReadOut += sizeof(fmt_cbSize); - bytesReadSoFar = 18; - fmtOut->extendedSize = drwav_bytes_to_u16(fmt_cbSize); - if (fmtOut->extendedSize > 0) { - if (fmtOut->formatTag == DR_WAVE_FORMAT_EXTENSIBLE) { - if (fmtOut->extendedSize != 22) { - return DRWAV_FALSE; - } - } - if (fmtOut->formatTag == DR_WAVE_FORMAT_EXTENSIBLE) { - drwav_uint8 fmtext[22]; - if (onRead(pUserData, fmtext, fmtOut->extendedSize) != fmtOut->extendedSize) { - return DRWAV_FALSE; - } - fmtOut->validBitsPerSample = drwav_bytes_to_u16(fmtext + 0); - fmtOut->channelMask = drwav_bytes_to_u32(fmtext + 2); - drwav_bytes_to_guid(fmtext + 6, fmtOut->subFormat); - } else { - if (!onSeek(pUserData, fmtOut->extendedSize, drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - } - *pRunningBytesReadOut += fmtOut->extendedSize; - bytesReadSoFar += fmtOut->extendedSize; - } - if (!onSeek(pUserData, (int)(header.sizeInBytes - bytesReadSoFar), drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - *pRunningBytesReadOut += (header.sizeInBytes - bytesReadSoFar); - } - if (header.paddingSize > 0) { - if (!onSeek(pUserData, header.paddingSize, drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - *pRunningBytesReadOut += header.paddingSize; - } - return DRWAV_TRUE; -} -DRWAV_PRIVATE size_t drwav__on_read(drwav_read_proc onRead, void* pUserData, void* pBufferOut, size_t bytesToRead, drwav_uint64* pCursor) -{ - size_t bytesRead; - DRWAV_ASSERT(onRead != NULL); - DRWAV_ASSERT(pCursor != NULL); - bytesRead = onRead(pUserData, pBufferOut, bytesToRead); - *pCursor += bytesRead; - return bytesRead; -} -#if 0 -DRWAV_PRIVATE drwav_bool32 drwav__on_seek(drwav_seek_proc onSeek, void* pUserData, int offset, drwav_seek_origin origin, drwav_uint64* pCursor) -{ - DRWAV_ASSERT(onSeek != NULL); - DRWAV_ASSERT(pCursor != NULL); - if (!onSeek(pUserData, offset, origin)) { - return DRWAV_FALSE; - } - if (origin == drwav_seek_origin_start) { - *pCursor = offset; - } else { - *pCursor += offset; - } - return DRWAV_TRUE; -} -#endif -#define DRWAV_SMPL_BYTES 36 -#define DRWAV_SMPL_LOOP_BYTES 24 -#define DRWAV_INST_BYTES 7 -#define DRWAV_ACID_BYTES 24 -#define DRWAV_CUE_BYTES 4 -#define DRWAV_BEXT_BYTES 602 -#define DRWAV_BEXT_DESCRIPTION_BYTES 256 -#define DRWAV_BEXT_ORIGINATOR_NAME_BYTES 32 -#define DRWAV_BEXT_ORIGINATOR_REF_BYTES 32 -#define DRWAV_BEXT_RESERVED_BYTES 180 -#define DRWAV_BEXT_UMID_BYTES 64 -#define DRWAV_CUE_POINT_BYTES 24 -#define DRWAV_LIST_LABEL_OR_NOTE_BYTES 4 -#define DRWAV_LIST_LABELLED_TEXT_BYTES 20 -#define DRWAV_METADATA_ALIGNMENT 8 -typedef enum -{ - drwav__metadata_parser_stage_count, - drwav__metadata_parser_stage_read -} drwav__metadata_parser_stage; -typedef struct -{ - drwav_read_proc onRead; - drwav_seek_proc onSeek; - void *pReadSeekUserData; - drwav__metadata_parser_stage stage; - drwav_metadata *pMetadata; - drwav_uint32 metadataCount; - drwav_uint8 *pData; - drwav_uint8 *pDataCursor; - drwav_uint64 metadataCursor; - drwav_uint64 extraCapacity; -} drwav__metadata_parser; -DRWAV_PRIVATE size_t drwav__metadata_memory_capacity(drwav__metadata_parser* pParser) -{ - drwav_uint64 cap = sizeof(drwav_metadata) * (drwav_uint64)pParser->metadataCount + pParser->extraCapacity; - if (cap > DRWAV_SIZE_MAX) { - return 0; - } - return (size_t)cap; -} -DRWAV_PRIVATE drwav_uint8* drwav__metadata_get_memory(drwav__metadata_parser* pParser, size_t size, size_t align) -{ - drwav_uint8* pResult; - if (align) { - drwav_uintptr modulo = (drwav_uintptr)pParser->pDataCursor % align; - if (modulo != 0) { - pParser->pDataCursor += align - modulo; - } - } - pResult = pParser->pDataCursor; - DRWAV_ASSERT((pResult + size) <= (pParser->pData + drwav__metadata_memory_capacity(pParser))); - pParser->pDataCursor += size; - return pResult; -} -DRWAV_PRIVATE void drwav__metadata_request_extra_memory_for_stage_2(drwav__metadata_parser* pParser, size_t bytes, size_t align) -{ - size_t extra = bytes + (align ? (align - 1) : 0); - pParser->extraCapacity += extra; -} -DRWAV_PRIVATE drwav_result drwav__metadata_alloc(drwav__metadata_parser* pParser, drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pParser->extraCapacity != 0 || pParser->metadataCount != 0) { - pAllocationCallbacks->onFree(pParser->pData, pAllocationCallbacks->pUserData); - pParser->pData = (drwav_uint8*)pAllocationCallbacks->onMalloc(drwav__metadata_memory_capacity(pParser), pAllocationCallbacks->pUserData); - pParser->pDataCursor = pParser->pData; - if (pParser->pData == NULL) { - return DRWAV_OUT_OF_MEMORY; - } - pParser->pMetadata = (drwav_metadata*)drwav__metadata_get_memory(pParser, sizeof(drwav_metadata) * pParser->metadataCount, 1); - pParser->metadataCursor = 0; - } - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE size_t drwav__metadata_parser_read(drwav__metadata_parser* pParser, void* pBufferOut, size_t bytesToRead, drwav_uint64* pCursor) -{ - if (pCursor != NULL) { - return drwav__on_read(pParser->onRead, pParser->pReadSeekUserData, pBufferOut, bytesToRead, pCursor); - } else { - return pParser->onRead(pParser->pReadSeekUserData, pBufferOut, bytesToRead); - } -} -DRWAV_PRIVATE drwav_uint64 drwav__read_smpl_to_metadata_obj(drwav__metadata_parser* pParser, const drwav_chunk_header* pChunkHeader, drwav_metadata* pMetadata) -{ - drwav_uint8 smplHeaderData[DRWAV_SMPL_BYTES]; - drwav_uint64 totalBytesRead = 0; - size_t bytesJustRead = drwav__metadata_parser_read(pParser, smplHeaderData, sizeof(smplHeaderData), &totalBytesRead); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - DRWAV_ASSERT(pChunkHeader != NULL); - if (bytesJustRead == sizeof(smplHeaderData)) { - drwav_uint32 iSampleLoop; - pMetadata->type = drwav_metadata_type_smpl; - pMetadata->data.smpl.manufacturerId = drwav_bytes_to_u32(smplHeaderData + 0); - pMetadata->data.smpl.productId = drwav_bytes_to_u32(smplHeaderData + 4); - pMetadata->data.smpl.samplePeriodNanoseconds = drwav_bytes_to_u32(smplHeaderData + 8); - pMetadata->data.smpl.midiUnityNote = drwav_bytes_to_u32(smplHeaderData + 12); - pMetadata->data.smpl.midiPitchFraction = drwav_bytes_to_u32(smplHeaderData + 16); - pMetadata->data.smpl.smpteFormat = drwav_bytes_to_u32(smplHeaderData + 20); - pMetadata->data.smpl.smpteOffset = drwav_bytes_to_u32(smplHeaderData + 24); - pMetadata->data.smpl.sampleLoopCount = drwav_bytes_to_u32(smplHeaderData + 28); - pMetadata->data.smpl.samplerSpecificDataSizeInBytes = drwav_bytes_to_u32(smplHeaderData + 32); - if (pMetadata->data.smpl.sampleLoopCount == (pChunkHeader->sizeInBytes - DRWAV_SMPL_BYTES) / DRWAV_SMPL_LOOP_BYTES) { - pMetadata->data.smpl.pLoops = (drwav_smpl_loop*)drwav__metadata_get_memory(pParser, sizeof(drwav_smpl_loop) * pMetadata->data.smpl.sampleLoopCount, DRWAV_METADATA_ALIGNMENT); - for (iSampleLoop = 0; iSampleLoop < pMetadata->data.smpl.sampleLoopCount; ++iSampleLoop) { - drwav_uint8 smplLoopData[DRWAV_SMPL_LOOP_BYTES]; - bytesJustRead = drwav__metadata_parser_read(pParser, smplLoopData, sizeof(smplLoopData), &totalBytesRead); - if (bytesJustRead == sizeof(smplLoopData)) { - pMetadata->data.smpl.pLoops[iSampleLoop].cuePointId = drwav_bytes_to_u32(smplLoopData + 0); - pMetadata->data.smpl.pLoops[iSampleLoop].type = drwav_bytes_to_u32(smplLoopData + 4); - pMetadata->data.smpl.pLoops[iSampleLoop].firstSampleByteOffset = drwav_bytes_to_u32(smplLoopData + 8); - pMetadata->data.smpl.pLoops[iSampleLoop].lastSampleByteOffset = drwav_bytes_to_u32(smplLoopData + 12); - pMetadata->data.smpl.pLoops[iSampleLoop].sampleFraction = drwav_bytes_to_u32(smplLoopData + 16); - pMetadata->data.smpl.pLoops[iSampleLoop].playCount = drwav_bytes_to_u32(smplLoopData + 20); - } else { - break; - } - } - if (pMetadata->data.smpl.samplerSpecificDataSizeInBytes > 0) { - pMetadata->data.smpl.pSamplerSpecificData = drwav__metadata_get_memory(pParser, pMetadata->data.smpl.samplerSpecificDataSizeInBytes, 1); - DRWAV_ASSERT(pMetadata->data.smpl.pSamplerSpecificData != NULL); - drwav__metadata_parser_read(pParser, pMetadata->data.smpl.pSamplerSpecificData, pMetadata->data.smpl.samplerSpecificDataSizeInBytes, &totalBytesRead); - } - } - } - return totalBytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__read_cue_to_metadata_obj(drwav__metadata_parser* pParser, const drwav_chunk_header* pChunkHeader, drwav_metadata* pMetadata) -{ - drwav_uint8 cueHeaderSectionData[DRWAV_CUE_BYTES]; - drwav_uint64 totalBytesRead = 0; - size_t bytesJustRead = drwav__metadata_parser_read(pParser, cueHeaderSectionData, sizeof(cueHeaderSectionData), &totalBytesRead); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - if (bytesJustRead == sizeof(cueHeaderSectionData)) { - pMetadata->type = drwav_metadata_type_cue; - pMetadata->data.cue.cuePointCount = drwav_bytes_to_u32(cueHeaderSectionData); - if (pMetadata->data.cue.cuePointCount == (pChunkHeader->sizeInBytes - DRWAV_CUE_BYTES) / DRWAV_CUE_POINT_BYTES) { - pMetadata->data.cue.pCuePoints = (drwav_cue_point*)drwav__metadata_get_memory(pParser, sizeof(drwav_cue_point) * pMetadata->data.cue.cuePointCount, DRWAV_METADATA_ALIGNMENT); - DRWAV_ASSERT(pMetadata->data.cue.pCuePoints != NULL); - if (pMetadata->data.cue.cuePointCount > 0) { - drwav_uint32 iCuePoint; - for (iCuePoint = 0; iCuePoint < pMetadata->data.cue.cuePointCount; ++iCuePoint) { - drwav_uint8 cuePointData[DRWAV_CUE_POINT_BYTES]; - bytesJustRead = drwav__metadata_parser_read(pParser, cuePointData, sizeof(cuePointData), &totalBytesRead); - if (bytesJustRead == sizeof(cuePointData)) { - pMetadata->data.cue.pCuePoints[iCuePoint].id = drwav_bytes_to_u32(cuePointData + 0); - pMetadata->data.cue.pCuePoints[iCuePoint].playOrderPosition = drwav_bytes_to_u32(cuePointData + 4); - pMetadata->data.cue.pCuePoints[iCuePoint].dataChunkId[0] = cuePointData[8]; - pMetadata->data.cue.pCuePoints[iCuePoint].dataChunkId[1] = cuePointData[9]; - pMetadata->data.cue.pCuePoints[iCuePoint].dataChunkId[2] = cuePointData[10]; - pMetadata->data.cue.pCuePoints[iCuePoint].dataChunkId[3] = cuePointData[11]; - pMetadata->data.cue.pCuePoints[iCuePoint].chunkStart = drwav_bytes_to_u32(cuePointData + 12); - pMetadata->data.cue.pCuePoints[iCuePoint].blockStart = drwav_bytes_to_u32(cuePointData + 16); - pMetadata->data.cue.pCuePoints[iCuePoint].sampleByteOffset = drwav_bytes_to_u32(cuePointData + 20); - } else { - break; - } - } - } - } - } - return totalBytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__read_inst_to_metadata_obj(drwav__metadata_parser* pParser, drwav_metadata* pMetadata) -{ - drwav_uint8 instData[DRWAV_INST_BYTES]; - drwav_uint64 bytesRead = drwav__metadata_parser_read(pParser, instData, sizeof(instData), NULL); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - if (bytesRead == sizeof(instData)) { - pMetadata->type = drwav_metadata_type_inst; - pMetadata->data.inst.midiUnityNote = (drwav_int8)instData[0]; - pMetadata->data.inst.fineTuneCents = (drwav_int8)instData[1]; - pMetadata->data.inst.gainDecibels = (drwav_int8)instData[2]; - pMetadata->data.inst.lowNote = (drwav_int8)instData[3]; - pMetadata->data.inst.highNote = (drwav_int8)instData[4]; - pMetadata->data.inst.lowVelocity = (drwav_int8)instData[5]; - pMetadata->data.inst.highVelocity = (drwav_int8)instData[6]; - } - return bytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__read_acid_to_metadata_obj(drwav__metadata_parser* pParser, drwav_metadata* pMetadata) -{ - drwav_uint8 acidData[DRWAV_ACID_BYTES]; - drwav_uint64 bytesRead = drwav__metadata_parser_read(pParser, acidData, sizeof(acidData), NULL); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - if (bytesRead == sizeof(acidData)) { - pMetadata->type = drwav_metadata_type_acid; - pMetadata->data.acid.flags = drwav_bytes_to_u32(acidData + 0); - pMetadata->data.acid.midiUnityNote = drwav_bytes_to_u16(acidData + 4); - pMetadata->data.acid.reserved1 = drwav_bytes_to_u16(acidData + 6); - pMetadata->data.acid.reserved2 = drwav_bytes_to_f32(acidData + 8); - pMetadata->data.acid.numBeats = drwav_bytes_to_u32(acidData + 12); - pMetadata->data.acid.meterDenominator = drwav_bytes_to_u16(acidData + 16); - pMetadata->data.acid.meterNumerator = drwav_bytes_to_u16(acidData + 18); - pMetadata->data.acid.tempo = drwav_bytes_to_f32(acidData + 20); - } - return bytesRead; -} -DRWAV_PRIVATE size_t drwav__strlen(const char* str) -{ - size_t result = 0; - while (*str++) { - result += 1; - } - return result; -} -DRWAV_PRIVATE size_t drwav__strlen_clamped(const char* str, size_t maxToRead) -{ - size_t result = 0; - while (*str++ && result < maxToRead) { - result += 1; - } - return result; -} -DRWAV_PRIVATE char* drwav__metadata_copy_string(drwav__metadata_parser* pParser, const char* str, size_t maxToRead) -{ - size_t len = drwav__strlen_clamped(str, maxToRead); - if (len) { - char* result = (char*)drwav__metadata_get_memory(pParser, len + 1, 1); - DRWAV_ASSERT(result != NULL); - DRWAV_COPY_MEMORY(result, str, len); - result[len] = '\0'; - return result; - } else { - return NULL; - } -} -typedef struct -{ - const void* pBuffer; - size_t sizeInBytes; - size_t cursor; -} drwav_buffer_reader; -DRWAV_PRIVATE drwav_result drwav_buffer_reader_init(const void* pBuffer, size_t sizeInBytes, drwav_buffer_reader* pReader) -{ - DRWAV_ASSERT(pBuffer != NULL); - DRWAV_ASSERT(pReader != NULL); - DRWAV_ZERO_OBJECT(pReader); - pReader->pBuffer = pBuffer; - pReader->sizeInBytes = sizeInBytes; - pReader->cursor = 0; - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE const void* drwav_buffer_reader_ptr(const drwav_buffer_reader* pReader) -{ - DRWAV_ASSERT(pReader != NULL); - return drwav_offset_ptr(pReader->pBuffer, pReader->cursor); -} -DRWAV_PRIVATE drwav_result drwav_buffer_reader_seek(drwav_buffer_reader* pReader, size_t bytesToSeek) -{ - DRWAV_ASSERT(pReader != NULL); - if (pReader->cursor + bytesToSeek > pReader->sizeInBytes) { - return DRWAV_BAD_SEEK; - } - pReader->cursor += bytesToSeek; - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE drwav_result drwav_buffer_reader_read(drwav_buffer_reader* pReader, void* pDst, size_t bytesToRead, size_t* pBytesRead) -{ - drwav_result result = DRWAV_SUCCESS; - size_t bytesRemaining; - DRWAV_ASSERT(pReader != NULL); - if (pBytesRead != NULL) { - *pBytesRead = 0; - } - bytesRemaining = (pReader->sizeInBytes - pReader->cursor); - if (bytesToRead > bytesRemaining) { - bytesToRead = bytesRemaining; - } - if (pDst == NULL) { - result = drwav_buffer_reader_seek(pReader, bytesToRead); - } else { - DRWAV_COPY_MEMORY(pDst, drwav_buffer_reader_ptr(pReader), bytesToRead); - pReader->cursor += bytesToRead; - } - DRWAV_ASSERT(pReader->cursor <= pReader->sizeInBytes); - if (result == DRWAV_SUCCESS) { - if (pBytesRead != NULL) { - *pBytesRead = bytesToRead; - } - } - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE drwav_result drwav_buffer_reader_read_u16(drwav_buffer_reader* pReader, drwav_uint16* pDst) -{ - drwav_result result; - size_t bytesRead; - drwav_uint8 data[2]; - DRWAV_ASSERT(pReader != NULL); - DRWAV_ASSERT(pDst != NULL); - *pDst = 0; - result = drwav_buffer_reader_read(pReader, data, sizeof(*pDst), &bytesRead); - if (result != DRWAV_SUCCESS || bytesRead != sizeof(*pDst)) { - return result; - } - *pDst = drwav_bytes_to_u16(data); - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE drwav_result drwav_buffer_reader_read_u32(drwav_buffer_reader* pReader, drwav_uint32* pDst) -{ - drwav_result result; - size_t bytesRead; - drwav_uint8 data[4]; - DRWAV_ASSERT(pReader != NULL); - DRWAV_ASSERT(pDst != NULL); - *pDst = 0; - result = drwav_buffer_reader_read(pReader, data, sizeof(*pDst), &bytesRead); - if (result != DRWAV_SUCCESS || bytesRead != sizeof(*pDst)) { - return result; - } - *pDst = drwav_bytes_to_u32(data); - return DRWAV_SUCCESS; -} -DRWAV_PRIVATE drwav_uint64 drwav__read_bext_to_metadata_obj(drwav__metadata_parser* pParser, drwav_metadata* pMetadata, drwav_uint64 chunkSize) -{ - drwav_uint8 bextData[DRWAV_BEXT_BYTES]; - size_t bytesRead = drwav__metadata_parser_read(pParser, bextData, sizeof(bextData), NULL); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - if (bytesRead == sizeof(bextData)) { - drwav_buffer_reader reader; - drwav_uint32 timeReferenceLow; - drwav_uint32 timeReferenceHigh; - size_t extraBytes; - pMetadata->type = drwav_metadata_type_bext; - if (drwav_buffer_reader_init(bextData, bytesRead, &reader) == DRWAV_SUCCESS) { - pMetadata->data.bext.pDescription = drwav__metadata_copy_string(pParser, (const char*)drwav_buffer_reader_ptr(&reader), DRWAV_BEXT_DESCRIPTION_BYTES); - drwav_buffer_reader_seek(&reader, DRWAV_BEXT_DESCRIPTION_BYTES); - pMetadata->data.bext.pOriginatorName = drwav__metadata_copy_string(pParser, (const char*)drwav_buffer_reader_ptr(&reader), DRWAV_BEXT_ORIGINATOR_NAME_BYTES); - drwav_buffer_reader_seek(&reader, DRWAV_BEXT_ORIGINATOR_NAME_BYTES); - pMetadata->data.bext.pOriginatorReference = drwav__metadata_copy_string(pParser, (const char*)drwav_buffer_reader_ptr(&reader), DRWAV_BEXT_ORIGINATOR_REF_BYTES); - drwav_buffer_reader_seek(&reader, DRWAV_BEXT_ORIGINATOR_REF_BYTES); - drwav_buffer_reader_read(&reader, pMetadata->data.bext.pOriginationDate, sizeof(pMetadata->data.bext.pOriginationDate), NULL); - drwav_buffer_reader_read(&reader, pMetadata->data.bext.pOriginationTime, sizeof(pMetadata->data.bext.pOriginationTime), NULL); - drwav_buffer_reader_read_u32(&reader, &timeReferenceLow); - drwav_buffer_reader_read_u32(&reader, &timeReferenceHigh); - pMetadata->data.bext.timeReference = ((drwav_uint64)timeReferenceHigh << 32) + timeReferenceLow; - drwav_buffer_reader_read_u16(&reader, &pMetadata->data.bext.version); - pMetadata->data.bext.pUMID = drwav__metadata_get_memory(pParser, DRWAV_BEXT_UMID_BYTES, 1); - drwav_buffer_reader_read(&reader, pMetadata->data.bext.pUMID, DRWAV_BEXT_UMID_BYTES, NULL); - drwav_buffer_reader_read_u16(&reader, &pMetadata->data.bext.loudnessValue); - drwav_buffer_reader_read_u16(&reader, &pMetadata->data.bext.loudnessRange); - drwav_buffer_reader_read_u16(&reader, &pMetadata->data.bext.maxTruePeakLevel); - drwav_buffer_reader_read_u16(&reader, &pMetadata->data.bext.maxMomentaryLoudness); - drwav_buffer_reader_read_u16(&reader, &pMetadata->data.bext.maxShortTermLoudness); - DRWAV_ASSERT((drwav_offset_ptr(drwav_buffer_reader_ptr(&reader), DRWAV_BEXT_RESERVED_BYTES)) == (bextData + DRWAV_BEXT_BYTES)); - extraBytes = (size_t)(chunkSize - DRWAV_BEXT_BYTES); - if (extraBytes > 0) { - pMetadata->data.bext.pCodingHistory = (char*)drwav__metadata_get_memory(pParser, extraBytes + 1, 1); - DRWAV_ASSERT(pMetadata->data.bext.pCodingHistory != NULL); - bytesRead += drwav__metadata_parser_read(pParser, pMetadata->data.bext.pCodingHistory, extraBytes, NULL); - pMetadata->data.bext.codingHistorySize = (drwav_uint32)drwav__strlen(pMetadata->data.bext.pCodingHistory); - } else { - pMetadata->data.bext.pCodingHistory = NULL; - pMetadata->data.bext.codingHistorySize = 0; - } - } - } - return bytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__read_list_label_or_note_to_metadata_obj(drwav__metadata_parser* pParser, drwav_metadata* pMetadata, drwav_uint64 chunkSize, drwav_metadata_type type) -{ - drwav_uint8 cueIDBuffer[DRWAV_LIST_LABEL_OR_NOTE_BYTES]; - drwav_uint64 totalBytesRead = 0; - size_t bytesJustRead = drwav__metadata_parser_read(pParser, cueIDBuffer, sizeof(cueIDBuffer), &totalBytesRead); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - if (bytesJustRead == sizeof(cueIDBuffer)) { - drwav_uint32 sizeIncludingNullTerminator; - pMetadata->type = type; - pMetadata->data.labelOrNote.cuePointId = drwav_bytes_to_u32(cueIDBuffer); - sizeIncludingNullTerminator = (drwav_uint32)chunkSize - DRWAV_LIST_LABEL_OR_NOTE_BYTES; - if (sizeIncludingNullTerminator > 0) { - pMetadata->data.labelOrNote.stringLength = sizeIncludingNullTerminator - 1; - pMetadata->data.labelOrNote.pString = (char*)drwav__metadata_get_memory(pParser, sizeIncludingNullTerminator, 1); - DRWAV_ASSERT(pMetadata->data.labelOrNote.pString != NULL); - drwav__metadata_parser_read(pParser, pMetadata->data.labelOrNote.pString, sizeIncludingNullTerminator, &totalBytesRead); - } else { - pMetadata->data.labelOrNote.stringLength = 0; - pMetadata->data.labelOrNote.pString = NULL; - } - } - return totalBytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__read_list_labelled_cue_region_to_metadata_obj(drwav__metadata_parser* pParser, drwav_metadata* pMetadata, drwav_uint64 chunkSize) -{ - drwav_uint8 buffer[DRWAV_LIST_LABELLED_TEXT_BYTES]; - drwav_uint64 totalBytesRead = 0; - size_t bytesJustRead = drwav__metadata_parser_read(pParser, buffer, sizeof(buffer), &totalBytesRead); - DRWAV_ASSERT(pParser->stage == drwav__metadata_parser_stage_read); - if (bytesJustRead == sizeof(buffer)) { - drwav_uint32 sizeIncludingNullTerminator; - pMetadata->type = drwav_metadata_type_list_labelled_cue_region; - pMetadata->data.labelledCueRegion.cuePointId = drwav_bytes_to_u32(buffer + 0); - pMetadata->data.labelledCueRegion.sampleLength = drwav_bytes_to_u32(buffer + 4); - pMetadata->data.labelledCueRegion.purposeId[0] = buffer[8]; - pMetadata->data.labelledCueRegion.purposeId[1] = buffer[9]; - pMetadata->data.labelledCueRegion.purposeId[2] = buffer[10]; - pMetadata->data.labelledCueRegion.purposeId[3] = buffer[11]; - pMetadata->data.labelledCueRegion.country = drwav_bytes_to_u16(buffer + 12); - pMetadata->data.labelledCueRegion.language = drwav_bytes_to_u16(buffer + 14); - pMetadata->data.labelledCueRegion.dialect = drwav_bytes_to_u16(buffer + 16); - pMetadata->data.labelledCueRegion.codePage = drwav_bytes_to_u16(buffer + 18); - sizeIncludingNullTerminator = (drwav_uint32)chunkSize - DRWAV_LIST_LABELLED_TEXT_BYTES; - if (sizeIncludingNullTerminator > 0) { - pMetadata->data.labelledCueRegion.stringLength = sizeIncludingNullTerminator - 1; - pMetadata->data.labelledCueRegion.pString = (char*)drwav__metadata_get_memory(pParser, sizeIncludingNullTerminator, 1); - DRWAV_ASSERT(pMetadata->data.labelledCueRegion.pString != NULL); - drwav__metadata_parser_read(pParser, pMetadata->data.labelledCueRegion.pString, sizeIncludingNullTerminator, &totalBytesRead); - } else { - pMetadata->data.labelledCueRegion.stringLength = 0; - pMetadata->data.labelledCueRegion.pString = NULL; - } - } - return totalBytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__metadata_process_info_text_chunk(drwav__metadata_parser* pParser, drwav_uint64 chunkSize, drwav_metadata_type type) -{ - drwav_uint64 bytesRead = 0; - drwav_uint32 stringSizeWithNullTerminator = (drwav_uint32)chunkSize; - if (pParser->stage == drwav__metadata_parser_stage_count) { - pParser->metadataCount += 1; - drwav__metadata_request_extra_memory_for_stage_2(pParser, stringSizeWithNullTerminator, 1); - } else { - drwav_metadata* pMetadata = &pParser->pMetadata[pParser->metadataCursor]; - pMetadata->type = type; - if (stringSizeWithNullTerminator > 0) { - pMetadata->data.infoText.stringLength = stringSizeWithNullTerminator - 1; - pMetadata->data.infoText.pString = (char*)drwav__metadata_get_memory(pParser, stringSizeWithNullTerminator, 1); - DRWAV_ASSERT(pMetadata->data.infoText.pString != NULL); - bytesRead = drwav__metadata_parser_read(pParser, pMetadata->data.infoText.pString, (size_t)stringSizeWithNullTerminator, NULL); - if (bytesRead == chunkSize) { - pParser->metadataCursor += 1; - } else { - } - } else { - pMetadata->data.infoText.stringLength = 0; - pMetadata->data.infoText.pString = NULL; - pParser->metadataCursor += 1; - } - } - return bytesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav__metadata_process_unknown_chunk(drwav__metadata_parser* pParser, const drwav_uint8* pChunkId, drwav_uint64 chunkSize, drwav_metadata_location location) -{ - drwav_uint64 bytesRead = 0; - if (location == drwav_metadata_location_invalid) { - return 0; - } - if (drwav_fourcc_equal(pChunkId, "data") || drwav_fourcc_equal(pChunkId, "fmt") || drwav_fourcc_equal(pChunkId, "fact")) { - return 0; - } - if (pParser->stage == drwav__metadata_parser_stage_count) { - pParser->metadataCount += 1; - drwav__metadata_request_extra_memory_for_stage_2(pParser, (size_t)chunkSize, 1); - } else { - drwav_metadata* pMetadata = &pParser->pMetadata[pParser->metadataCursor]; - pMetadata->type = drwav_metadata_type_unknown; - pMetadata->data.unknown.chunkLocation = location; - pMetadata->data.unknown.id[0] = pChunkId[0]; - pMetadata->data.unknown.id[1] = pChunkId[1]; - pMetadata->data.unknown.id[2] = pChunkId[2]; - pMetadata->data.unknown.id[3] = pChunkId[3]; - pMetadata->data.unknown.dataSizeInBytes = (drwav_uint32)chunkSize; - pMetadata->data.unknown.pData = (drwav_uint8 *)drwav__metadata_get_memory(pParser, (size_t)chunkSize, 1); - DRWAV_ASSERT(pMetadata->data.unknown.pData != NULL); - bytesRead = drwav__metadata_parser_read(pParser, pMetadata->data.unknown.pData, pMetadata->data.unknown.dataSizeInBytes, NULL); - if (bytesRead == pMetadata->data.unknown.dataSizeInBytes) { - pParser->metadataCursor += 1; - } else { - } - } - return bytesRead; -} -DRWAV_PRIVATE drwav_bool32 drwav__chunk_matches(drwav_metadata_type allowedMetadataTypes, const drwav_uint8* pChunkID, drwav_metadata_type type, const char* pID) -{ - return (allowedMetadataTypes & type) && drwav_fourcc_equal(pChunkID, pID); -} -DRWAV_PRIVATE drwav_uint64 drwav__metadata_process_chunk(drwav__metadata_parser* pParser, const drwav_chunk_header* pChunkHeader, drwav_metadata_type allowedMetadataTypes) -{ - const drwav_uint8 *pChunkID = pChunkHeader->id.fourcc; - drwav_uint64 bytesRead = 0; - if (drwav__chunk_matches(allowedMetadataTypes, pChunkID, drwav_metadata_type_smpl, "smpl")) { - if (pChunkHeader->sizeInBytes >= DRWAV_SMPL_BYTES) { - if (pParser->stage == drwav__metadata_parser_stage_count) { - drwav_uint8 buffer[4]; - size_t bytesJustRead; - if (!pParser->onSeek(pParser->pReadSeekUserData, 28, drwav_seek_origin_current)) { - return bytesRead; - } - bytesRead += 28; - bytesJustRead = drwav__metadata_parser_read(pParser, buffer, sizeof(buffer), &bytesRead); - if (bytesJustRead == sizeof(buffer)) { - drwav_uint32 loopCount = drwav_bytes_to_u32(buffer); - drwav_uint64 calculatedLoopCount; - calculatedLoopCount = (pChunkHeader->sizeInBytes - DRWAV_SMPL_BYTES) / DRWAV_SMPL_LOOP_BYTES; - if (calculatedLoopCount == loopCount) { - bytesJustRead = drwav__metadata_parser_read(pParser, buffer, sizeof(buffer), &bytesRead); - if (bytesJustRead == sizeof(buffer)) { - drwav_uint32 samplerSpecificDataSizeInBytes = drwav_bytes_to_u32(buffer); - pParser->metadataCount += 1; - drwav__metadata_request_extra_memory_for_stage_2(pParser, sizeof(drwav_smpl_loop) * loopCount, DRWAV_METADATA_ALIGNMENT); - drwav__metadata_request_extra_memory_for_stage_2(pParser, samplerSpecificDataSizeInBytes, 1); - } - } else { - } - } - } else { - bytesRead = drwav__read_smpl_to_metadata_obj(pParser, pChunkHeader, &pParser->pMetadata[pParser->metadataCursor]); - if (bytesRead == pChunkHeader->sizeInBytes) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav__chunk_matches(allowedMetadataTypes, pChunkID, drwav_metadata_type_inst, "inst")) { - if (pChunkHeader->sizeInBytes == DRWAV_INST_BYTES) { - if (pParser->stage == drwav__metadata_parser_stage_count) { - pParser->metadataCount += 1; - } else { - bytesRead = drwav__read_inst_to_metadata_obj(pParser, &pParser->pMetadata[pParser->metadataCursor]); - if (bytesRead == pChunkHeader->sizeInBytes) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav__chunk_matches(allowedMetadataTypes, pChunkID, drwav_metadata_type_acid, "acid")) { - if (pChunkHeader->sizeInBytes == DRWAV_ACID_BYTES) { - if (pParser->stage == drwav__metadata_parser_stage_count) { - pParser->metadataCount += 1; - } else { - bytesRead = drwav__read_acid_to_metadata_obj(pParser, &pParser->pMetadata[pParser->metadataCursor]); - if (bytesRead == pChunkHeader->sizeInBytes) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav__chunk_matches(allowedMetadataTypes, pChunkID, drwav_metadata_type_cue, "cue ")) { - if (pChunkHeader->sizeInBytes >= DRWAV_CUE_BYTES) { - if (pParser->stage == drwav__metadata_parser_stage_count) { - size_t cueCount; - pParser->metadataCount += 1; - cueCount = (size_t)(pChunkHeader->sizeInBytes - DRWAV_CUE_BYTES) / DRWAV_CUE_POINT_BYTES; - drwav__metadata_request_extra_memory_for_stage_2(pParser, sizeof(drwav_cue_point) * cueCount, DRWAV_METADATA_ALIGNMENT); - } else { - bytesRead = drwav__read_cue_to_metadata_obj(pParser, pChunkHeader, &pParser->pMetadata[pParser->metadataCursor]); - if (bytesRead == pChunkHeader->sizeInBytes) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav__chunk_matches(allowedMetadataTypes, pChunkID, drwav_metadata_type_bext, "bext")) { - if (pChunkHeader->sizeInBytes >= DRWAV_BEXT_BYTES) { - if (pParser->stage == drwav__metadata_parser_stage_count) { - char buffer[DRWAV_BEXT_DESCRIPTION_BYTES + 1]; - size_t allocSizeNeeded = DRWAV_BEXT_UMID_BYTES; - size_t bytesJustRead; - buffer[DRWAV_BEXT_DESCRIPTION_BYTES] = '\0'; - bytesJustRead = drwav__metadata_parser_read(pParser, buffer, DRWAV_BEXT_DESCRIPTION_BYTES, &bytesRead); - if (bytesJustRead != DRWAV_BEXT_DESCRIPTION_BYTES) { - return bytesRead; - } - allocSizeNeeded += drwav__strlen(buffer) + 1; - buffer[DRWAV_BEXT_ORIGINATOR_NAME_BYTES] = '\0'; - bytesJustRead = drwav__metadata_parser_read(pParser, buffer, DRWAV_BEXT_ORIGINATOR_NAME_BYTES, &bytesRead); - if (bytesJustRead != DRWAV_BEXT_ORIGINATOR_NAME_BYTES) { - return bytesRead; - } - allocSizeNeeded += drwav__strlen(buffer) + 1; - buffer[DRWAV_BEXT_ORIGINATOR_REF_BYTES] = '\0'; - bytesJustRead = drwav__metadata_parser_read(pParser, buffer, DRWAV_BEXT_ORIGINATOR_REF_BYTES, &bytesRead); - if (bytesJustRead != DRWAV_BEXT_ORIGINATOR_REF_BYTES) { - return bytesRead; - } - allocSizeNeeded += drwav__strlen(buffer) + 1; - allocSizeNeeded += (size_t)pChunkHeader->sizeInBytes - DRWAV_BEXT_BYTES; - drwav__metadata_request_extra_memory_for_stage_2(pParser, allocSizeNeeded, 1); - pParser->metadataCount += 1; - } else { - bytesRead = drwav__read_bext_to_metadata_obj(pParser, &pParser->pMetadata[pParser->metadataCursor], pChunkHeader->sizeInBytes); - if (bytesRead == pChunkHeader->sizeInBytes) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav_fourcc_equal(pChunkID, "LIST") || drwav_fourcc_equal(pChunkID, "list")) { - drwav_metadata_location listType = drwav_metadata_location_invalid; - while (bytesRead < pChunkHeader->sizeInBytes) { - drwav_uint8 subchunkId[4]; - drwav_uint8 subchunkSizeBuffer[4]; - drwav_uint64 subchunkDataSize; - drwav_uint64 subchunkBytesRead = 0; - drwav_uint64 bytesJustRead = drwav__metadata_parser_read(pParser, subchunkId, sizeof(subchunkId), &bytesRead); - if (bytesJustRead != sizeof(subchunkId)) { - break; - } - if (drwav_fourcc_equal(subchunkId, "adtl")) { - listType = drwav_metadata_location_inside_adtl_list; - continue; - } else if (drwav_fourcc_equal(subchunkId, "INFO")) { - listType = drwav_metadata_location_inside_info_list; - continue; - } - bytesJustRead = drwav__metadata_parser_read(pParser, subchunkSizeBuffer, sizeof(subchunkSizeBuffer), &bytesRead); - if (bytesJustRead != sizeof(subchunkSizeBuffer)) { - break; - } - subchunkDataSize = drwav_bytes_to_u32(subchunkSizeBuffer); - if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_label, "labl") || drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_note, "note")) { - if (subchunkDataSize >= DRWAV_LIST_LABEL_OR_NOTE_BYTES) { - drwav_uint64 stringSizeWithNullTerm = subchunkDataSize - DRWAV_LIST_LABEL_OR_NOTE_BYTES; - if (pParser->stage == drwav__metadata_parser_stage_count) { - pParser->metadataCount += 1; - drwav__metadata_request_extra_memory_for_stage_2(pParser, (size_t)stringSizeWithNullTerm, 1); - } else { - subchunkBytesRead = drwav__read_list_label_or_note_to_metadata_obj(pParser, &pParser->pMetadata[pParser->metadataCursor], subchunkDataSize, drwav_fourcc_equal(subchunkId, "labl") ? drwav_metadata_type_list_label : drwav_metadata_type_list_note); - if (subchunkBytesRead == subchunkDataSize) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_labelled_cue_region, "ltxt")) { - if (subchunkDataSize >= DRWAV_LIST_LABELLED_TEXT_BYTES) { - drwav_uint64 stringSizeWithNullTerminator = subchunkDataSize - DRWAV_LIST_LABELLED_TEXT_BYTES; - if (pParser->stage == drwav__metadata_parser_stage_count) { - pParser->metadataCount += 1; - drwav__metadata_request_extra_memory_for_stage_2(pParser, (size_t)stringSizeWithNullTerminator, 1); - } else { - subchunkBytesRead = drwav__read_list_labelled_cue_region_to_metadata_obj(pParser, &pParser->pMetadata[pParser->metadataCursor], subchunkDataSize); - if (subchunkBytesRead == subchunkDataSize) { - pParser->metadataCursor += 1; - } else { - } - } - } else { - } - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_software, "ISFT")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_software); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_copyright, "ICOP")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_copyright); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_title, "INAM")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_title); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_artist, "IART")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_artist); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_comment, "ICMT")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_comment); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_date, "ICRD")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_date); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_genre, "IGNR")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_genre); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_album, "IPRD")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_album); - } else if (drwav__chunk_matches(allowedMetadataTypes, subchunkId, drwav_metadata_type_list_info_tracknumber, "ITRK")) { - subchunkBytesRead = drwav__metadata_process_info_text_chunk(pParser, subchunkDataSize, drwav_metadata_type_list_info_tracknumber); - } else if ((allowedMetadataTypes & drwav_metadata_type_unknown) != 0) { - subchunkBytesRead = drwav__metadata_process_unknown_chunk(pParser, subchunkId, subchunkDataSize, listType); - } - bytesRead += subchunkBytesRead; - DRWAV_ASSERT(subchunkBytesRead <= subchunkDataSize); - if (subchunkBytesRead < subchunkDataSize) { - drwav_uint64 bytesToSeek = subchunkDataSize - subchunkBytesRead; - if (!pParser->onSeek(pParser->pReadSeekUserData, (int)bytesToSeek, drwav_seek_origin_current)) { - break; - } - bytesRead += bytesToSeek; - } - if ((subchunkDataSize % 2) == 1) { - if (!pParser->onSeek(pParser->pReadSeekUserData, 1, drwav_seek_origin_current)) { - break; - } - bytesRead += 1; - } - } - } else if ((allowedMetadataTypes & drwav_metadata_type_unknown) != 0) { - bytesRead = drwav__metadata_process_unknown_chunk(pParser, pChunkID, pChunkHeader->sizeInBytes, drwav_metadata_location_top_level); - } - return bytesRead; -} -DRWAV_PRIVATE drwav_uint32 drwav_get_bytes_per_pcm_frame(drwav* pWav) -{ - drwav_uint32 bytesPerFrame; - if ((pWav->bitsPerSample & 0x7) == 0) { - bytesPerFrame = (pWav->bitsPerSample * pWav->fmt.channels) >> 3; - } else { - bytesPerFrame = pWav->fmt.blockAlign; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ALAW || pWav->translatedFormatTag == DR_WAVE_FORMAT_MULAW) { - if (bytesPerFrame != pWav->fmt.channels) { - return 0; - } - } - return bytesPerFrame; -} -DRWAV_API drwav_uint16 drwav_fmt_get_format(const drwav_fmt* pFMT) -{ - if (pFMT == NULL) { - return 0; - } - if (pFMT->formatTag != DR_WAVE_FORMAT_EXTENSIBLE) { - return pFMT->formatTag; - } else { - return drwav_bytes_to_u16(pFMT->subFormat); - } -} -DRWAV_PRIVATE drwav_bool32 drwav_preinit(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, void* pReadSeekUserData, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pWav == NULL || onRead == NULL || onSeek == NULL) { - return DRWAV_FALSE; - } - DRWAV_ZERO_MEMORY(pWav, sizeof(*pWav)); - pWav->onRead = onRead; - pWav->onSeek = onSeek; - pWav->pUserData = pReadSeekUserData; - pWav->allocationCallbacks = drwav_copy_allocation_callbacks_or_defaults(pAllocationCallbacks); - if (pWav->allocationCallbacks.onFree == NULL || (pWav->allocationCallbacks.onMalloc == NULL && pWav->allocationCallbacks.onRealloc == NULL)) { - return DRWAV_FALSE; - } - return DRWAV_TRUE; -} -DRWAV_PRIVATE drwav_bool32 drwav_init__internal(drwav* pWav, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags) -{ - drwav_uint64 cursor; - drwav_bool32 sequential; - drwav_uint8 riff[4]; - drwav_fmt fmt; - unsigned short translatedFormatTag; - drwav_bool32 foundDataChunk; - drwav_uint64 dataChunkSize = 0; - drwav_uint64 sampleCountFromFactChunk = 0; - drwav_uint64 chunkSize; - drwav__metadata_parser metadataParser; - cursor = 0; - sequential = (flags & DRWAV_SEQUENTIAL) != 0; - if (drwav__on_read(pWav->onRead, pWav->pUserData, riff, sizeof(riff), &cursor) != sizeof(riff)) { - return DRWAV_FALSE; - } - if (drwav_fourcc_equal(riff, "RIFF")) { - pWav->container = drwav_container_riff; - } else if (drwav_fourcc_equal(riff, "riff")) { - int i; - drwav_uint8 riff2[12]; - pWav->container = drwav_container_w64; - if (drwav__on_read(pWav->onRead, pWav->pUserData, riff2, sizeof(riff2), &cursor) != sizeof(riff2)) { - return DRWAV_FALSE; - } - for (i = 0; i < 12; ++i) { - if (riff2[i] != drwavGUID_W64_RIFF[i+4]) { - return DRWAV_FALSE; - } - } - } else if (drwav_fourcc_equal(riff, "RF64")) { - pWav->container = drwav_container_rf64; - } else { - return DRWAV_FALSE; - } - if (pWav->container == drwav_container_riff || pWav->container == drwav_container_rf64) { - drwav_uint8 chunkSizeBytes[4]; - drwav_uint8 wave[4]; - if (drwav__on_read(pWav->onRead, pWav->pUserData, chunkSizeBytes, sizeof(chunkSizeBytes), &cursor) != sizeof(chunkSizeBytes)) { - return DRWAV_FALSE; - } - if (pWav->container == drwav_container_riff) { - if (drwav_bytes_to_u32(chunkSizeBytes) < 36) { - return DRWAV_FALSE; - } - } else { - if (drwav_bytes_to_u32(chunkSizeBytes) != 0xFFFFFFFF) { - return DRWAV_FALSE; - } - } - if (drwav__on_read(pWav->onRead, pWav->pUserData, wave, sizeof(wave), &cursor) != sizeof(wave)) { - return DRWAV_FALSE; - } - if (!drwav_fourcc_equal(wave, "WAVE")) { - return DRWAV_FALSE; - } - } else { - drwav_uint8 chunkSizeBytes[8]; - drwav_uint8 wave[16]; - if (drwav__on_read(pWav->onRead, pWav->pUserData, chunkSizeBytes, sizeof(chunkSizeBytes), &cursor) != sizeof(chunkSizeBytes)) { - return DRWAV_FALSE; - } - if (drwav_bytes_to_u64(chunkSizeBytes) < 80) { - return DRWAV_FALSE; - } - if (drwav__on_read(pWav->onRead, pWav->pUserData, wave, sizeof(wave), &cursor) != sizeof(wave)) { - return DRWAV_FALSE; - } - if (!drwav_guid_equal(wave, drwavGUID_W64_WAVE)) { - return DRWAV_FALSE; - } - } - if (pWav->container == drwav_container_rf64) { - drwav_uint8 sizeBytes[8]; - drwav_uint64 bytesRemainingInChunk; - drwav_chunk_header header; - drwav_result result = drwav__read_chunk_header(pWav->onRead, pWav->pUserData, pWav->container, &cursor, &header); - if (result != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - if (!drwav_fourcc_equal(header.id.fourcc, "ds64")) { - return DRWAV_FALSE; - } - bytesRemainingInChunk = header.sizeInBytes + header.paddingSize; - if (!drwav__seek_forward(pWav->onSeek, 8, pWav->pUserData)) { - return DRWAV_FALSE; - } - bytesRemainingInChunk -= 8; - cursor += 8; - if (drwav__on_read(pWav->onRead, pWav->pUserData, sizeBytes, sizeof(sizeBytes), &cursor) != sizeof(sizeBytes)) { - return DRWAV_FALSE; - } - bytesRemainingInChunk -= 8; - dataChunkSize = drwav_bytes_to_u64(sizeBytes); - if (drwav__on_read(pWav->onRead, pWav->pUserData, sizeBytes, sizeof(sizeBytes), &cursor) != sizeof(sizeBytes)) { - return DRWAV_FALSE; - } - bytesRemainingInChunk -= 8; - sampleCountFromFactChunk = drwav_bytes_to_u64(sizeBytes); - if (!drwav__seek_forward(pWav->onSeek, bytesRemainingInChunk, pWav->pUserData)) { - return DRWAV_FALSE; - } - cursor += bytesRemainingInChunk; - } - if (!drwav__read_fmt(pWav->onRead, pWav->onSeek, pWav->pUserData, pWav->container, &cursor, &fmt)) { - return DRWAV_FALSE; - } - if ((fmt.sampleRate == 0 || fmt.sampleRate > DRWAV_MAX_SAMPLE_RATE) || - (fmt.channels == 0 || fmt.channels > DRWAV_MAX_CHANNELS) || - (fmt.bitsPerSample == 0 || fmt.bitsPerSample > DRWAV_MAX_BITS_PER_SAMPLE) || - fmt.blockAlign == 0) { - return DRWAV_FALSE; - } - translatedFormatTag = fmt.formatTag; - if (translatedFormatTag == DR_WAVE_FORMAT_EXTENSIBLE) { - translatedFormatTag = drwav_bytes_to_u16(fmt.subFormat + 0); - } - DRWAV_ZERO_MEMORY(&metadataParser, sizeof(metadataParser)); - if (!sequential && pWav->allowedMetadataTypes != drwav_metadata_type_none && (pWav->container == drwav_container_riff || pWav->container == drwav_container_rf64)) { - drwav_uint64 cursorForMetadata = cursor; - metadataParser.onRead = pWav->onRead; - metadataParser.onSeek = pWav->onSeek; - metadataParser.pReadSeekUserData = pWav->pUserData; - metadataParser.stage = drwav__metadata_parser_stage_count; - for (;;) { - drwav_result result; - drwav_uint64 bytesRead; - drwav_uint64 remainingBytes; - drwav_chunk_header header; - result = drwav__read_chunk_header(pWav->onRead, pWav->pUserData, pWav->container, &cursorForMetadata, &header); - if (result != DRWAV_SUCCESS) { - break; - } - bytesRead = drwav__metadata_process_chunk(&metadataParser, &header, pWav->allowedMetadataTypes); - DRWAV_ASSERT(bytesRead <= header.sizeInBytes); - remainingBytes = header.sizeInBytes - bytesRead + header.paddingSize; - if (!drwav__seek_forward(pWav->onSeek, remainingBytes, pWav->pUserData)) { - break; - } - cursorForMetadata += remainingBytes; - } - if (!drwav__seek_from_start(pWav->onSeek, cursor, pWav->pUserData)) { - return DRWAV_FALSE; - } - drwav__metadata_alloc(&metadataParser, &pWav->allocationCallbacks); - metadataParser.stage = drwav__metadata_parser_stage_read; - } - foundDataChunk = DRWAV_FALSE; - for (;;) { - drwav_chunk_header header; - drwav_result result = drwav__read_chunk_header(pWav->onRead, pWav->pUserData, pWav->container, &cursor, &header); - if (result != DRWAV_SUCCESS) { - if (!foundDataChunk) { - return DRWAV_FALSE; - } else { - break; - } - } - if (!sequential && onChunk != NULL) { - drwav_uint64 callbackBytesRead = onChunk(pChunkUserData, pWav->onRead, pWav->onSeek, pWav->pUserData, &header, pWav->container, &fmt); - if (callbackBytesRead > 0) { - if (!drwav__seek_from_start(pWav->onSeek, cursor, pWav->pUserData)) { - return DRWAV_FALSE; - } - } - } - if (!sequential && pWav->allowedMetadataTypes != drwav_metadata_type_none && (pWav->container == drwav_container_riff || pWav->container == drwav_container_rf64)) { - drwav_uint64 bytesRead = drwav__metadata_process_chunk(&metadataParser, &header, pWav->allowedMetadataTypes); - if (bytesRead > 0) { - if (!drwav__seek_from_start(pWav->onSeek, cursor, pWav->pUserData)) { - return DRWAV_FALSE; - } - } - } - if (!foundDataChunk) { - pWav->dataChunkDataPos = cursor; - } - chunkSize = header.sizeInBytes; - if (pWav->container == drwav_container_riff || pWav->container == drwav_container_rf64) { - if (drwav_fourcc_equal(header.id.fourcc, "data")) { - foundDataChunk = DRWAV_TRUE; - if (pWav->container != drwav_container_rf64) { - dataChunkSize = chunkSize; - } - } - } else { - if (drwav_guid_equal(header.id.guid, drwavGUID_W64_DATA)) { - foundDataChunk = DRWAV_TRUE; - dataChunkSize = chunkSize; - } - } - if (foundDataChunk && sequential) { - break; - } - if (pWav->container == drwav_container_riff) { - if (drwav_fourcc_equal(header.id.fourcc, "fact")) { - drwav_uint32 sampleCount; - if (drwav__on_read(pWav->onRead, pWav->pUserData, &sampleCount, 4, &cursor) != 4) { - return DRWAV_FALSE; - } - chunkSize -= 4; - if (!foundDataChunk) { - pWav->dataChunkDataPos = cursor; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM) { - sampleCountFromFactChunk = sampleCount; - } else { - sampleCountFromFactChunk = 0; - } - } - } else if (pWav->container == drwav_container_w64) { - if (drwav_guid_equal(header.id.guid, drwavGUID_W64_FACT)) { - if (drwav__on_read(pWav->onRead, pWav->pUserData, &sampleCountFromFactChunk, 8, &cursor) != 8) { - return DRWAV_FALSE; - } - chunkSize -= 8; - if (!foundDataChunk) { - pWav->dataChunkDataPos = cursor; - } - } - } else if (pWav->container == drwav_container_rf64) { - } - chunkSize += header.paddingSize; - if (!drwav__seek_forward(pWav->onSeek, chunkSize, pWav->pUserData)) { - break; - } - cursor += chunkSize; - if (!foundDataChunk) { - pWav->dataChunkDataPos = cursor; - } - } - pWav->pMetadata = metadataParser.pMetadata; - pWav->metadataCount = metadataParser.metadataCount; - if (!foundDataChunk) { - return DRWAV_FALSE; - } - if (!sequential) { - if (!drwav__seek_from_start(pWav->onSeek, pWav->dataChunkDataPos, pWav->pUserData)) { - return DRWAV_FALSE; - } - cursor = pWav->dataChunkDataPos; - } - pWav->fmt = fmt; - pWav->sampleRate = fmt.sampleRate; - pWav->channels = fmt.channels; - pWav->bitsPerSample = fmt.bitsPerSample; - pWav->bytesRemaining = dataChunkSize; - pWav->translatedFormatTag = translatedFormatTag; - pWav->dataChunkDataSize = dataChunkSize; - if (sampleCountFromFactChunk != 0) { - pWav->totalPCMFrameCount = sampleCountFromFactChunk; - } else { - drwav_uint32 bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return DRWAV_FALSE; - } - pWav->totalPCMFrameCount = dataChunkSize / bytesPerFrame; - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM) { - drwav_uint64 totalBlockHeaderSizeInBytes; - drwav_uint64 blockCount = dataChunkSize / fmt.blockAlign; - if ((blockCount * fmt.blockAlign) < dataChunkSize) { - blockCount += 1; - } - totalBlockHeaderSizeInBytes = blockCount * (6*fmt.channels); - pWav->totalPCMFrameCount = ((dataChunkSize - totalBlockHeaderSizeInBytes) * 2) / fmt.channels; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - drwav_uint64 totalBlockHeaderSizeInBytes; - drwav_uint64 blockCount = dataChunkSize / fmt.blockAlign; - if ((blockCount * fmt.blockAlign) < dataChunkSize) { - blockCount += 1; - } - totalBlockHeaderSizeInBytes = blockCount * (4*fmt.channels); - pWav->totalPCMFrameCount = ((dataChunkSize - totalBlockHeaderSizeInBytes) * 2) / fmt.channels; - pWav->totalPCMFrameCount += blockCount; - } - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM || pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - if (pWav->channels > 2) { - return DRWAV_FALSE; - } - } - if (drwav_get_bytes_per_pcm_frame(pWav) == 0) { - return DRWAV_FALSE; - } -#ifdef DR_WAV_LIBSNDFILE_COMPAT - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM) { - drwav_uint64 blockCount = dataChunkSize / fmt.blockAlign; - pWav->totalPCMFrameCount = (((blockCount * (fmt.blockAlign - (6*pWav->channels))) * 2)) / fmt.channels; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - drwav_uint64 blockCount = dataChunkSize / fmt.blockAlign; - pWav->totalPCMFrameCount = (((blockCount * (fmt.blockAlign - (4*pWav->channels))) * 2) + (blockCount * pWav->channels)) / fmt.channels; - } -#endif - return DRWAV_TRUE; -} -DRWAV_API drwav_bool32 drwav_init(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_ex(pWav, onRead, onSeek, NULL, pUserData, NULL, 0, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_ex(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, drwav_chunk_proc onChunk, void* pReadSeekUserData, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (!drwav_preinit(pWav, onRead, onSeek, pReadSeekUserData, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - return drwav_init__internal(pWav, onChunk, pChunkUserData, flags); -} -DRWAV_API drwav_bool32 drwav_init_with_metadata(drwav* pWav, drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (!drwav_preinit(pWav, onRead, onSeek, pUserData, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - pWav->allowedMetadataTypes = drwav_metadata_type_all_including_unknown; - return drwav_init__internal(pWav, NULL, NULL, flags); -} -DRWAV_API drwav_metadata* drwav_take_ownership_of_metadata(drwav* pWav) -{ - drwav_metadata *result = pWav->pMetadata; - pWav->pMetadata = NULL; - pWav->metadataCount = 0; - return result; -} -DRWAV_PRIVATE size_t drwav__write(drwav* pWav, const void* pData, size_t dataSize) -{ - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->onWrite != NULL); - return pWav->onWrite(pWav->pUserData, pData, dataSize); -} -DRWAV_PRIVATE size_t drwav__write_byte(drwav* pWav, drwav_uint8 byte) -{ - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->onWrite != NULL); - return pWav->onWrite(pWav->pUserData, &byte, 1); -} -DRWAV_PRIVATE size_t drwav__write_u16ne_to_le(drwav* pWav, drwav_uint16 value) -{ - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->onWrite != NULL); - if (!drwav__is_little_endian()) { - value = drwav__bswap16(value); - } - return drwav__write(pWav, &value, 2); -} -DRWAV_PRIVATE size_t drwav__write_u32ne_to_le(drwav* pWav, drwav_uint32 value) -{ - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->onWrite != NULL); - if (!drwav__is_little_endian()) { - value = drwav__bswap32(value); - } - return drwav__write(pWav, &value, 4); -} -DRWAV_PRIVATE size_t drwav__write_u64ne_to_le(drwav* pWav, drwav_uint64 value) -{ - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->onWrite != NULL); - if (!drwav__is_little_endian()) { - value = drwav__bswap64(value); - } - return drwav__write(pWav, &value, 8); -} -DRWAV_PRIVATE size_t drwav__write_f32ne_to_le(drwav* pWav, float value) -{ - union { - drwav_uint32 u32; - float f32; - } u; - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->onWrite != NULL); - u.f32 = value; - if (!drwav__is_little_endian()) { - u.u32 = drwav__bswap32(u.u32); - } - return drwav__write(pWav, &u.u32, 4); -} -DRWAV_PRIVATE size_t drwav__write_or_count(drwav* pWav, const void* pData, size_t dataSize) -{ - if (pWav == NULL) { - return dataSize; - } - return drwav__write(pWav, pData, dataSize); -} -DRWAV_PRIVATE size_t drwav__write_or_count_byte(drwav* pWav, drwav_uint8 byte) -{ - if (pWav == NULL) { - return 1; - } - return drwav__write_byte(pWav, byte); -} -DRWAV_PRIVATE size_t drwav__write_or_count_u16ne_to_le(drwav* pWav, drwav_uint16 value) -{ - if (pWav == NULL) { - return 2; - } - return drwav__write_u16ne_to_le(pWav, value); -} -DRWAV_PRIVATE size_t drwav__write_or_count_u32ne_to_le(drwav* pWav, drwav_uint32 value) -{ - if (pWav == NULL) { - return 4; - } - return drwav__write_u32ne_to_le(pWav, value); -} -#if 0 -DRWAV_PRIVATE size_t drwav__write_or_count_u64ne_to_le(drwav* pWav, drwav_uint64 value) -{ - if (pWav == NULL) { - return 8; - } - return drwav__write_u64ne_to_le(pWav, value); -} -#endif -DRWAV_PRIVATE size_t drwav__write_or_count_f32ne_to_le(drwav* pWav, float value) -{ - if (pWav == NULL) { - return 4; - } - return drwav__write_f32ne_to_le(pWav, value); -} -DRWAV_PRIVATE size_t drwav__write_or_count_string_to_fixed_size_buf(drwav* pWav, char* str, size_t bufFixedSize) -{ - size_t len; - if (pWav == NULL) { - return bufFixedSize; - } - len = drwav__strlen_clamped(str, bufFixedSize); - drwav__write_or_count(pWav, str, len); - if (len < bufFixedSize) { - size_t i; - for (i = 0; i < bufFixedSize - len; ++i) { - drwav__write_byte(pWav, 0); - } - } - return bufFixedSize; -} -DRWAV_PRIVATE size_t drwav__write_or_count_metadata(drwav* pWav, drwav_metadata* pMetadatas, drwav_uint32 metadataCount) -{ - size_t bytesWritten = 0; - drwav_bool32 hasListAdtl = DRWAV_FALSE; - drwav_bool32 hasListInfo = DRWAV_FALSE; - drwav_uint32 iMetadata; - if (pMetadatas == NULL || metadataCount == 0) { - return 0; - } - for (iMetadata = 0; iMetadata < metadataCount; ++iMetadata) { - drwav_metadata* pMetadata = &pMetadatas[iMetadata]; - drwav_uint32 chunkSize = 0; - if ((pMetadata->type & drwav_metadata_type_list_all_info_strings) || (pMetadata->type == drwav_metadata_type_unknown && pMetadata->data.unknown.chunkLocation == drwav_metadata_location_inside_info_list)) { - hasListInfo = DRWAV_TRUE; - } - if ((pMetadata->type & drwav_metadata_type_list_all_adtl) || (pMetadata->type == drwav_metadata_type_unknown && pMetadata->data.unknown.chunkLocation == drwav_metadata_location_inside_adtl_list)) { - hasListAdtl = DRWAV_TRUE; - } - switch (pMetadata->type) { - case drwav_metadata_type_smpl: - { - drwav_uint32 iLoop; - chunkSize = DRWAV_SMPL_BYTES + DRWAV_SMPL_LOOP_BYTES * pMetadata->data.smpl.sampleLoopCount + pMetadata->data.smpl.samplerSpecificDataSizeInBytes; - bytesWritten += drwav__write_or_count(pWav, "smpl", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.manufacturerId); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.productId); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.samplePeriodNanoseconds); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.midiUnityNote); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.midiPitchFraction); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.smpteFormat); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.smpteOffset); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.sampleLoopCount); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.samplerSpecificDataSizeInBytes); - for (iLoop = 0; iLoop < pMetadata->data.smpl.sampleLoopCount; ++iLoop) { - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.pLoops[iLoop].cuePointId); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.pLoops[iLoop].type); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.pLoops[iLoop].firstSampleByteOffset); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.pLoops[iLoop].lastSampleByteOffset); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.pLoops[iLoop].sampleFraction); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.smpl.pLoops[iLoop].playCount); - } - if (pMetadata->data.smpl.samplerSpecificDataSizeInBytes > 0) { - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.smpl.pSamplerSpecificData, pMetadata->data.smpl.samplerSpecificDataSizeInBytes); - } - } break; - case drwav_metadata_type_inst: - { - chunkSize = DRWAV_INST_BYTES; - bytesWritten += drwav__write_or_count(pWav, "inst", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.midiUnityNote, 1); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.fineTuneCents, 1); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.gainDecibels, 1); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.lowNote, 1); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.highNote, 1); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.lowVelocity, 1); - bytesWritten += drwav__write_or_count(pWav, &pMetadata->data.inst.highVelocity, 1); - } break; - case drwav_metadata_type_cue: - { - drwav_uint32 iCuePoint; - chunkSize = DRWAV_CUE_BYTES + DRWAV_CUE_POINT_BYTES * pMetadata->data.cue.cuePointCount; - bytesWritten += drwav__write_or_count(pWav, "cue ", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.cue.cuePointCount); - for (iCuePoint = 0; iCuePoint < pMetadata->data.cue.cuePointCount; ++iCuePoint) { - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.cue.pCuePoints[iCuePoint].id); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.cue.pCuePoints[iCuePoint].playOrderPosition); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.cue.pCuePoints[iCuePoint].dataChunkId, 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.cue.pCuePoints[iCuePoint].chunkStart); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.cue.pCuePoints[iCuePoint].blockStart); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.cue.pCuePoints[iCuePoint].sampleByteOffset); - } - } break; - case drwav_metadata_type_acid: - { - chunkSize = DRWAV_ACID_BYTES; - bytesWritten += drwav__write_or_count(pWav, "acid", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.acid.flags); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.acid.midiUnityNote); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.acid.reserved1); - bytesWritten += drwav__write_or_count_f32ne_to_le(pWav, pMetadata->data.acid.reserved2); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.acid.numBeats); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.acid.meterDenominator); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.acid.meterNumerator); - bytesWritten += drwav__write_or_count_f32ne_to_le(pWav, pMetadata->data.acid.tempo); - } break; - case drwav_metadata_type_bext: - { - char reservedBuf[DRWAV_BEXT_RESERVED_BYTES]; - drwav_uint32 timeReferenceLow; - drwav_uint32 timeReferenceHigh; - chunkSize = DRWAV_BEXT_BYTES + pMetadata->data.bext.codingHistorySize; - bytesWritten += drwav__write_or_count(pWav, "bext", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count_string_to_fixed_size_buf(pWav, pMetadata->data.bext.pDescription, DRWAV_BEXT_DESCRIPTION_BYTES); - bytesWritten += drwav__write_or_count_string_to_fixed_size_buf(pWav, pMetadata->data.bext.pOriginatorName, DRWAV_BEXT_ORIGINATOR_NAME_BYTES); - bytesWritten += drwav__write_or_count_string_to_fixed_size_buf(pWav, pMetadata->data.bext.pOriginatorReference, DRWAV_BEXT_ORIGINATOR_REF_BYTES); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.bext.pOriginationDate, sizeof(pMetadata->data.bext.pOriginationDate)); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.bext.pOriginationTime, sizeof(pMetadata->data.bext.pOriginationTime)); - timeReferenceLow = (drwav_uint32)(pMetadata->data.bext.timeReference & 0xFFFFFFFF); - timeReferenceHigh = (drwav_uint32)(pMetadata->data.bext.timeReference >> 32); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, timeReferenceLow); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, timeReferenceHigh); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.bext.version); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.bext.pUMID, DRWAV_BEXT_UMID_BYTES); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.bext.loudnessValue); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.bext.loudnessRange); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.bext.maxTruePeakLevel); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.bext.maxMomentaryLoudness); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.bext.maxShortTermLoudness); - DRWAV_ZERO_MEMORY(reservedBuf, sizeof(reservedBuf)); - bytesWritten += drwav__write_or_count(pWav, reservedBuf, sizeof(reservedBuf)); - if (pMetadata->data.bext.codingHistorySize > 0) { - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.bext.pCodingHistory, pMetadata->data.bext.codingHistorySize); - } - } break; - case drwav_metadata_type_unknown: - { - if (pMetadata->data.unknown.chunkLocation == drwav_metadata_location_top_level) { - chunkSize = pMetadata->data.unknown.dataSizeInBytes; - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.unknown.id, 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.unknown.pData, pMetadata->data.unknown.dataSizeInBytes); - } - } break; - default: break; - } - if ((chunkSize % 2) != 0) { - bytesWritten += drwav__write_or_count_byte(pWav, 0); - } - } - if (hasListInfo) { - drwav_uint32 chunkSize = 4; - for (iMetadata = 0; iMetadata < metadataCount; ++iMetadata) { - drwav_metadata* pMetadata = &pMetadatas[iMetadata]; - if ((pMetadata->type & drwav_metadata_type_list_all_info_strings)) { - chunkSize += 8; - chunkSize += pMetadata->data.infoText.stringLength + 1; - } else if (pMetadata->type == drwav_metadata_type_unknown && pMetadata->data.unknown.chunkLocation == drwav_metadata_location_inside_info_list) { - chunkSize += 8; - chunkSize += pMetadata->data.unknown.dataSizeInBytes; - } - if ((chunkSize % 2) != 0) { - chunkSize += 1; - } - } - bytesWritten += drwav__write_or_count(pWav, "LIST", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count(pWav, "INFO", 4); - for (iMetadata = 0; iMetadata < metadataCount; ++iMetadata) { - drwav_metadata* pMetadata = &pMetadatas[iMetadata]; - drwav_uint32 subchunkSize = 0; - if (pMetadata->type & drwav_metadata_type_list_all_info_strings) { - const char* pID = NULL; - switch (pMetadata->type) { - case drwav_metadata_type_list_info_software: pID = "ISFT"; break; - case drwav_metadata_type_list_info_copyright: pID = "ICOP"; break; - case drwav_metadata_type_list_info_title: pID = "INAM"; break; - case drwav_metadata_type_list_info_artist: pID = "IART"; break; - case drwav_metadata_type_list_info_comment: pID = "ICMT"; break; - case drwav_metadata_type_list_info_date: pID = "ICRD"; break; - case drwav_metadata_type_list_info_genre: pID = "IGNR"; break; - case drwav_metadata_type_list_info_album: pID = "IPRD"; break; - case drwav_metadata_type_list_info_tracknumber: pID = "ITRK"; break; - default: break; - } - DRWAV_ASSERT(pID != NULL); - if (pMetadata->data.infoText.stringLength) { - subchunkSize = pMetadata->data.infoText.stringLength + 1; - bytesWritten += drwav__write_or_count(pWav, pID, 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, subchunkSize); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.infoText.pString, pMetadata->data.infoText.stringLength); - bytesWritten += drwav__write_or_count_byte(pWav, '\0'); - } - } else if (pMetadata->type == drwav_metadata_type_unknown && pMetadata->data.unknown.chunkLocation == drwav_metadata_location_inside_info_list) { - if (pMetadata->data.unknown.dataSizeInBytes) { - subchunkSize = pMetadata->data.unknown.dataSizeInBytes; - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.unknown.id, 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.unknown.dataSizeInBytes); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.unknown.pData, subchunkSize); - } - } - if ((subchunkSize % 2) != 0) { - bytesWritten += drwav__write_or_count_byte(pWav, 0); - } - } - } - if (hasListAdtl) { - drwav_uint32 chunkSize = 4; - for (iMetadata = 0; iMetadata < metadataCount; ++iMetadata) { - drwav_metadata* pMetadata = &pMetadatas[iMetadata]; - switch (pMetadata->type) - { - case drwav_metadata_type_list_label: - case drwav_metadata_type_list_note: - { - chunkSize += 8; - chunkSize += DRWAV_LIST_LABEL_OR_NOTE_BYTES; - if (pMetadata->data.labelOrNote.stringLength > 0) { - chunkSize += pMetadata->data.labelOrNote.stringLength + 1; - } - } break; - case drwav_metadata_type_list_labelled_cue_region: - { - chunkSize += 8; - chunkSize += DRWAV_LIST_LABELLED_TEXT_BYTES; - if (pMetadata->data.labelledCueRegion.stringLength > 0) { - chunkSize += pMetadata->data.labelledCueRegion.stringLength + 1; - } - } break; - case drwav_metadata_type_unknown: - { - if (pMetadata->data.unknown.chunkLocation == drwav_metadata_location_inside_adtl_list) { - chunkSize += 8; - chunkSize += pMetadata->data.unknown.dataSizeInBytes; - } - } break; - default: break; - } - if ((chunkSize % 2) != 0) { - chunkSize += 1; - } - } - bytesWritten += drwav__write_or_count(pWav, "LIST", 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, chunkSize); - bytesWritten += drwav__write_or_count(pWav, "adtl", 4); - for (iMetadata = 0; iMetadata < metadataCount; ++iMetadata) { - drwav_metadata* pMetadata = &pMetadatas[iMetadata]; - drwav_uint32 subchunkSize = 0; - switch (pMetadata->type) - { - case drwav_metadata_type_list_label: - case drwav_metadata_type_list_note: - { - if (pMetadata->data.labelOrNote.stringLength > 0) { - const char *pID = NULL; - if (pMetadata->type == drwav_metadata_type_list_label) { - pID = "labl"; - } - else if (pMetadata->type == drwav_metadata_type_list_note) { - pID = "note"; - } - DRWAV_ASSERT(pID != NULL); - DRWAV_ASSERT(pMetadata->data.labelOrNote.pString != NULL); - subchunkSize = DRWAV_LIST_LABEL_OR_NOTE_BYTES; - bytesWritten += drwav__write_or_count(pWav, pID, 4); - subchunkSize += pMetadata->data.labelOrNote.stringLength + 1; - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, subchunkSize); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.labelOrNote.cuePointId); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.labelOrNote.pString, pMetadata->data.labelOrNote.stringLength); - bytesWritten += drwav__write_or_count_byte(pWav, '\0'); - } - } break; - case drwav_metadata_type_list_labelled_cue_region: - { - subchunkSize = DRWAV_LIST_LABELLED_TEXT_BYTES; - bytesWritten += drwav__write_or_count(pWav, "ltxt", 4); - if (pMetadata->data.labelledCueRegion.stringLength > 0) { - subchunkSize += pMetadata->data.labelledCueRegion.stringLength + 1; - } - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, subchunkSize); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.labelledCueRegion.cuePointId); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, pMetadata->data.labelledCueRegion.sampleLength); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.labelledCueRegion.purposeId, 4); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.labelledCueRegion.country); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.labelledCueRegion.language); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.labelledCueRegion.dialect); - bytesWritten += drwav__write_or_count_u16ne_to_le(pWav, pMetadata->data.labelledCueRegion.codePage); - if (pMetadata->data.labelledCueRegion.stringLength > 0) { - DRWAV_ASSERT(pMetadata->data.labelledCueRegion.pString != NULL); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.labelledCueRegion.pString, pMetadata->data.labelledCueRegion.stringLength); - bytesWritten += drwav__write_or_count_byte(pWav, '\0'); - } - } break; - case drwav_metadata_type_unknown: - { - if (pMetadata->data.unknown.chunkLocation == drwav_metadata_location_inside_adtl_list) { - subchunkSize = pMetadata->data.unknown.dataSizeInBytes; - DRWAV_ASSERT(pMetadata->data.unknown.pData != NULL); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.unknown.id, 4); - bytesWritten += drwav__write_or_count_u32ne_to_le(pWav, subchunkSize); - bytesWritten += drwav__write_or_count(pWav, pMetadata->data.unknown.pData, subchunkSize); - } - } break; - default: break; - } - if ((subchunkSize % 2) != 0) { - bytesWritten += drwav__write_or_count_byte(pWav, 0); - } - } - } - DRWAV_ASSERT((bytesWritten % 2) == 0); - return bytesWritten; -} -DRWAV_PRIVATE drwav_uint32 drwav__riff_chunk_size_riff(drwav_uint64 dataChunkSize, drwav_metadata* pMetadata, drwav_uint32 metadataCount) -{ - drwav_uint64 chunkSize = 4 + 24 + (drwav_uint64)drwav__write_or_count_metadata(NULL, pMetadata, metadataCount) + 8 + dataChunkSize + drwav__chunk_padding_size_riff(dataChunkSize); - if (chunkSize > 0xFFFFFFFFUL) { - chunkSize = 0xFFFFFFFFUL; - } - return (drwav_uint32)chunkSize; -} -DRWAV_PRIVATE drwav_uint32 drwav__data_chunk_size_riff(drwav_uint64 dataChunkSize) -{ - if (dataChunkSize <= 0xFFFFFFFFUL) { - return (drwav_uint32)dataChunkSize; - } else { - return 0xFFFFFFFFUL; - } -} -DRWAV_PRIVATE drwav_uint64 drwav__riff_chunk_size_w64(drwav_uint64 dataChunkSize) -{ - drwav_uint64 dataSubchunkPaddingSize = drwav__chunk_padding_size_w64(dataChunkSize); - return 80 + 24 + dataChunkSize + dataSubchunkPaddingSize; -} -DRWAV_PRIVATE drwav_uint64 drwav__data_chunk_size_w64(drwav_uint64 dataChunkSize) -{ - return 24 + dataChunkSize; -} -DRWAV_PRIVATE drwav_uint64 drwav__riff_chunk_size_rf64(drwav_uint64 dataChunkSize, drwav_metadata *metadata, drwav_uint32 numMetadata) -{ - drwav_uint64 chunkSize = 4 + 36 + 24 + (drwav_uint64)drwav__write_or_count_metadata(NULL, metadata, numMetadata) + 8 + dataChunkSize + drwav__chunk_padding_size_riff(dataChunkSize); - if (chunkSize > 0xFFFFFFFFUL) { - chunkSize = 0xFFFFFFFFUL; - } - return chunkSize; -} -DRWAV_PRIVATE drwav_uint64 drwav__data_chunk_size_rf64(drwav_uint64 dataChunkSize) -{ - return dataChunkSize; -} -DRWAV_PRIVATE drwav_bool32 drwav_preinit_write(drwav* pWav, const drwav_data_format* pFormat, drwav_bool32 isSequential, drwav_write_proc onWrite, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pWav == NULL || onWrite == NULL) { - return DRWAV_FALSE; - } - if (!isSequential && onSeek == NULL) { - return DRWAV_FALSE; - } - if (pFormat->format == DR_WAVE_FORMAT_EXTENSIBLE) { - return DRWAV_FALSE; - } - if (pFormat->format == DR_WAVE_FORMAT_ADPCM || pFormat->format == DR_WAVE_FORMAT_DVI_ADPCM) { - return DRWAV_FALSE; - } - DRWAV_ZERO_MEMORY(pWav, sizeof(*pWav)); - pWav->onWrite = onWrite; - pWav->onSeek = onSeek; - pWav->pUserData = pUserData; - pWav->allocationCallbacks = drwav_copy_allocation_callbacks_or_defaults(pAllocationCallbacks); - if (pWav->allocationCallbacks.onFree == NULL || (pWav->allocationCallbacks.onMalloc == NULL && pWav->allocationCallbacks.onRealloc == NULL)) { - return DRWAV_FALSE; - } - pWav->fmt.formatTag = (drwav_uint16)pFormat->format; - pWav->fmt.channels = (drwav_uint16)pFormat->channels; - pWav->fmt.sampleRate = pFormat->sampleRate; - pWav->fmt.avgBytesPerSec = (drwav_uint32)((pFormat->bitsPerSample * pFormat->sampleRate * pFormat->channels) / 8); - pWav->fmt.blockAlign = (drwav_uint16)((pFormat->channels * pFormat->bitsPerSample) / 8); - pWav->fmt.bitsPerSample = (drwav_uint16)pFormat->bitsPerSample; - pWav->fmt.extendedSize = 0; - pWav->isSequentialWrite = isSequential; - return DRWAV_TRUE; -} -DRWAV_PRIVATE drwav_bool32 drwav_init_write__internal(drwav* pWav, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount) -{ - size_t runningPos = 0; - drwav_uint64 initialDataChunkSize = 0; - drwav_uint64 chunkSizeFMT; - if (pWav->isSequentialWrite) { - initialDataChunkSize = (totalSampleCount * pWav->fmt.bitsPerSample) / 8; - if (pFormat->container == drwav_container_riff) { - if (initialDataChunkSize > (0xFFFFFFFFUL - 36)) { - return DRWAV_FALSE; - } - } - } - pWav->dataChunkDataSizeTargetWrite = initialDataChunkSize; - if (pFormat->container == drwav_container_riff) { - drwav_uint32 chunkSizeRIFF = 28 + (drwav_uint32)initialDataChunkSize; - runningPos += drwav__write(pWav, "RIFF", 4); - runningPos += drwav__write_u32ne_to_le(pWav, chunkSizeRIFF); - runningPos += drwav__write(pWav, "WAVE", 4); - } else if (pFormat->container == drwav_container_w64) { - drwav_uint64 chunkSizeRIFF = 80 + 24 + initialDataChunkSize; - runningPos += drwav__write(pWav, drwavGUID_W64_RIFF, 16); - runningPos += drwav__write_u64ne_to_le(pWav, chunkSizeRIFF); - runningPos += drwav__write(pWav, drwavGUID_W64_WAVE, 16); - } else if (pFormat->container == drwav_container_rf64) { - runningPos += drwav__write(pWav, "RF64", 4); - runningPos += drwav__write_u32ne_to_le(pWav, 0xFFFFFFFF); - runningPos += drwav__write(pWav, "WAVE", 4); - } - if (pFormat->container == drwav_container_rf64) { - drwav_uint32 initialds64ChunkSize = 28; - drwav_uint64 initialRiffChunkSize = 8 + initialds64ChunkSize + initialDataChunkSize; - runningPos += drwav__write(pWav, "ds64", 4); - runningPos += drwav__write_u32ne_to_le(pWav, initialds64ChunkSize); - runningPos += drwav__write_u64ne_to_le(pWav, initialRiffChunkSize); - runningPos += drwav__write_u64ne_to_le(pWav, initialDataChunkSize); - runningPos += drwav__write_u64ne_to_le(pWav, totalSampleCount); - runningPos += drwav__write_u32ne_to_le(pWav, 0); - } - if (pFormat->container == drwav_container_riff || pFormat->container == drwav_container_rf64) { - chunkSizeFMT = 16; - runningPos += drwav__write(pWav, "fmt ", 4); - runningPos += drwav__write_u32ne_to_le(pWav, (drwav_uint32)chunkSizeFMT); - } else if (pFormat->container == drwav_container_w64) { - chunkSizeFMT = 40; - runningPos += drwav__write(pWav, drwavGUID_W64_FMT, 16); - runningPos += drwav__write_u64ne_to_le(pWav, chunkSizeFMT); - } - runningPos += drwav__write_u16ne_to_le(pWav, pWav->fmt.formatTag); - runningPos += drwav__write_u16ne_to_le(pWav, pWav->fmt.channels); - runningPos += drwav__write_u32ne_to_le(pWav, pWav->fmt.sampleRate); - runningPos += drwav__write_u32ne_to_le(pWav, pWav->fmt.avgBytesPerSec); - runningPos += drwav__write_u16ne_to_le(pWav, pWav->fmt.blockAlign); - runningPos += drwav__write_u16ne_to_le(pWav, pWav->fmt.bitsPerSample); - if (!pWav->isSequentialWrite && pWav->pMetadata != NULL && pWav->metadataCount > 0 && (pFormat->container == drwav_container_riff || pFormat->container == drwav_container_rf64)) { - runningPos += drwav__write_or_count_metadata(pWav, pWav->pMetadata, pWav->metadataCount); - } - pWav->dataChunkDataPos = runningPos; - if (pFormat->container == drwav_container_riff) { - drwav_uint32 chunkSizeDATA = (drwav_uint32)initialDataChunkSize; - runningPos += drwav__write(pWav, "data", 4); - runningPos += drwav__write_u32ne_to_le(pWav, chunkSizeDATA); - } else if (pFormat->container == drwav_container_w64) { - drwav_uint64 chunkSizeDATA = 24 + initialDataChunkSize; - runningPos += drwav__write(pWav, drwavGUID_W64_DATA, 16); - runningPos += drwav__write_u64ne_to_le(pWav, chunkSizeDATA); - } else if (pFormat->container == drwav_container_rf64) { - runningPos += drwav__write(pWav, "data", 4); - runningPos += drwav__write_u32ne_to_le(pWav, 0xFFFFFFFF); - } - pWav->container = pFormat->container; - pWav->channels = (drwav_uint16)pFormat->channels; - pWav->sampleRate = pFormat->sampleRate; - pWav->bitsPerSample = (drwav_uint16)pFormat->bitsPerSample; - pWav->translatedFormatTag = (drwav_uint16)pFormat->format; - pWav->dataChunkDataPos = runningPos; - return DRWAV_TRUE; -} -DRWAV_API drwav_bool32 drwav_init_write(drwav* pWav, const drwav_data_format* pFormat, drwav_write_proc onWrite, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (!drwav_preinit_write(pWav, pFormat, DRWAV_FALSE, onWrite, onSeek, pUserData, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - return drwav_init_write__internal(pWav, pFormat, 0); -} -DRWAV_API drwav_bool32 drwav_init_write_sequential(drwav* pWav, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, drwav_write_proc onWrite, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (!drwav_preinit_write(pWav, pFormat, DRWAV_TRUE, onWrite, NULL, pUserData, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - return drwav_init_write__internal(pWav, pFormat, totalSampleCount); -} -DRWAV_API drwav_bool32 drwav_init_write_sequential_pcm_frames(drwav* pWav, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, drwav_write_proc onWrite, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pFormat == NULL) { - return DRWAV_FALSE; - } - return drwav_init_write_sequential(pWav, pFormat, totalPCMFrameCount*pFormat->channels, onWrite, pUserData, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_write_with_metadata(drwav* pWav, const drwav_data_format* pFormat, drwav_write_proc onWrite, drwav_seek_proc onSeek, void* pUserData, const drwav_allocation_callbacks* pAllocationCallbacks, drwav_metadata* pMetadata, drwav_uint32 metadataCount) -{ - if (!drwav_preinit_write(pWav, pFormat, DRWAV_FALSE, onWrite, onSeek, pUserData, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - pWav->pMetadata = pMetadata; - pWav->metadataCount = metadataCount; - return drwav_init_write__internal(pWav, pFormat, 0); -} -DRWAV_API drwav_uint64 drwav_target_write_size_bytes(const drwav_data_format* pFormat, drwav_uint64 totalFrameCount, drwav_metadata* pMetadata, drwav_uint32 metadataCount) -{ - drwav_uint64 targetDataSizeBytes = (drwav_uint64)((drwav_int64)totalFrameCount * pFormat->channels * pFormat->bitsPerSample/8.0); - drwav_uint64 riffChunkSizeBytes; - drwav_uint64 fileSizeBytes = 0; - if (pFormat->container == drwav_container_riff) { - riffChunkSizeBytes = drwav__riff_chunk_size_riff(targetDataSizeBytes, pMetadata, metadataCount); - fileSizeBytes = (8 + riffChunkSizeBytes); - } else if (pFormat->container == drwav_container_w64) { - riffChunkSizeBytes = drwav__riff_chunk_size_w64(targetDataSizeBytes); - fileSizeBytes = riffChunkSizeBytes; - } else if (pFormat->container == drwav_container_rf64) { - riffChunkSizeBytes = drwav__riff_chunk_size_rf64(targetDataSizeBytes, pMetadata, metadataCount); - fileSizeBytes = (8 + riffChunkSizeBytes); - } - return fileSizeBytes; -} -#ifndef DR_WAV_NO_STDIO -#include -DRWAV_PRIVATE drwav_result drwav_result_from_errno(int e) -{ - switch (e) - { - case 0: return DRWAV_SUCCESS; - #ifdef EPERM - case EPERM: return DRWAV_INVALID_OPERATION; - #endif - #ifdef ENOENT - case ENOENT: return DRWAV_DOES_NOT_EXIST; - #endif - #ifdef ESRCH - case ESRCH: return DRWAV_DOES_NOT_EXIST; - #endif - #ifdef EINTR - case EINTR: return DRWAV_INTERRUPT; - #endif - #ifdef EIO - case EIO: return DRWAV_IO_ERROR; - #endif - #ifdef ENXIO - case ENXIO: return DRWAV_DOES_NOT_EXIST; - #endif - #ifdef E2BIG - case E2BIG: return DRWAV_INVALID_ARGS; - #endif - #ifdef ENOEXEC - case ENOEXEC: return DRWAV_INVALID_FILE; - #endif - #ifdef EBADF - case EBADF: return DRWAV_INVALID_FILE; - #endif - #ifdef ECHILD - case ECHILD: return DRWAV_ERROR; - #endif - #ifdef EAGAIN - case EAGAIN: return DRWAV_UNAVAILABLE; - #endif - #ifdef ENOMEM - case ENOMEM: return DRWAV_OUT_OF_MEMORY; - #endif - #ifdef EACCES - case EACCES: return DRWAV_ACCESS_DENIED; - #endif - #ifdef EFAULT - case EFAULT: return DRWAV_BAD_ADDRESS; - #endif - #ifdef ENOTBLK - case ENOTBLK: return DRWAV_ERROR; - #endif - #ifdef EBUSY - case EBUSY: return DRWAV_BUSY; - #endif - #ifdef EEXIST - case EEXIST: return DRWAV_ALREADY_EXISTS; - #endif - #ifdef EXDEV - case EXDEV: return DRWAV_ERROR; - #endif - #ifdef ENODEV - case ENODEV: return DRWAV_DOES_NOT_EXIST; - #endif - #ifdef ENOTDIR - case ENOTDIR: return DRWAV_NOT_DIRECTORY; - #endif - #ifdef EISDIR - case EISDIR: return DRWAV_IS_DIRECTORY; - #endif - #ifdef EINVAL - case EINVAL: return DRWAV_INVALID_ARGS; - #endif - #ifdef ENFILE - case ENFILE: return DRWAV_TOO_MANY_OPEN_FILES; - #endif - #ifdef EMFILE - case EMFILE: return DRWAV_TOO_MANY_OPEN_FILES; - #endif - #ifdef ENOTTY - case ENOTTY: return DRWAV_INVALID_OPERATION; - #endif - #ifdef ETXTBSY - case ETXTBSY: return DRWAV_BUSY; - #endif - #ifdef EFBIG - case EFBIG: return DRWAV_TOO_BIG; - #endif - #ifdef ENOSPC - case ENOSPC: return DRWAV_NO_SPACE; - #endif - #ifdef ESPIPE - case ESPIPE: return DRWAV_BAD_SEEK; - #endif - #ifdef EROFS - case EROFS: return DRWAV_ACCESS_DENIED; - #endif - #ifdef EMLINK - case EMLINK: return DRWAV_TOO_MANY_LINKS; - #endif - #ifdef EPIPE - case EPIPE: return DRWAV_BAD_PIPE; - #endif - #ifdef EDOM - case EDOM: return DRWAV_OUT_OF_RANGE; - #endif - #ifdef ERANGE - case ERANGE: return DRWAV_OUT_OF_RANGE; - #endif - #ifdef EDEADLK - case EDEADLK: return DRWAV_DEADLOCK; - #endif - #ifdef ENAMETOOLONG - case ENAMETOOLONG: return DRWAV_PATH_TOO_LONG; - #endif - #ifdef ENOLCK - case ENOLCK: return DRWAV_ERROR; - #endif - #ifdef ENOSYS - case ENOSYS: return DRWAV_NOT_IMPLEMENTED; - #endif - #ifdef ENOTEMPTY - case ENOTEMPTY: return DRWAV_DIRECTORY_NOT_EMPTY; - #endif - #ifdef ELOOP - case ELOOP: return DRWAV_TOO_MANY_LINKS; - #endif - #ifdef ENOMSG - case ENOMSG: return DRWAV_NO_MESSAGE; - #endif - #ifdef EIDRM - case EIDRM: return DRWAV_ERROR; - #endif - #ifdef ECHRNG - case ECHRNG: return DRWAV_ERROR; - #endif - #ifdef EL2NSYNC - case EL2NSYNC: return DRWAV_ERROR; - #endif - #ifdef EL3HLT - case EL3HLT: return DRWAV_ERROR; - #endif - #ifdef EL3RST - case EL3RST: return DRWAV_ERROR; - #endif - #ifdef ELNRNG - case ELNRNG: return DRWAV_OUT_OF_RANGE; - #endif - #ifdef EUNATCH - case EUNATCH: return DRWAV_ERROR; - #endif - #ifdef ENOCSI - case ENOCSI: return DRWAV_ERROR; - #endif - #ifdef EL2HLT - case EL2HLT: return DRWAV_ERROR; - #endif - #ifdef EBADE - case EBADE: return DRWAV_ERROR; - #endif - #ifdef EBADR - case EBADR: return DRWAV_ERROR; - #endif - #ifdef EXFULL - case EXFULL: return DRWAV_ERROR; - #endif - #ifdef ENOANO - case ENOANO: return DRWAV_ERROR; - #endif - #ifdef EBADRQC - case EBADRQC: return DRWAV_ERROR; - #endif - #ifdef EBADSLT - case EBADSLT: return DRWAV_ERROR; - #endif - #ifdef EBFONT - case EBFONT: return DRWAV_INVALID_FILE; - #endif - #ifdef ENOSTR - case ENOSTR: return DRWAV_ERROR; - #endif - #ifdef ENODATA - case ENODATA: return DRWAV_NO_DATA_AVAILABLE; - #endif - #ifdef ETIME - case ETIME: return DRWAV_TIMEOUT; - #endif - #ifdef ENOSR - case ENOSR: return DRWAV_NO_DATA_AVAILABLE; - #endif - #ifdef ENONET - case ENONET: return DRWAV_NO_NETWORK; - #endif - #ifdef ENOPKG - case ENOPKG: return DRWAV_ERROR; - #endif - #ifdef EREMOTE - case EREMOTE: return DRWAV_ERROR; - #endif - #ifdef ENOLINK - case ENOLINK: return DRWAV_ERROR; - #endif - #ifdef EADV - case EADV: return DRWAV_ERROR; - #endif - #ifdef ESRMNT - case ESRMNT: return DRWAV_ERROR; - #endif - #ifdef ECOMM - case ECOMM: return DRWAV_ERROR; - #endif - #ifdef EPROTO - case EPROTO: return DRWAV_ERROR; - #endif - #ifdef EMULTIHOP - case EMULTIHOP: return DRWAV_ERROR; - #endif - #ifdef EDOTDOT - case EDOTDOT: return DRWAV_ERROR; - #endif - #ifdef EBADMSG - case EBADMSG: return DRWAV_BAD_MESSAGE; - #endif - #ifdef EOVERFLOW - case EOVERFLOW: return DRWAV_TOO_BIG; - #endif - #ifdef ENOTUNIQ - case ENOTUNIQ: return DRWAV_NOT_UNIQUE; - #endif - #ifdef EBADFD - case EBADFD: return DRWAV_ERROR; - #endif - #ifdef EREMCHG - case EREMCHG: return DRWAV_ERROR; - #endif - #ifdef ELIBACC - case ELIBACC: return DRWAV_ACCESS_DENIED; - #endif - #ifdef ELIBBAD - case ELIBBAD: return DRWAV_INVALID_FILE; - #endif - #ifdef ELIBSCN - case ELIBSCN: return DRWAV_INVALID_FILE; - #endif - #ifdef ELIBMAX - case ELIBMAX: return DRWAV_ERROR; - #endif - #ifdef ELIBEXEC - case ELIBEXEC: return DRWAV_ERROR; - #endif - #ifdef EILSEQ - case EILSEQ: return DRWAV_INVALID_DATA; - #endif - #ifdef ERESTART - case ERESTART: return DRWAV_ERROR; - #endif - #ifdef ESTRPIPE - case ESTRPIPE: return DRWAV_ERROR; - #endif - #ifdef EUSERS - case EUSERS: return DRWAV_ERROR; - #endif - #ifdef ENOTSOCK - case ENOTSOCK: return DRWAV_NOT_SOCKET; - #endif - #ifdef EDESTADDRREQ - case EDESTADDRREQ: return DRWAV_NO_ADDRESS; - #endif - #ifdef EMSGSIZE - case EMSGSIZE: return DRWAV_TOO_BIG; - #endif - #ifdef EPROTOTYPE - case EPROTOTYPE: return DRWAV_BAD_PROTOCOL; - #endif - #ifdef ENOPROTOOPT - case ENOPROTOOPT: return DRWAV_PROTOCOL_UNAVAILABLE; - #endif - #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return DRWAV_PROTOCOL_NOT_SUPPORTED; - #endif - #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return DRWAV_SOCKET_NOT_SUPPORTED; - #endif - #ifdef EOPNOTSUPP - case EOPNOTSUPP: return DRWAV_INVALID_OPERATION; - #endif - #ifdef EPFNOSUPPORT - case EPFNOSUPPORT: return DRWAV_PROTOCOL_FAMILY_NOT_SUPPORTED; - #endif - #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return DRWAV_ADDRESS_FAMILY_NOT_SUPPORTED; - #endif - #ifdef EADDRINUSE - case EADDRINUSE: return DRWAV_ALREADY_IN_USE; - #endif - #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return DRWAV_ERROR; - #endif - #ifdef ENETDOWN - case ENETDOWN: return DRWAV_NO_NETWORK; - #endif - #ifdef ENETUNREACH - case ENETUNREACH: return DRWAV_NO_NETWORK; - #endif - #ifdef ENETRESET - case ENETRESET: return DRWAV_NO_NETWORK; - #endif - #ifdef ECONNABORTED - case ECONNABORTED: return DRWAV_NO_NETWORK; - #endif - #ifdef ECONNRESET - case ECONNRESET: return DRWAV_CONNECTION_RESET; - #endif - #ifdef ENOBUFS - case ENOBUFS: return DRWAV_NO_SPACE; - #endif - #ifdef EISCONN - case EISCONN: return DRWAV_ALREADY_CONNECTED; - #endif - #ifdef ENOTCONN - case ENOTCONN: return DRWAV_NOT_CONNECTED; - #endif - #ifdef ESHUTDOWN - case ESHUTDOWN: return DRWAV_ERROR; - #endif - #ifdef ETOOMANYREFS - case ETOOMANYREFS: return DRWAV_ERROR; - #endif - #ifdef ETIMEDOUT - case ETIMEDOUT: return DRWAV_TIMEOUT; - #endif - #ifdef ECONNREFUSED - case ECONNREFUSED: return DRWAV_CONNECTION_REFUSED; - #endif - #ifdef EHOSTDOWN - case EHOSTDOWN: return DRWAV_NO_HOST; - #endif - #ifdef EHOSTUNREACH - case EHOSTUNREACH: return DRWAV_NO_HOST; - #endif - #ifdef EALREADY - case EALREADY: return DRWAV_IN_PROGRESS; - #endif - #ifdef EINPROGRESS - case EINPROGRESS: return DRWAV_IN_PROGRESS; - #endif - #ifdef ESTALE - case ESTALE: return DRWAV_INVALID_FILE; - #endif - #ifdef EUCLEAN - case EUCLEAN: return DRWAV_ERROR; - #endif - #ifdef ENOTNAM - case ENOTNAM: return DRWAV_ERROR; - #endif - #ifdef ENAVAIL - case ENAVAIL: return DRWAV_ERROR; - #endif - #ifdef EISNAM - case EISNAM: return DRWAV_ERROR; - #endif - #ifdef EREMOTEIO - case EREMOTEIO: return DRWAV_IO_ERROR; - #endif - #ifdef EDQUOT - case EDQUOT: return DRWAV_NO_SPACE; - #endif - #ifdef ENOMEDIUM - case ENOMEDIUM: return DRWAV_DOES_NOT_EXIST; - #endif - #ifdef EMEDIUMTYPE - case EMEDIUMTYPE: return DRWAV_ERROR; - #endif - #ifdef ECANCELED - case ECANCELED: return DRWAV_CANCELLED; - #endif - #ifdef ENOKEY - case ENOKEY: return DRWAV_ERROR; - #endif - #ifdef EKEYEXPIRED - case EKEYEXPIRED: return DRWAV_ERROR; - #endif - #ifdef EKEYREVOKED - case EKEYREVOKED: return DRWAV_ERROR; - #endif - #ifdef EKEYREJECTED - case EKEYREJECTED: return DRWAV_ERROR; - #endif - #ifdef EOWNERDEAD - case EOWNERDEAD: return DRWAV_ERROR; - #endif - #ifdef ENOTRECOVERABLE - case ENOTRECOVERABLE: return DRWAV_ERROR; - #endif - #ifdef ERFKILL - case ERFKILL: return DRWAV_ERROR; - #endif - #ifdef EHWPOISON - case EHWPOISON: return DRWAV_ERROR; - #endif - default: return DRWAV_ERROR; - } -} -DRWAV_PRIVATE drwav_result drwav_fopen(FILE** ppFile, const char* pFilePath, const char* pOpenMode) -{ -#if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err; -#endif - if (ppFile != NULL) { - *ppFile = NULL; - } - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return DRWAV_INVALID_ARGS; - } -#if defined(_MSC_VER) && _MSC_VER >= 1400 - err = fopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return drwav_result_from_errno(err); - } -#else -#if defined(_WIN32) || defined(__APPLE__) - *ppFile = fopen(pFilePath, pOpenMode); -#else - #if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64 && defined(_LARGEFILE64_SOURCE) - *ppFile = fopen64(pFilePath, pOpenMode); - #else - *ppFile = fopen(pFilePath, pOpenMode); - #endif -#endif - if (*ppFile == NULL) { - drwav_result result = drwav_result_from_errno(errno); - if (result == DRWAV_SUCCESS) { - result = DRWAV_ERROR; - } - return result; - } -#endif - return DRWAV_SUCCESS; -} -#if defined(_WIN32) - #if defined(_MSC_VER) || defined(__MINGW64__) || (!defined(__STRICT_ANSI__) && !defined(_NO_EXT_KEYS)) - #define DRWAV_HAS_WFOPEN - #endif -#endif -#ifndef DR_WAV_NO_WCHAR -DRWAV_PRIVATE drwav_result drwav_wfopen(FILE** ppFile, const wchar_t* pFilePath, const wchar_t* pOpenMode, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (ppFile != NULL) { - *ppFile = NULL; - } - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return DRWAV_INVALID_ARGS; - } -#if defined(DRWAV_HAS_WFOPEN) - { - #if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err = _wfopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return drwav_result_from_errno(err); - } - #else - *ppFile = _wfopen(pFilePath, pOpenMode); - if (*ppFile == NULL) { - return drwav_result_from_errno(errno); - } - #endif - (void)pAllocationCallbacks; - } -#else - #if defined(__DJGPP__) - { - } - #else - { - mbstate_t mbs; - size_t lenMB; - const wchar_t* pFilePathTemp = pFilePath; - char* pFilePathMB = NULL; - char pOpenModeMB[32] = {0}; - DRWAV_ZERO_OBJECT(&mbs); - lenMB = wcsrtombs(NULL, &pFilePathTemp, 0, &mbs); - if (lenMB == (size_t)-1) { - return drwav_result_from_errno(errno); - } - pFilePathMB = (char*)drwav__malloc_from_callbacks(lenMB + 1, pAllocationCallbacks); - if (pFilePathMB == NULL) { - return DRWAV_OUT_OF_MEMORY; - } - pFilePathTemp = pFilePath; - DRWAV_ZERO_OBJECT(&mbs); - wcsrtombs(pFilePathMB, &pFilePathTemp, lenMB + 1, &mbs); - { - size_t i = 0; - for (;;) { - if (pOpenMode[i] == 0) { - pOpenModeMB[i] = '\0'; - break; - } - pOpenModeMB[i] = (char)pOpenMode[i]; - i += 1; - } - } - *ppFile = fopen(pFilePathMB, pOpenModeMB); - drwav__free_from_callbacks(pFilePathMB, pAllocationCallbacks); - } - #endif - if (*ppFile == NULL) { - return DRWAV_ERROR; - } -#endif - return DRWAV_SUCCESS; -} -#endif -DRWAV_PRIVATE size_t drwav__on_read_stdio(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - return fread(pBufferOut, 1, bytesToRead, (FILE*)pUserData); -} -DRWAV_PRIVATE size_t drwav__on_write_stdio(void* pUserData, const void* pData, size_t bytesToWrite) -{ - return fwrite(pData, 1, bytesToWrite, (FILE*)pUserData); -} -DRWAV_PRIVATE drwav_bool32 drwav__on_seek_stdio(void* pUserData, int offset, drwav_seek_origin origin) -{ - return fseek((FILE*)pUserData, offset, (origin == drwav_seek_origin_current) ? SEEK_CUR : SEEK_SET) == 0; -} -DRWAV_API drwav_bool32 drwav_init_file(drwav* pWav, const char* filename, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_file_ex(pWav, filename, NULL, NULL, 0, pAllocationCallbacks); -} -DRWAV_PRIVATE drwav_bool32 drwav_init_file__internal_FILE(drwav* pWav, FILE* pFile, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, drwav_metadata_type allowedMetadataTypes, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav_bool32 result; - result = drwav_preinit(pWav, drwav__on_read_stdio, drwav__on_seek_stdio, (void*)pFile, pAllocationCallbacks); - if (result != DRWAV_TRUE) { - fclose(pFile); - return result; - } - pWav->allowedMetadataTypes = allowedMetadataTypes; - result = drwav_init__internal(pWav, onChunk, pChunkUserData, flags); - if (result != DRWAV_TRUE) { - fclose(pFile); - return result; - } - return DRWAV_TRUE; -} -DRWAV_API drwav_bool32 drwav_init_file_ex(drwav* pWav, const char* filename, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - FILE* pFile; - if (drwav_fopen(&pFile, filename, "rb") != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - return drwav_init_file__internal_FILE(pWav, pFile, onChunk, pChunkUserData, flags, drwav_metadata_type_none, pAllocationCallbacks); -} -#ifndef DR_WAV_NO_WCHAR -DRWAV_API drwav_bool32 drwav_init_file_w(drwav* pWav, const wchar_t* filename, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_file_ex_w(pWav, filename, NULL, NULL, 0, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_file_ex_w(drwav* pWav, const wchar_t* filename, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - FILE* pFile; - if (drwav_wfopen(&pFile, filename, L"rb", pAllocationCallbacks) != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - return drwav_init_file__internal_FILE(pWav, pFile, onChunk, pChunkUserData, flags, drwav_metadata_type_none, pAllocationCallbacks); -} -#endif -DRWAV_API drwav_bool32 drwav_init_file_with_metadata(drwav* pWav, const char* filename, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - FILE* pFile; - if (drwav_fopen(&pFile, filename, "rb") != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - return drwav_init_file__internal_FILE(pWav, pFile, NULL, NULL, flags, drwav_metadata_type_all_including_unknown, pAllocationCallbacks); -} -#ifndef DR_WAV_NO_WCHAR -DRWAV_API drwav_bool32 drwav_init_file_with_metadata_w(drwav* pWav, const wchar_t* filename, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - FILE* pFile; - if (drwav_wfopen(&pFile, filename, L"rb", pAllocationCallbacks) != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - return drwav_init_file__internal_FILE(pWav, pFile, NULL, NULL, flags, drwav_metadata_type_all_including_unknown, pAllocationCallbacks); -} -#endif -DRWAV_PRIVATE drwav_bool32 drwav_init_file_write__internal_FILE(drwav* pWav, FILE* pFile, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, drwav_bool32 isSequential, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav_bool32 result; - result = drwav_preinit_write(pWav, pFormat, isSequential, drwav__on_write_stdio, drwav__on_seek_stdio, (void*)pFile, pAllocationCallbacks); - if (result != DRWAV_TRUE) { - fclose(pFile); - return result; - } - result = drwav_init_write__internal(pWav, pFormat, totalSampleCount); - if (result != DRWAV_TRUE) { - fclose(pFile); - return result; - } - return DRWAV_TRUE; -} -DRWAV_PRIVATE drwav_bool32 drwav_init_file_write__internal(drwav* pWav, const char* filename, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, drwav_bool32 isSequential, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - FILE* pFile; - if (drwav_fopen(&pFile, filename, "wb") != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - return drwav_init_file_write__internal_FILE(pWav, pFile, pFormat, totalSampleCount, isSequential, pAllocationCallbacks); -} -#ifndef DR_WAV_NO_WCHAR -DRWAV_PRIVATE drwav_bool32 drwav_init_file_write_w__internal(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, drwav_bool32 isSequential, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - FILE* pFile; - if (drwav_wfopen(&pFile, filename, L"wb", pAllocationCallbacks) != DRWAV_SUCCESS) { - return DRWAV_FALSE; - } - return drwav_init_file_write__internal_FILE(pWav, pFile, pFormat, totalSampleCount, isSequential, pAllocationCallbacks); -} -#endif -DRWAV_API drwav_bool32 drwav_init_file_write(drwav* pWav, const char* filename, const drwav_data_format* pFormat, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_file_write__internal(pWav, filename, pFormat, 0, DRWAV_FALSE, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_file_write_sequential(drwav* pWav, const char* filename, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_file_write__internal(pWav, filename, pFormat, totalSampleCount, DRWAV_TRUE, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_file_write_sequential_pcm_frames(drwav* pWav, const char* filename, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pFormat == NULL) { - return DRWAV_FALSE; - } - return drwav_init_file_write_sequential(pWav, filename, pFormat, totalPCMFrameCount*pFormat->channels, pAllocationCallbacks); -} -#ifndef DR_WAV_NO_WCHAR -DRWAV_API drwav_bool32 drwav_init_file_write_w(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_file_write_w__internal(pWav, filename, pFormat, 0, DRWAV_FALSE, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_file_write_sequential_w(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_file_write_w__internal(pWav, filename, pFormat, totalSampleCount, DRWAV_TRUE, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_file_write_sequential_pcm_frames_w(drwav* pWav, const wchar_t* filename, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pFormat == NULL) { - return DRWAV_FALSE; - } - return drwav_init_file_write_sequential_w(pWav, filename, pFormat, totalPCMFrameCount*pFormat->channels, pAllocationCallbacks); -} -#endif -#endif -DRWAV_PRIVATE size_t drwav__on_read_memory(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - drwav* pWav = (drwav*)pUserData; - size_t bytesRemaining; - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->memoryStream.dataSize >= pWav->memoryStream.currentReadPos); - bytesRemaining = pWav->memoryStream.dataSize - pWav->memoryStream.currentReadPos; - if (bytesToRead > bytesRemaining) { - bytesToRead = bytesRemaining; - } - if (bytesToRead > 0) { - DRWAV_COPY_MEMORY(pBufferOut, pWav->memoryStream.data + pWav->memoryStream.currentReadPos, bytesToRead); - pWav->memoryStream.currentReadPos += bytesToRead; - } - return bytesToRead; -} -DRWAV_PRIVATE drwav_bool32 drwav__on_seek_memory(void* pUserData, int offset, drwav_seek_origin origin) -{ - drwav* pWav = (drwav*)pUserData; - DRWAV_ASSERT(pWav != NULL); - if (origin == drwav_seek_origin_current) { - if (offset > 0) { - if (pWav->memoryStream.currentReadPos + offset > pWav->memoryStream.dataSize) { - return DRWAV_FALSE; - } - } else { - if (pWav->memoryStream.currentReadPos < (size_t)-offset) { - return DRWAV_FALSE; - } - } - pWav->memoryStream.currentReadPos += offset; - } else { - if ((drwav_uint32)offset <= pWav->memoryStream.dataSize) { - pWav->memoryStream.currentReadPos = offset; - } else { - return DRWAV_FALSE; - } - } - return DRWAV_TRUE; -} -DRWAV_PRIVATE size_t drwav__on_write_memory(void* pUserData, const void* pDataIn, size_t bytesToWrite) -{ - drwav* pWav = (drwav*)pUserData; - size_t bytesRemaining; - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(pWav->memoryStreamWrite.dataCapacity >= pWav->memoryStreamWrite.currentWritePos); - bytesRemaining = pWav->memoryStreamWrite.dataCapacity - pWav->memoryStreamWrite.currentWritePos; - if (bytesRemaining < bytesToWrite) { - void* pNewData; - size_t newDataCapacity = (pWav->memoryStreamWrite.dataCapacity == 0) ? 256 : pWav->memoryStreamWrite.dataCapacity * 2; - if ((newDataCapacity - pWav->memoryStreamWrite.currentWritePos) < bytesToWrite) { - newDataCapacity = pWav->memoryStreamWrite.currentWritePos + bytesToWrite; - } - pNewData = drwav__realloc_from_callbacks(*pWav->memoryStreamWrite.ppData, newDataCapacity, pWav->memoryStreamWrite.dataCapacity, &pWav->allocationCallbacks); - if (pNewData == NULL) { - return 0; - } - *pWav->memoryStreamWrite.ppData = pNewData; - pWav->memoryStreamWrite.dataCapacity = newDataCapacity; - } - DRWAV_COPY_MEMORY(((drwav_uint8*)(*pWav->memoryStreamWrite.ppData)) + pWav->memoryStreamWrite.currentWritePos, pDataIn, bytesToWrite); - pWav->memoryStreamWrite.currentWritePos += bytesToWrite; - if (pWav->memoryStreamWrite.dataSize < pWav->memoryStreamWrite.currentWritePos) { - pWav->memoryStreamWrite.dataSize = pWav->memoryStreamWrite.currentWritePos; - } - *pWav->memoryStreamWrite.pDataSize = pWav->memoryStreamWrite.dataSize; - return bytesToWrite; -} -DRWAV_PRIVATE drwav_bool32 drwav__on_seek_memory_write(void* pUserData, int offset, drwav_seek_origin origin) -{ - drwav* pWav = (drwav*)pUserData; - DRWAV_ASSERT(pWav != NULL); - if (origin == drwav_seek_origin_current) { - if (offset > 0) { - if (pWav->memoryStreamWrite.currentWritePos + offset > pWav->memoryStreamWrite.dataSize) { - offset = (int)(pWav->memoryStreamWrite.dataSize - pWav->memoryStreamWrite.currentWritePos); - } - } else { - if (pWav->memoryStreamWrite.currentWritePos < (size_t)-offset) { - offset = -(int)pWav->memoryStreamWrite.currentWritePos; - } - } - pWav->memoryStreamWrite.currentWritePos += offset; - } else { - if ((drwav_uint32)offset <= pWav->memoryStreamWrite.dataSize) { - pWav->memoryStreamWrite.currentWritePos = offset; - } else { - pWav->memoryStreamWrite.currentWritePos = pWav->memoryStreamWrite.dataSize; - } - } - return DRWAV_TRUE; -} -DRWAV_API drwav_bool32 drwav_init_memory(drwav* pWav, const void* data, size_t dataSize, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_memory_ex(pWav, data, dataSize, NULL, NULL, 0, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_memory_ex(drwav* pWav, const void* data, size_t dataSize, drwav_chunk_proc onChunk, void* pChunkUserData, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (data == NULL || dataSize == 0) { - return DRWAV_FALSE; - } - if (!drwav_preinit(pWav, drwav__on_read_memory, drwav__on_seek_memory, pWav, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - pWav->memoryStream.data = (const drwav_uint8*)data; - pWav->memoryStream.dataSize = dataSize; - pWav->memoryStream.currentReadPos = 0; - return drwav_init__internal(pWav, onChunk, pChunkUserData, flags); -} -DRWAV_API drwav_bool32 drwav_init_memory_with_metadata(drwav* pWav, const void* data, size_t dataSize, drwav_uint32 flags, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (data == NULL || dataSize == 0) { - return DRWAV_FALSE; - } - if (!drwav_preinit(pWav, drwav__on_read_memory, drwav__on_seek_memory, pWav, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - pWav->memoryStream.data = (const drwav_uint8*)data; - pWav->memoryStream.dataSize = dataSize; - pWav->memoryStream.currentReadPos = 0; - pWav->allowedMetadataTypes = drwav_metadata_type_all_including_unknown; - return drwav_init__internal(pWav, NULL, NULL, flags); -} -DRWAV_PRIVATE drwav_bool32 drwav_init_memory_write__internal(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, drwav_bool32 isSequential, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (ppData == NULL || pDataSize == NULL) { - return DRWAV_FALSE; - } - *ppData = NULL; - *pDataSize = 0; - if (!drwav_preinit_write(pWav, pFormat, isSequential, drwav__on_write_memory, drwav__on_seek_memory_write, pWav, pAllocationCallbacks)) { - return DRWAV_FALSE; - } - pWav->memoryStreamWrite.ppData = ppData; - pWav->memoryStreamWrite.pDataSize = pDataSize; - pWav->memoryStreamWrite.dataSize = 0; - pWav->memoryStreamWrite.dataCapacity = 0; - pWav->memoryStreamWrite.currentWritePos = 0; - return drwav_init_write__internal(pWav, pFormat, totalSampleCount); -} -DRWAV_API drwav_bool32 drwav_init_memory_write(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_memory_write__internal(pWav, ppData, pDataSize, pFormat, 0, DRWAV_FALSE, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_memory_write_sequential(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, drwav_uint64 totalSampleCount, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - return drwav_init_memory_write__internal(pWav, ppData, pDataSize, pFormat, totalSampleCount, DRWAV_TRUE, pAllocationCallbacks); -} -DRWAV_API drwav_bool32 drwav_init_memory_write_sequential_pcm_frames(drwav* pWav, void** ppData, size_t* pDataSize, const drwav_data_format* pFormat, drwav_uint64 totalPCMFrameCount, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pFormat == NULL) { - return DRWAV_FALSE; - } - return drwav_init_memory_write_sequential(pWav, ppData, pDataSize, pFormat, totalPCMFrameCount*pFormat->channels, pAllocationCallbacks); -} -DRWAV_API drwav_result drwav_uninit(drwav* pWav) -{ - drwav_result result = DRWAV_SUCCESS; - if (pWav == NULL) { - return DRWAV_INVALID_ARGS; - } - if (pWav->onWrite != NULL) { - drwav_uint32 paddingSize = 0; - if (pWav->container == drwav_container_riff || pWav->container == drwav_container_rf64) { - paddingSize = drwav__chunk_padding_size_riff(pWav->dataChunkDataSize); - } else { - paddingSize = drwav__chunk_padding_size_w64(pWav->dataChunkDataSize); - } - if (paddingSize > 0) { - drwav_uint64 paddingData = 0; - drwav__write(pWav, &paddingData, paddingSize); - } - if (pWav->onSeek && !pWav->isSequentialWrite) { - if (pWav->container == drwav_container_riff) { - if (pWav->onSeek(pWav->pUserData, 4, drwav_seek_origin_start)) { - drwav_uint32 riffChunkSize = drwav__riff_chunk_size_riff(pWav->dataChunkDataSize, pWav->pMetadata, pWav->metadataCount); - drwav__write_u32ne_to_le(pWav, riffChunkSize); - } - if (pWav->onSeek(pWav->pUserData, (int)pWav->dataChunkDataPos - 4, drwav_seek_origin_start)) { - drwav_uint32 dataChunkSize = drwav__data_chunk_size_riff(pWav->dataChunkDataSize); - drwav__write_u32ne_to_le(pWav, dataChunkSize); - } - } else if (pWav->container == drwav_container_w64) { - if (pWav->onSeek(pWav->pUserData, 16, drwav_seek_origin_start)) { - drwav_uint64 riffChunkSize = drwav__riff_chunk_size_w64(pWav->dataChunkDataSize); - drwav__write_u64ne_to_le(pWav, riffChunkSize); - } - if (pWav->onSeek(pWav->pUserData, (int)pWav->dataChunkDataPos - 8, drwav_seek_origin_start)) { - drwav_uint64 dataChunkSize = drwav__data_chunk_size_w64(pWav->dataChunkDataSize); - drwav__write_u64ne_to_le(pWav, dataChunkSize); - } - } else if (pWav->container == drwav_container_rf64) { - int ds64BodyPos = 12 + 8; - if (pWav->onSeek(pWav->pUserData, ds64BodyPos + 0, drwav_seek_origin_start)) { - drwav_uint64 riffChunkSize = drwav__riff_chunk_size_rf64(pWav->dataChunkDataSize, pWav->pMetadata, pWav->metadataCount); - drwav__write_u64ne_to_le(pWav, riffChunkSize); - } - if (pWav->onSeek(pWav->pUserData, ds64BodyPos + 8, drwav_seek_origin_start)) { - drwav_uint64 dataChunkSize = drwav__data_chunk_size_rf64(pWav->dataChunkDataSize); - drwav__write_u64ne_to_le(pWav, dataChunkSize); - } - } - } - if (pWav->isSequentialWrite) { - if (pWav->dataChunkDataSize != pWav->dataChunkDataSizeTargetWrite) { - result = DRWAV_INVALID_FILE; - } - } - } else { - if (pWav->pMetadata != NULL) { - pWav->allocationCallbacks.onFree(pWav->pMetadata, pWav->allocationCallbacks.pUserData); - } - } -#ifndef DR_WAV_NO_STDIO - if (pWav->onRead == drwav__on_read_stdio || pWav->onWrite == drwav__on_write_stdio) { - fclose((FILE*)pWav->pUserData); - } -#endif - return result; -} -DRWAV_API size_t drwav_read_raw(drwav* pWav, size_t bytesToRead, void* pBufferOut) -{ - size_t bytesRead; - drwav_uint32 bytesPerFrame; - if (pWav == NULL || bytesToRead == 0) { - return 0; - } - if (bytesToRead > pWav->bytesRemaining) { - bytesToRead = (size_t)pWav->bytesRemaining; - } - if (bytesToRead == 0) { - return 0; - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - if (pBufferOut != NULL) { - bytesRead = pWav->onRead(pWav->pUserData, pBufferOut, bytesToRead); - } else { - bytesRead = 0; - while (bytesRead < bytesToRead) { - size_t bytesToSeek = (bytesToRead - bytesRead); - if (bytesToSeek > 0x7FFFFFFF) { - bytesToSeek = 0x7FFFFFFF; - } - if (pWav->onSeek(pWav->pUserData, (int)bytesToSeek, drwav_seek_origin_current) == DRWAV_FALSE) { - break; - } - bytesRead += bytesToSeek; - } - while (bytesRead < bytesToRead) { - drwav_uint8 buffer[4096]; - size_t bytesSeeked; - size_t bytesToSeek = (bytesToRead - bytesRead); - if (bytesToSeek > sizeof(buffer)) { - bytesToSeek = sizeof(buffer); - } - bytesSeeked = pWav->onRead(pWav->pUserData, buffer, bytesToSeek); - bytesRead += bytesSeeked; - if (bytesSeeked < bytesToSeek) { - break; - } - } - } - pWav->readCursorInPCMFrames += bytesRead / bytesPerFrame; - pWav->bytesRemaining -= bytesRead; - return bytesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_le(drwav* pWav, drwav_uint64 framesToRead, void* pBufferOut) -{ - drwav_uint32 bytesPerFrame; - drwav_uint64 bytesToRead; - if (pWav == NULL || framesToRead == 0) { - return 0; - } - if (drwav__is_compressed_format_tag(pWav->translatedFormatTag)) { - return 0; - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesToRead = framesToRead * bytesPerFrame; - if (bytesToRead > DRWAV_SIZE_MAX) { - bytesToRead = (DRWAV_SIZE_MAX / bytesPerFrame) * bytesPerFrame; - } - if (bytesToRead == 0) { - return 0; - } - return drwav_read_raw(pWav, (size_t)bytesToRead, pBufferOut) / bytesPerFrame; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_be(drwav* pWav, drwav_uint64 framesToRead, void* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_le(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL) { - drwav_uint32 bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - drwav__bswap_samples(pBufferOut, framesRead*pWav->channels, bytesPerFrame/pWav->channels, pWav->translatedFormatTag); - } - return framesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames(drwav* pWav, drwav_uint64 framesToRead, void* pBufferOut) -{ - if (drwav__is_little_endian()) { - return drwav_read_pcm_frames_le(pWav, framesToRead, pBufferOut); - } else { - return drwav_read_pcm_frames_be(pWav, framesToRead, pBufferOut); - } -} -DRWAV_PRIVATE drwav_bool32 drwav_seek_to_first_pcm_frame(drwav* pWav) -{ - if (pWav->onWrite != NULL) { - return DRWAV_FALSE; - } - if (!pWav->onSeek(pWav->pUserData, (int)pWav->dataChunkDataPos, drwav_seek_origin_start)) { - return DRWAV_FALSE; - } - if (drwav__is_compressed_format_tag(pWav->translatedFormatTag)) { - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM) { - DRWAV_ZERO_OBJECT(&pWav->msadpcm); - } else if (pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - DRWAV_ZERO_OBJECT(&pWav->ima); - } else { - DRWAV_ASSERT(DRWAV_FALSE); - } - } - pWav->readCursorInPCMFrames = 0; - pWav->bytesRemaining = pWav->dataChunkDataSize; - return DRWAV_TRUE; -} -DRWAV_API drwav_bool32 drwav_seek_to_pcm_frame(drwav* pWav, drwav_uint64 targetFrameIndex) -{ - if (pWav == NULL || pWav->onSeek == NULL) { - return DRWAV_FALSE; - } - if (pWav->onWrite != NULL) { - return DRWAV_FALSE; - } - if (pWav->totalPCMFrameCount == 0) { - return DRWAV_TRUE; - } - if (targetFrameIndex > pWav->totalPCMFrameCount) { - targetFrameIndex = pWav->totalPCMFrameCount; - } - if (drwav__is_compressed_format_tag(pWav->translatedFormatTag)) { - if (targetFrameIndex < pWav->readCursorInPCMFrames) { - if (!drwav_seek_to_first_pcm_frame(pWav)) { - return DRWAV_FALSE; - } - } - if (targetFrameIndex > pWav->readCursorInPCMFrames) { - drwav_uint64 offsetInFrames = targetFrameIndex - pWav->readCursorInPCMFrames; - drwav_int16 devnull[2048]; - while (offsetInFrames > 0) { - drwav_uint64 framesRead = 0; - drwav_uint64 framesToRead = offsetInFrames; - if (framesToRead > drwav_countof(devnull)/pWav->channels) { - framesToRead = drwav_countof(devnull)/pWav->channels; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM) { - framesRead = drwav_read_pcm_frames_s16__msadpcm(pWav, framesToRead, devnull); - } else if (pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - framesRead = drwav_read_pcm_frames_s16__ima(pWav, framesToRead, devnull); - } else { - DRWAV_ASSERT(DRWAV_FALSE); - } - if (framesRead != framesToRead) { - return DRWAV_FALSE; - } - offsetInFrames -= framesRead; - } - } - } else { - drwav_uint64 totalSizeInBytes; - drwav_uint64 currentBytePos; - drwav_uint64 targetBytePos; - drwav_uint64 offset; - drwav_uint32 bytesPerFrame; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return DRWAV_FALSE; - } - totalSizeInBytes = pWav->totalPCMFrameCount * bytesPerFrame; - DRWAV_ASSERT(totalSizeInBytes >= pWav->bytesRemaining); - currentBytePos = totalSizeInBytes - pWav->bytesRemaining; - targetBytePos = targetFrameIndex * bytesPerFrame; - if (currentBytePos < targetBytePos) { - offset = (targetBytePos - currentBytePos); - } else { - if (!drwav_seek_to_first_pcm_frame(pWav)) { - return DRWAV_FALSE; - } - offset = targetBytePos; - } - while (offset > 0) { - int offset32 = ((offset > INT_MAX) ? INT_MAX : (int)offset); - if (!pWav->onSeek(pWav->pUserData, offset32, drwav_seek_origin_current)) { - return DRWAV_FALSE; - } - pWav->readCursorInPCMFrames += offset32 / bytesPerFrame; - pWav->bytesRemaining -= offset32; - offset -= offset32; - } - } - return DRWAV_TRUE; -} -DRWAV_API drwav_result drwav_get_cursor_in_pcm_frames(drwav* pWav, drwav_uint64* pCursor) -{ - if (pCursor == NULL) { - return DRWAV_INVALID_ARGS; - } - *pCursor = 0; - if (pWav == NULL) { - return DRWAV_INVALID_ARGS; - } - *pCursor = pWav->readCursorInPCMFrames; - return DRWAV_SUCCESS; -} -DRWAV_API drwav_result drwav_get_length_in_pcm_frames(drwav* pWav, drwav_uint64* pLength) -{ - if (pLength == NULL) { - return DRWAV_INVALID_ARGS; - } - *pLength = 0; - if (pWav == NULL) { - return DRWAV_INVALID_ARGS; - } - *pLength = pWav->totalPCMFrameCount; - return DRWAV_SUCCESS; -} -DRWAV_API size_t drwav_write_raw(drwav* pWav, size_t bytesToWrite, const void* pData) -{ - size_t bytesWritten; - if (pWav == NULL || bytesToWrite == 0 || pData == NULL) { - return 0; - } - bytesWritten = pWav->onWrite(pWav->pUserData, pData, bytesToWrite); - pWav->dataChunkDataSize += bytesWritten; - return bytesWritten; -} -DRWAV_API drwav_uint64 drwav_write_pcm_frames_le(drwav* pWav, drwav_uint64 framesToWrite, const void* pData) -{ - drwav_uint64 bytesToWrite; - drwav_uint64 bytesWritten; - const drwav_uint8* pRunningData; - if (pWav == NULL || framesToWrite == 0 || pData == NULL) { - return 0; - } - bytesToWrite = ((framesToWrite * pWav->channels * pWav->bitsPerSample) / 8); - if (bytesToWrite > DRWAV_SIZE_MAX) { - return 0; - } - bytesWritten = 0; - pRunningData = (const drwav_uint8*)pData; - while (bytesToWrite > 0) { - size_t bytesJustWritten; - drwav_uint64 bytesToWriteThisIteration; - bytesToWriteThisIteration = bytesToWrite; - DRWAV_ASSERT(bytesToWriteThisIteration <= DRWAV_SIZE_MAX); - bytesJustWritten = drwav_write_raw(pWav, (size_t)bytesToWriteThisIteration, pRunningData); - if (bytesJustWritten == 0) { - break; - } - bytesToWrite -= bytesJustWritten; - bytesWritten += bytesJustWritten; - pRunningData += bytesJustWritten; - } - return (bytesWritten * 8) / pWav->bitsPerSample / pWav->channels; -} -DRWAV_API drwav_uint64 drwav_write_pcm_frames_be(drwav* pWav, drwav_uint64 framesToWrite, const void* pData) -{ - drwav_uint64 bytesToWrite; - drwav_uint64 bytesWritten; - drwav_uint32 bytesPerSample; - const drwav_uint8* pRunningData; - if (pWav == NULL || framesToWrite == 0 || pData == NULL) { - return 0; - } - bytesToWrite = ((framesToWrite * pWav->channels * pWav->bitsPerSample) / 8); - if (bytesToWrite > DRWAV_SIZE_MAX) { - return 0; - } - bytesWritten = 0; - pRunningData = (const drwav_uint8*)pData; - bytesPerSample = drwav_get_bytes_per_pcm_frame(pWav) / pWav->channels; - if (bytesPerSample == 0) { - return 0; - } - while (bytesToWrite > 0) { - drwav_uint8 temp[4096]; - drwav_uint32 sampleCount; - size_t bytesJustWritten; - drwav_uint64 bytesToWriteThisIteration; - bytesToWriteThisIteration = bytesToWrite; - DRWAV_ASSERT(bytesToWriteThisIteration <= DRWAV_SIZE_MAX); - sampleCount = sizeof(temp)/bytesPerSample; - if (bytesToWriteThisIteration > ((drwav_uint64)sampleCount)*bytesPerSample) { - bytesToWriteThisIteration = ((drwav_uint64)sampleCount)*bytesPerSample; - } - DRWAV_COPY_MEMORY(temp, pRunningData, (size_t)bytesToWriteThisIteration); - drwav__bswap_samples(temp, sampleCount, bytesPerSample, pWav->translatedFormatTag); - bytesJustWritten = drwav_write_raw(pWav, (size_t)bytesToWriteThisIteration, temp); - if (bytesJustWritten == 0) { - break; - } - bytesToWrite -= bytesJustWritten; - bytesWritten += bytesJustWritten; - pRunningData += bytesJustWritten; - } - return (bytesWritten * 8) / pWav->bitsPerSample / pWav->channels; -} -DRWAV_API drwav_uint64 drwav_write_pcm_frames(drwav* pWav, drwav_uint64 framesToWrite, const void* pData) -{ - if (drwav__is_little_endian()) { - return drwav_write_pcm_frames_le(pWav, framesToWrite, pData); - } else { - return drwav_write_pcm_frames_be(pWav, framesToWrite, pData); - } -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__msadpcm(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 totalFramesRead = 0; - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(framesToRead > 0); - while (pWav->readCursorInPCMFrames < pWav->totalPCMFrameCount) { - DRWAV_ASSERT(framesToRead > 0); - if (pWav->msadpcm.cachedFrameCount == 0 && pWav->msadpcm.bytesRemainingInBlock == 0) { - if (pWav->channels == 1) { - drwav_uint8 header[7]; - if (pWav->onRead(pWav->pUserData, header, sizeof(header)) != sizeof(header)) { - return totalFramesRead; - } - pWav->msadpcm.bytesRemainingInBlock = pWav->fmt.blockAlign - sizeof(header); - pWav->msadpcm.predictor[0] = header[0]; - pWav->msadpcm.delta[0] = drwav_bytes_to_s16(header + 1); - pWav->msadpcm.prevFrames[0][1] = (drwav_int32)drwav_bytes_to_s16(header + 3); - pWav->msadpcm.prevFrames[0][0] = (drwav_int32)drwav_bytes_to_s16(header + 5); - pWav->msadpcm.cachedFrames[2] = pWav->msadpcm.prevFrames[0][0]; - pWav->msadpcm.cachedFrames[3] = pWav->msadpcm.prevFrames[0][1]; - pWav->msadpcm.cachedFrameCount = 2; - } else { - drwav_uint8 header[14]; - if (pWav->onRead(pWav->pUserData, header, sizeof(header)) != sizeof(header)) { - return totalFramesRead; - } - pWav->msadpcm.bytesRemainingInBlock = pWav->fmt.blockAlign - sizeof(header); - pWav->msadpcm.predictor[0] = header[0]; - pWav->msadpcm.predictor[1] = header[1]; - pWav->msadpcm.delta[0] = drwav_bytes_to_s16(header + 2); - pWav->msadpcm.delta[1] = drwav_bytes_to_s16(header + 4); - pWav->msadpcm.prevFrames[0][1] = (drwav_int32)drwav_bytes_to_s16(header + 6); - pWav->msadpcm.prevFrames[1][1] = (drwav_int32)drwav_bytes_to_s16(header + 8); - pWav->msadpcm.prevFrames[0][0] = (drwav_int32)drwav_bytes_to_s16(header + 10); - pWav->msadpcm.prevFrames[1][0] = (drwav_int32)drwav_bytes_to_s16(header + 12); - pWav->msadpcm.cachedFrames[0] = pWav->msadpcm.prevFrames[0][0]; - pWav->msadpcm.cachedFrames[1] = pWav->msadpcm.prevFrames[1][0]; - pWav->msadpcm.cachedFrames[2] = pWav->msadpcm.prevFrames[0][1]; - pWav->msadpcm.cachedFrames[3] = pWav->msadpcm.prevFrames[1][1]; - pWav->msadpcm.cachedFrameCount = 2; - } - } - while (framesToRead > 0 && pWav->msadpcm.cachedFrameCount > 0 && pWav->readCursorInPCMFrames < pWav->totalPCMFrameCount) { - if (pBufferOut != NULL) { - drwav_uint32 iSample = 0; - for (iSample = 0; iSample < pWav->channels; iSample += 1) { - pBufferOut[iSample] = (drwav_int16)pWav->msadpcm.cachedFrames[(drwav_countof(pWav->msadpcm.cachedFrames) - (pWav->msadpcm.cachedFrameCount*pWav->channels)) + iSample]; - } - pBufferOut += pWav->channels; - } - framesToRead -= 1; - totalFramesRead += 1; - pWav->readCursorInPCMFrames += 1; - pWav->msadpcm.cachedFrameCount -= 1; - } - if (framesToRead == 0) { - break; - } - if (pWav->msadpcm.cachedFrameCount == 0) { - if (pWav->msadpcm.bytesRemainingInBlock == 0) { - continue; - } else { - static drwav_int32 adaptationTable[] = { - 230, 230, 230, 230, 307, 409, 512, 614, - 768, 614, 512, 409, 307, 230, 230, 230 - }; - static drwav_int32 coeff1Table[] = { 256, 512, 0, 192, 240, 460, 392 }; - static drwav_int32 coeff2Table[] = { 0, -256, 0, 64, 0, -208, -232 }; - drwav_uint8 nibbles; - drwav_int32 nibble0; - drwav_int32 nibble1; - if (pWav->onRead(pWav->pUserData, &nibbles, 1) != 1) { - return totalFramesRead; - } - pWav->msadpcm.bytesRemainingInBlock -= 1; - nibble0 = ((nibbles & 0xF0) >> 4); if ((nibbles & 0x80)) { nibble0 |= 0xFFFFFFF0UL; } - nibble1 = ((nibbles & 0x0F) >> 0); if ((nibbles & 0x08)) { nibble1 |= 0xFFFFFFF0UL; } - if (pWav->channels == 1) { - drwav_int32 newSample0; - drwav_int32 newSample1; - newSample0 = ((pWav->msadpcm.prevFrames[0][1] * coeff1Table[pWav->msadpcm.predictor[0]]) + (pWav->msadpcm.prevFrames[0][0] * coeff2Table[pWav->msadpcm.predictor[0]])) >> 8; - newSample0 += nibble0 * pWav->msadpcm.delta[0]; - newSample0 = drwav_clamp(newSample0, -32768, 32767); - pWav->msadpcm.delta[0] = (adaptationTable[((nibbles & 0xF0) >> 4)] * pWav->msadpcm.delta[0]) >> 8; - if (pWav->msadpcm.delta[0] < 16) { - pWav->msadpcm.delta[0] = 16; - } - pWav->msadpcm.prevFrames[0][0] = pWav->msadpcm.prevFrames[0][1]; - pWav->msadpcm.prevFrames[0][1] = newSample0; - newSample1 = ((pWav->msadpcm.prevFrames[0][1] * coeff1Table[pWav->msadpcm.predictor[0]]) + (pWav->msadpcm.prevFrames[0][0] * coeff2Table[pWav->msadpcm.predictor[0]])) >> 8; - newSample1 += nibble1 * pWav->msadpcm.delta[0]; - newSample1 = drwav_clamp(newSample1, -32768, 32767); - pWav->msadpcm.delta[0] = (adaptationTable[((nibbles & 0x0F) >> 0)] * pWav->msadpcm.delta[0]) >> 8; - if (pWav->msadpcm.delta[0] < 16) { - pWav->msadpcm.delta[0] = 16; - } - pWav->msadpcm.prevFrames[0][0] = pWav->msadpcm.prevFrames[0][1]; - pWav->msadpcm.prevFrames[0][1] = newSample1; - pWav->msadpcm.cachedFrames[2] = newSample0; - pWav->msadpcm.cachedFrames[3] = newSample1; - pWav->msadpcm.cachedFrameCount = 2; - } else { - drwav_int32 newSample0; - drwav_int32 newSample1; - newSample0 = ((pWav->msadpcm.prevFrames[0][1] * coeff1Table[pWav->msadpcm.predictor[0]]) + (pWav->msadpcm.prevFrames[0][0] * coeff2Table[pWav->msadpcm.predictor[0]])) >> 8; - newSample0 += nibble0 * pWav->msadpcm.delta[0]; - newSample0 = drwav_clamp(newSample0, -32768, 32767); - pWav->msadpcm.delta[0] = (adaptationTable[((nibbles & 0xF0) >> 4)] * pWav->msadpcm.delta[0]) >> 8; - if (pWav->msadpcm.delta[0] < 16) { - pWav->msadpcm.delta[0] = 16; - } - pWav->msadpcm.prevFrames[0][0] = pWav->msadpcm.prevFrames[0][1]; - pWav->msadpcm.prevFrames[0][1] = newSample0; - newSample1 = ((pWav->msadpcm.prevFrames[1][1] * coeff1Table[pWav->msadpcm.predictor[1]]) + (pWav->msadpcm.prevFrames[1][0] * coeff2Table[pWav->msadpcm.predictor[1]])) >> 8; - newSample1 += nibble1 * pWav->msadpcm.delta[1]; - newSample1 = drwav_clamp(newSample1, -32768, 32767); - pWav->msadpcm.delta[1] = (adaptationTable[((nibbles & 0x0F) >> 0)] * pWav->msadpcm.delta[1]) >> 8; - if (pWav->msadpcm.delta[1] < 16) { - pWav->msadpcm.delta[1] = 16; - } - pWav->msadpcm.prevFrames[1][0] = pWav->msadpcm.prevFrames[1][1]; - pWav->msadpcm.prevFrames[1][1] = newSample1; - pWav->msadpcm.cachedFrames[2] = newSample0; - pWav->msadpcm.cachedFrames[3] = newSample1; - pWav->msadpcm.cachedFrameCount = 1; - } - } - } - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__ima(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 totalFramesRead = 0; - drwav_uint32 iChannel; - static drwav_int32 indexTable[16] = { - -1, -1, -1, -1, 2, 4, 6, 8, - -1, -1, -1, -1, 2, 4, 6, 8 - }; - static drwav_int32 stepTable[89] = { - 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, - 19, 21, 23, 25, 28, 31, 34, 37, 41, 45, - 50, 55, 60, 66, 73, 80, 88, 97, 107, 118, - 130, 143, 157, 173, 190, 209, 230, 253, 279, 307, - 337, 371, 408, 449, 494, 544, 598, 658, 724, 796, - 876, 963, 1060, 1166, 1282, 1411, 1552, 1707, 1878, 2066, - 2272, 2499, 2749, 3024, 3327, 3660, 4026, 4428, 4871, 5358, - 5894, 6484, 7132, 7845, 8630, 9493, 10442, 11487, 12635, 13899, - 15289, 16818, 18500, 20350, 22385, 24623, 27086, 29794, 32767 - }; - DRWAV_ASSERT(pWav != NULL); - DRWAV_ASSERT(framesToRead > 0); - while (pWav->readCursorInPCMFrames < pWav->totalPCMFrameCount) { - DRWAV_ASSERT(framesToRead > 0); - if (pWav->ima.cachedFrameCount == 0 && pWav->ima.bytesRemainingInBlock == 0) { - if (pWav->channels == 1) { - drwav_uint8 header[4]; - if (pWav->onRead(pWav->pUserData, header, sizeof(header)) != sizeof(header)) { - return totalFramesRead; - } - pWav->ima.bytesRemainingInBlock = pWav->fmt.blockAlign - sizeof(header); - if (header[2] >= drwav_countof(stepTable)) { - pWav->onSeek(pWav->pUserData, pWav->ima.bytesRemainingInBlock, drwav_seek_origin_current); - pWav->ima.bytesRemainingInBlock = 0; - return totalFramesRead; - } - pWav->ima.predictor[0] = drwav_bytes_to_s16(header + 0); - pWav->ima.stepIndex[0] = drwav_clamp(header[2], 0, (drwav_int32)drwav_countof(stepTable)-1); - pWav->ima.cachedFrames[drwav_countof(pWav->ima.cachedFrames) - 1] = pWav->ima.predictor[0]; - pWav->ima.cachedFrameCount = 1; - } else { - drwav_uint8 header[8]; - if (pWav->onRead(pWav->pUserData, header, sizeof(header)) != sizeof(header)) { - return totalFramesRead; - } - pWav->ima.bytesRemainingInBlock = pWav->fmt.blockAlign - sizeof(header); - if (header[2] >= drwav_countof(stepTable) || header[6] >= drwav_countof(stepTable)) { - pWav->onSeek(pWav->pUserData, pWav->ima.bytesRemainingInBlock, drwav_seek_origin_current); - pWav->ima.bytesRemainingInBlock = 0; - return totalFramesRead; - } - pWav->ima.predictor[0] = drwav_bytes_to_s16(header + 0); - pWav->ima.stepIndex[0] = drwav_clamp(header[2], 0, (drwav_int32)drwav_countof(stepTable)-1); - pWav->ima.predictor[1] = drwav_bytes_to_s16(header + 4); - pWav->ima.stepIndex[1] = drwav_clamp(header[6], 0, (drwav_int32)drwav_countof(stepTable)-1); - pWav->ima.cachedFrames[drwav_countof(pWav->ima.cachedFrames) - 2] = pWav->ima.predictor[0]; - pWav->ima.cachedFrames[drwav_countof(pWav->ima.cachedFrames) - 1] = pWav->ima.predictor[1]; - pWav->ima.cachedFrameCount = 1; - } - } - while (framesToRead > 0 && pWav->ima.cachedFrameCount > 0 && pWav->readCursorInPCMFrames < pWav->totalPCMFrameCount) { - if (pBufferOut != NULL) { - drwav_uint32 iSample; - for (iSample = 0; iSample < pWav->channels; iSample += 1) { - pBufferOut[iSample] = (drwav_int16)pWav->ima.cachedFrames[(drwav_countof(pWav->ima.cachedFrames) - (pWav->ima.cachedFrameCount*pWav->channels)) + iSample]; - } - pBufferOut += pWav->channels; - } - framesToRead -= 1; - totalFramesRead += 1; - pWav->readCursorInPCMFrames += 1; - pWav->ima.cachedFrameCount -= 1; - } - if (framesToRead == 0) { - break; - } - if (pWav->ima.cachedFrameCount == 0) { - if (pWav->ima.bytesRemainingInBlock == 0) { - continue; - } else { - pWav->ima.cachedFrameCount = 8; - for (iChannel = 0; iChannel < pWav->channels; ++iChannel) { - drwav_uint32 iByte; - drwav_uint8 nibbles[4]; - if (pWav->onRead(pWav->pUserData, &nibbles, 4) != 4) { - pWav->ima.cachedFrameCount = 0; - return totalFramesRead; - } - pWav->ima.bytesRemainingInBlock -= 4; - for (iByte = 0; iByte < 4; ++iByte) { - drwav_uint8 nibble0 = ((nibbles[iByte] & 0x0F) >> 0); - drwav_uint8 nibble1 = ((nibbles[iByte] & 0xF0) >> 4); - drwav_int32 step = stepTable[pWav->ima.stepIndex[iChannel]]; - drwav_int32 predictor = pWav->ima.predictor[iChannel]; - drwav_int32 diff = step >> 3; - if (nibble0 & 1) diff += step >> 2; - if (nibble0 & 2) diff += step >> 1; - if (nibble0 & 4) diff += step; - if (nibble0 & 8) diff = -diff; - predictor = drwav_clamp(predictor + diff, -32768, 32767); - pWav->ima.predictor[iChannel] = predictor; - pWav->ima.stepIndex[iChannel] = drwav_clamp(pWav->ima.stepIndex[iChannel] + indexTable[nibble0], 0, (drwav_int32)drwav_countof(stepTable)-1); - pWav->ima.cachedFrames[(drwav_countof(pWav->ima.cachedFrames) - (pWav->ima.cachedFrameCount*pWav->channels)) + (iByte*2+0)*pWav->channels + iChannel] = predictor; - step = stepTable[pWav->ima.stepIndex[iChannel]]; - predictor = pWav->ima.predictor[iChannel]; - diff = step >> 3; - if (nibble1 & 1) diff += step >> 2; - if (nibble1 & 2) diff += step >> 1; - if (nibble1 & 4) diff += step; - if (nibble1 & 8) diff = -diff; - predictor = drwav_clamp(predictor + diff, -32768, 32767); - pWav->ima.predictor[iChannel] = predictor; - pWav->ima.stepIndex[iChannel] = drwav_clamp(pWav->ima.stepIndex[iChannel] + indexTable[nibble1], 0, (drwav_int32)drwav_countof(stepTable)-1); - pWav->ima.cachedFrames[(drwav_countof(pWav->ima.cachedFrames) - (pWav->ima.cachedFrameCount*pWav->channels)) + (iByte*2+1)*pWav->channels + iChannel] = predictor; - } - } - } - } - } - return totalFramesRead; -} -#ifndef DR_WAV_NO_CONVERSION_API -static unsigned short g_drwavAlawTable[256] = { - 0xEA80, 0xEB80, 0xE880, 0xE980, 0xEE80, 0xEF80, 0xEC80, 0xED80, 0xE280, 0xE380, 0xE080, 0xE180, 0xE680, 0xE780, 0xE480, 0xE580, - 0xF540, 0xF5C0, 0xF440, 0xF4C0, 0xF740, 0xF7C0, 0xF640, 0xF6C0, 0xF140, 0xF1C0, 0xF040, 0xF0C0, 0xF340, 0xF3C0, 0xF240, 0xF2C0, - 0xAA00, 0xAE00, 0xA200, 0xA600, 0xBA00, 0xBE00, 0xB200, 0xB600, 0x8A00, 0x8E00, 0x8200, 0x8600, 0x9A00, 0x9E00, 0x9200, 0x9600, - 0xD500, 0xD700, 0xD100, 0xD300, 0xDD00, 0xDF00, 0xD900, 0xDB00, 0xC500, 0xC700, 0xC100, 0xC300, 0xCD00, 0xCF00, 0xC900, 0xCB00, - 0xFEA8, 0xFEB8, 0xFE88, 0xFE98, 0xFEE8, 0xFEF8, 0xFEC8, 0xFED8, 0xFE28, 0xFE38, 0xFE08, 0xFE18, 0xFE68, 0xFE78, 0xFE48, 0xFE58, - 0xFFA8, 0xFFB8, 0xFF88, 0xFF98, 0xFFE8, 0xFFF8, 0xFFC8, 0xFFD8, 0xFF28, 0xFF38, 0xFF08, 0xFF18, 0xFF68, 0xFF78, 0xFF48, 0xFF58, - 0xFAA0, 0xFAE0, 0xFA20, 0xFA60, 0xFBA0, 0xFBE0, 0xFB20, 0xFB60, 0xF8A0, 0xF8E0, 0xF820, 0xF860, 0xF9A0, 0xF9E0, 0xF920, 0xF960, - 0xFD50, 0xFD70, 0xFD10, 0xFD30, 0xFDD0, 0xFDF0, 0xFD90, 0xFDB0, 0xFC50, 0xFC70, 0xFC10, 0xFC30, 0xFCD0, 0xFCF0, 0xFC90, 0xFCB0, - 0x1580, 0x1480, 0x1780, 0x1680, 0x1180, 0x1080, 0x1380, 0x1280, 0x1D80, 0x1C80, 0x1F80, 0x1E80, 0x1980, 0x1880, 0x1B80, 0x1A80, - 0x0AC0, 0x0A40, 0x0BC0, 0x0B40, 0x08C0, 0x0840, 0x09C0, 0x0940, 0x0EC0, 0x0E40, 0x0FC0, 0x0F40, 0x0CC0, 0x0C40, 0x0DC0, 0x0D40, - 0x5600, 0x5200, 0x5E00, 0x5A00, 0x4600, 0x4200, 0x4E00, 0x4A00, 0x7600, 0x7200, 0x7E00, 0x7A00, 0x6600, 0x6200, 0x6E00, 0x6A00, - 0x2B00, 0x2900, 0x2F00, 0x2D00, 0x2300, 0x2100, 0x2700, 0x2500, 0x3B00, 0x3900, 0x3F00, 0x3D00, 0x3300, 0x3100, 0x3700, 0x3500, - 0x0158, 0x0148, 0x0178, 0x0168, 0x0118, 0x0108, 0x0138, 0x0128, 0x01D8, 0x01C8, 0x01F8, 0x01E8, 0x0198, 0x0188, 0x01B8, 0x01A8, - 0x0058, 0x0048, 0x0078, 0x0068, 0x0018, 0x0008, 0x0038, 0x0028, 0x00D8, 0x00C8, 0x00F8, 0x00E8, 0x0098, 0x0088, 0x00B8, 0x00A8, - 0x0560, 0x0520, 0x05E0, 0x05A0, 0x0460, 0x0420, 0x04E0, 0x04A0, 0x0760, 0x0720, 0x07E0, 0x07A0, 0x0660, 0x0620, 0x06E0, 0x06A0, - 0x02B0, 0x0290, 0x02F0, 0x02D0, 0x0230, 0x0210, 0x0270, 0x0250, 0x03B0, 0x0390, 0x03F0, 0x03D0, 0x0330, 0x0310, 0x0370, 0x0350 -}; -static unsigned short g_drwavMulawTable[256] = { - 0x8284, 0x8684, 0x8A84, 0x8E84, 0x9284, 0x9684, 0x9A84, 0x9E84, 0xA284, 0xA684, 0xAA84, 0xAE84, 0xB284, 0xB684, 0xBA84, 0xBE84, - 0xC184, 0xC384, 0xC584, 0xC784, 0xC984, 0xCB84, 0xCD84, 0xCF84, 0xD184, 0xD384, 0xD584, 0xD784, 0xD984, 0xDB84, 0xDD84, 0xDF84, - 0xE104, 0xE204, 0xE304, 0xE404, 0xE504, 0xE604, 0xE704, 0xE804, 0xE904, 0xEA04, 0xEB04, 0xEC04, 0xED04, 0xEE04, 0xEF04, 0xF004, - 0xF0C4, 0xF144, 0xF1C4, 0xF244, 0xF2C4, 0xF344, 0xF3C4, 0xF444, 0xF4C4, 0xF544, 0xF5C4, 0xF644, 0xF6C4, 0xF744, 0xF7C4, 0xF844, - 0xF8A4, 0xF8E4, 0xF924, 0xF964, 0xF9A4, 0xF9E4, 0xFA24, 0xFA64, 0xFAA4, 0xFAE4, 0xFB24, 0xFB64, 0xFBA4, 0xFBE4, 0xFC24, 0xFC64, - 0xFC94, 0xFCB4, 0xFCD4, 0xFCF4, 0xFD14, 0xFD34, 0xFD54, 0xFD74, 0xFD94, 0xFDB4, 0xFDD4, 0xFDF4, 0xFE14, 0xFE34, 0xFE54, 0xFE74, - 0xFE8C, 0xFE9C, 0xFEAC, 0xFEBC, 0xFECC, 0xFEDC, 0xFEEC, 0xFEFC, 0xFF0C, 0xFF1C, 0xFF2C, 0xFF3C, 0xFF4C, 0xFF5C, 0xFF6C, 0xFF7C, - 0xFF88, 0xFF90, 0xFF98, 0xFFA0, 0xFFA8, 0xFFB0, 0xFFB8, 0xFFC0, 0xFFC8, 0xFFD0, 0xFFD8, 0xFFE0, 0xFFE8, 0xFFF0, 0xFFF8, 0x0000, - 0x7D7C, 0x797C, 0x757C, 0x717C, 0x6D7C, 0x697C, 0x657C, 0x617C, 0x5D7C, 0x597C, 0x557C, 0x517C, 0x4D7C, 0x497C, 0x457C, 0x417C, - 0x3E7C, 0x3C7C, 0x3A7C, 0x387C, 0x367C, 0x347C, 0x327C, 0x307C, 0x2E7C, 0x2C7C, 0x2A7C, 0x287C, 0x267C, 0x247C, 0x227C, 0x207C, - 0x1EFC, 0x1DFC, 0x1CFC, 0x1BFC, 0x1AFC, 0x19FC, 0x18FC, 0x17FC, 0x16FC, 0x15FC, 0x14FC, 0x13FC, 0x12FC, 0x11FC, 0x10FC, 0x0FFC, - 0x0F3C, 0x0EBC, 0x0E3C, 0x0DBC, 0x0D3C, 0x0CBC, 0x0C3C, 0x0BBC, 0x0B3C, 0x0ABC, 0x0A3C, 0x09BC, 0x093C, 0x08BC, 0x083C, 0x07BC, - 0x075C, 0x071C, 0x06DC, 0x069C, 0x065C, 0x061C, 0x05DC, 0x059C, 0x055C, 0x051C, 0x04DC, 0x049C, 0x045C, 0x041C, 0x03DC, 0x039C, - 0x036C, 0x034C, 0x032C, 0x030C, 0x02EC, 0x02CC, 0x02AC, 0x028C, 0x026C, 0x024C, 0x022C, 0x020C, 0x01EC, 0x01CC, 0x01AC, 0x018C, - 0x0174, 0x0164, 0x0154, 0x0144, 0x0134, 0x0124, 0x0114, 0x0104, 0x00F4, 0x00E4, 0x00D4, 0x00C4, 0x00B4, 0x00A4, 0x0094, 0x0084, - 0x0078, 0x0070, 0x0068, 0x0060, 0x0058, 0x0050, 0x0048, 0x0040, 0x0038, 0x0030, 0x0028, 0x0020, 0x0018, 0x0010, 0x0008, 0x0000 -}; -static DRWAV_INLINE drwav_int16 drwav__alaw_to_s16(drwav_uint8 sampleIn) -{ - return (short)g_drwavAlawTable[sampleIn]; -} -static DRWAV_INLINE drwav_int16 drwav__mulaw_to_s16(drwav_uint8 sampleIn) -{ - return (short)g_drwavMulawTable[sampleIn]; -} -DRWAV_PRIVATE void drwav__pcm_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t totalSampleCount, unsigned int bytesPerSample) -{ - size_t i; - if (bytesPerSample == 1) { - drwav_u8_to_s16(pOut, pIn, totalSampleCount); - return; - } - if (bytesPerSample == 2) { - for (i = 0; i < totalSampleCount; ++i) { - *pOut++ = ((const drwav_int16*)pIn)[i]; - } - return; - } - if (bytesPerSample == 3) { - drwav_s24_to_s16(pOut, pIn, totalSampleCount); - return; - } - if (bytesPerSample == 4) { - drwav_s32_to_s16(pOut, (const drwav_int32*)pIn, totalSampleCount); - return; - } - if (bytesPerSample > 8) { - DRWAV_ZERO_MEMORY(pOut, totalSampleCount * sizeof(*pOut)); - return; - } - for (i = 0; i < totalSampleCount; ++i) { - drwav_uint64 sample = 0; - unsigned int shift = (8 - bytesPerSample) * 8; - unsigned int j; - for (j = 0; j < bytesPerSample; j += 1) { - DRWAV_ASSERT(j < 8); - sample |= (drwav_uint64)(pIn[j]) << shift; - shift += 8; - } - pIn += j; - *pOut++ = (drwav_int16)((drwav_int64)sample >> 48); - } -} -DRWAV_PRIVATE void drwav__ieee_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t totalSampleCount, unsigned int bytesPerSample) -{ - if (bytesPerSample == 4) { - drwav_f32_to_s16(pOut, (const float*)pIn, totalSampleCount); - return; - } else if (bytesPerSample == 8) { - drwav_f64_to_s16(pOut, (const double*)pIn, totalSampleCount); - return; - } else { - DRWAV_ZERO_MEMORY(pOut, totalSampleCount * sizeof(*pOut)); - return; - } -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__pcm(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - if ((pWav->translatedFormatTag == DR_WAVE_FORMAT_PCM && pWav->bitsPerSample == 16) || pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, pBufferOut); - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav__pcm_to_s16(pBufferOut, sampleData, (size_t)samplesRead, bytesPerSample); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__ieee(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - if (pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, NULL); - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav__ieee_to_s16(pBufferOut, sampleData, (size_t)samplesRead, bytesPerSample); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__alaw(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - if (pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, NULL); - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav_alaw_to_s16(pBufferOut, sampleData, (size_t)samplesRead); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s16__mulaw(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - if (pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, NULL); - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav_mulaw_to_s16(pBufferOut, sampleData, (size_t)samplesRead); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s16(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - if (pWav == NULL || framesToRead == 0) { - return 0; - } - if (pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, NULL); - } - if (framesToRead * pWav->channels * sizeof(drwav_int16) > DRWAV_SIZE_MAX) { - framesToRead = DRWAV_SIZE_MAX / sizeof(drwav_int16) / pWav->channels; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_PCM) { - return drwav_read_pcm_frames_s16__pcm(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_IEEE_FLOAT) { - return drwav_read_pcm_frames_s16__ieee(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ALAW) { - return drwav_read_pcm_frames_s16__alaw(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_MULAW) { - return drwav_read_pcm_frames_s16__mulaw(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM) { - return drwav_read_pcm_frames_s16__msadpcm(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - return drwav_read_pcm_frames_s16__ima(pWav, framesToRead, pBufferOut); - } - return 0; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s16le(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_s16(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL && drwav__is_little_endian() == DRWAV_FALSE) { - drwav__bswap_samples_s16(pBufferOut, framesRead*pWav->channels); - } - return framesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s16be(drwav* pWav, drwav_uint64 framesToRead, drwav_int16* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_s16(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL && drwav__is_little_endian() == DRWAV_TRUE) { - drwav__bswap_samples_s16(pBufferOut, framesRead*pWav->channels); - } - return framesRead; -} -DRWAV_API void drwav_u8_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - int r; - size_t i; - for (i = 0; i < sampleCount; ++i) { - int x = pIn[i]; - r = x << 8; - r = r - 32768; - pOut[i] = (short)r; - } -} -DRWAV_API void drwav_s24_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - int r; - size_t i; - for (i = 0; i < sampleCount; ++i) { - int x = ((int)(((unsigned int)(((const drwav_uint8*)pIn)[i*3+0]) << 8) | ((unsigned int)(((const drwav_uint8*)pIn)[i*3+1]) << 16) | ((unsigned int)(((const drwav_uint8*)pIn)[i*3+2])) << 24)) >> 8; - r = x >> 8; - pOut[i] = (short)r; - } -} -DRWAV_API void drwav_s32_to_s16(drwav_int16* pOut, const drwav_int32* pIn, size_t sampleCount) -{ - int r; - size_t i; - for (i = 0; i < sampleCount; ++i) { - int x = pIn[i]; - r = x >> 16; - pOut[i] = (short)r; - } -} -DRWAV_API void drwav_f32_to_s16(drwav_int16* pOut, const float* pIn, size_t sampleCount) -{ - int r; - size_t i; - for (i = 0; i < sampleCount; ++i) { - float x = pIn[i]; - float c; - c = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); - c = c + 1; - r = (int)(c * 32767.5f); - r = r - 32768; - pOut[i] = (short)r; - } -} -DRWAV_API void drwav_f64_to_s16(drwav_int16* pOut, const double* pIn, size_t sampleCount) -{ - int r; - size_t i; - for (i = 0; i < sampleCount; ++i) { - double x = pIn[i]; - double c; - c = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); - c = c + 1; - r = (int)(c * 32767.5); - r = r - 32768; - pOut[i] = (short)r; - } -} -DRWAV_API void drwav_alaw_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - for (i = 0; i < sampleCount; ++i) { - pOut[i] = drwav__alaw_to_s16(pIn[i]); - } -} -DRWAV_API void drwav_mulaw_to_s16(drwav_int16* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - for (i = 0; i < sampleCount; ++i) { - pOut[i] = drwav__mulaw_to_s16(pIn[i]); - } -} -DRWAV_PRIVATE void drwav__pcm_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount, unsigned int bytesPerSample) -{ - unsigned int i; - if (bytesPerSample == 1) { - drwav_u8_to_f32(pOut, pIn, sampleCount); - return; - } - if (bytesPerSample == 2) { - drwav_s16_to_f32(pOut, (const drwav_int16*)pIn, sampleCount); - return; - } - if (bytesPerSample == 3) { - drwav_s24_to_f32(pOut, pIn, sampleCount); - return; - } - if (bytesPerSample == 4) { - drwav_s32_to_f32(pOut, (const drwav_int32*)pIn, sampleCount); - return; - } - if (bytesPerSample > 8) { - DRWAV_ZERO_MEMORY(pOut, sampleCount * sizeof(*pOut)); - return; - } - for (i = 0; i < sampleCount; ++i) { - drwav_uint64 sample = 0; - unsigned int shift = (8 - bytesPerSample) * 8; - unsigned int j; - for (j = 0; j < bytesPerSample; j += 1) { - DRWAV_ASSERT(j < 8); - sample |= (drwav_uint64)(pIn[j]) << shift; - shift += 8; - } - pIn += j; - *pOut++ = (float)((drwav_int64)sample / 9223372036854775807.0); - } -} -DRWAV_PRIVATE void drwav__ieee_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount, unsigned int bytesPerSample) -{ - if (bytesPerSample == 4) { - unsigned int i; - for (i = 0; i < sampleCount; ++i) { - *pOut++ = ((const float*)pIn)[i]; - } - return; - } else if (bytesPerSample == 8) { - drwav_f64_to_f32(pOut, (const double*)pIn, sampleCount); - return; - } else { - DRWAV_ZERO_MEMORY(pOut, sampleCount * sizeof(*pOut)); - return; - } -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_f32__pcm(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav__pcm_to_f32(pBufferOut, sampleData, (size_t)samplesRead, bytesPerSample); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_f32__msadpcm_ima(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_int16 samples16[2048]; - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, drwav_countof(samples16)/pWav->channels); - drwav_uint64 framesRead = drwav_read_pcm_frames_s16(pWav, framesToReadThisIteration, samples16); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - drwav_s16_to_f32(pBufferOut, samples16, (size_t)(framesRead*pWav->channels)); - pBufferOut += framesRead*pWav->channels; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_f32__ieee(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_IEEE_FLOAT && pWav->bitsPerSample == 32) { - return drwav_read_pcm_frames(pWav, framesToRead, pBufferOut); - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav__ieee_to_f32(pBufferOut, sampleData, (size_t)samplesRead, bytesPerSample); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_f32__alaw(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav_alaw_to_f32(pBufferOut, sampleData, (size_t)samplesRead); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_f32__mulaw(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav_mulaw_to_f32(pBufferOut, sampleData, (size_t)samplesRead); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_f32(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - if (pWav == NULL || framesToRead == 0) { - return 0; - } - if (pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, NULL); - } - if (framesToRead * pWav->channels * sizeof(float) > DRWAV_SIZE_MAX) { - framesToRead = DRWAV_SIZE_MAX / sizeof(float) / pWav->channels; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_PCM) { - return drwav_read_pcm_frames_f32__pcm(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM || pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - return drwav_read_pcm_frames_f32__msadpcm_ima(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_IEEE_FLOAT) { - return drwav_read_pcm_frames_f32__ieee(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ALAW) { - return drwav_read_pcm_frames_f32__alaw(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_MULAW) { - return drwav_read_pcm_frames_f32__mulaw(pWav, framesToRead, pBufferOut); - } - return 0; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_f32le(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_f32(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL && drwav__is_little_endian() == DRWAV_FALSE) { - drwav__bswap_samples_f32(pBufferOut, framesRead*pWav->channels); - } - return framesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_f32be(drwav* pWav, drwav_uint64 framesToRead, float* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_f32(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL && drwav__is_little_endian() == DRWAV_TRUE) { - drwav__bswap_samples_f32(pBufferOut, framesRead*pWav->channels); - } - return framesRead; -} -DRWAV_API void drwav_u8_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } -#ifdef DR_WAV_LIBSNDFILE_COMPAT - for (i = 0; i < sampleCount; ++i) { - *pOut++ = (pIn[i] / 256.0f) * 2 - 1; - } -#else - for (i = 0; i < sampleCount; ++i) { - float x = pIn[i]; - x = x * 0.00784313725490196078f; - x = x - 1; - *pOut++ = x; - } -#endif -} -DRWAV_API void drwav_s16_to_f32(float* pOut, const drwav_int16* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = pIn[i] * 0.000030517578125f; - } -} -DRWAV_API void drwav_s24_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - double x; - drwav_uint32 a = ((drwav_uint32)(pIn[i*3+0]) << 8); - drwav_uint32 b = ((drwav_uint32)(pIn[i*3+1]) << 16); - drwav_uint32 c = ((drwav_uint32)(pIn[i*3+2]) << 24); - x = (double)((drwav_int32)(a | b | c) >> 8); - *pOut++ = (float)(x * 0.00000011920928955078125); - } -} -DRWAV_API void drwav_s32_to_f32(float* pOut, const drwav_int32* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = (float)(pIn[i] / 2147483648.0); - } -} -DRWAV_API void drwav_f64_to_f32(float* pOut, const double* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = (float)pIn[i]; - } -} -DRWAV_API void drwav_alaw_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = drwav__alaw_to_s16(pIn[i]) / 32768.0f; - } -} -DRWAV_API void drwav_mulaw_to_f32(float* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = drwav__mulaw_to_s16(pIn[i]) / 32768.0f; - } -} -DRWAV_PRIVATE void drwav__pcm_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t totalSampleCount, unsigned int bytesPerSample) -{ - unsigned int i; - if (bytesPerSample == 1) { - drwav_u8_to_s32(pOut, pIn, totalSampleCount); - return; - } - if (bytesPerSample == 2) { - drwav_s16_to_s32(pOut, (const drwav_int16*)pIn, totalSampleCount); - return; - } - if (bytesPerSample == 3) { - drwav_s24_to_s32(pOut, pIn, totalSampleCount); - return; - } - if (bytesPerSample == 4) { - for (i = 0; i < totalSampleCount; ++i) { - *pOut++ = ((const drwav_int32*)pIn)[i]; - } - return; - } - if (bytesPerSample > 8) { - DRWAV_ZERO_MEMORY(pOut, totalSampleCount * sizeof(*pOut)); - return; - } - for (i = 0; i < totalSampleCount; ++i) { - drwav_uint64 sample = 0; - unsigned int shift = (8 - bytesPerSample) * 8; - unsigned int j; - for (j = 0; j < bytesPerSample; j += 1) { - DRWAV_ASSERT(j < 8); - sample |= (drwav_uint64)(pIn[j]) << shift; - shift += 8; - } - pIn += j; - *pOut++ = (drwav_int32)((drwav_int64)sample >> 32); - } -} -DRWAV_PRIVATE void drwav__ieee_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t totalSampleCount, unsigned int bytesPerSample) -{ - if (bytesPerSample == 4) { - drwav_f32_to_s32(pOut, (const float*)pIn, totalSampleCount); - return; - } else if (bytesPerSample == 8) { - drwav_f64_to_s32(pOut, (const double*)pIn, totalSampleCount); - return; - } else { - DRWAV_ZERO_MEMORY(pOut, totalSampleCount * sizeof(*pOut)); - return; - } -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s32__pcm(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_PCM && pWav->bitsPerSample == 32) { - return drwav_read_pcm_frames(pWav, framesToRead, pBufferOut); - } - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav__pcm_to_s32(pBufferOut, sampleData, (size_t)samplesRead, bytesPerSample); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s32__msadpcm_ima(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 totalFramesRead = 0; - drwav_int16 samples16[2048]; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, drwav_countof(samples16)/pWav->channels); - drwav_uint64 framesRead = drwav_read_pcm_frames_s16(pWav, framesToReadThisIteration, samples16); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - drwav_s16_to_s32(pBufferOut, samples16, (size_t)(framesRead*pWav->channels)); - pBufferOut += framesRead*pWav->channels; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s32__ieee(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav__ieee_to_s32(pBufferOut, sampleData, (size_t)samplesRead, bytesPerSample); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s32__alaw(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav_alaw_to_s32(pBufferOut, sampleData, (size_t)samplesRead); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_PRIVATE drwav_uint64 drwav_read_pcm_frames_s32__mulaw(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 totalFramesRead; - drwav_uint8 sampleData[4096] = {0}; - drwav_uint32 bytesPerFrame; - drwav_uint32 bytesPerSample; - drwav_uint64 samplesRead; - bytesPerFrame = drwav_get_bytes_per_pcm_frame(pWav); - if (bytesPerFrame == 0) { - return 0; - } - bytesPerSample = bytesPerFrame / pWav->channels; - if (bytesPerSample == 0 || (bytesPerFrame % pWav->channels) != 0) { - return 0; - } - totalFramesRead = 0; - while (framesToRead > 0) { - drwav_uint64 framesToReadThisIteration = drwav_min(framesToRead, sizeof(sampleData)/bytesPerFrame); - drwav_uint64 framesRead = drwav_read_pcm_frames(pWav, framesToReadThisIteration, sampleData); - if (framesRead == 0) { - break; - } - DRWAV_ASSERT(framesRead <= framesToReadThisIteration); - samplesRead = framesRead * pWav->channels; - if ((samplesRead * bytesPerSample) > sizeof(sampleData)) { - DRWAV_ASSERT(DRWAV_FALSE); - break; - } - drwav_mulaw_to_s32(pBufferOut, sampleData, (size_t)samplesRead); - pBufferOut += samplesRead; - framesToRead -= framesRead; - totalFramesRead += framesRead; - } - return totalFramesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s32(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - if (pWav == NULL || framesToRead == 0) { - return 0; - } - if (pBufferOut == NULL) { - return drwav_read_pcm_frames(pWav, framesToRead, NULL); - } - if (framesToRead * pWav->channels * sizeof(drwav_int32) > DRWAV_SIZE_MAX) { - framesToRead = DRWAV_SIZE_MAX / sizeof(drwav_int32) / pWav->channels; - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_PCM) { - return drwav_read_pcm_frames_s32__pcm(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ADPCM || pWav->translatedFormatTag == DR_WAVE_FORMAT_DVI_ADPCM) { - return drwav_read_pcm_frames_s32__msadpcm_ima(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_IEEE_FLOAT) { - return drwav_read_pcm_frames_s32__ieee(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_ALAW) { - return drwav_read_pcm_frames_s32__alaw(pWav, framesToRead, pBufferOut); - } - if (pWav->translatedFormatTag == DR_WAVE_FORMAT_MULAW) { - return drwav_read_pcm_frames_s32__mulaw(pWav, framesToRead, pBufferOut); - } - return 0; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s32le(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_s32(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL && drwav__is_little_endian() == DRWAV_FALSE) { - drwav__bswap_samples_s32(pBufferOut, framesRead*pWav->channels); - } - return framesRead; -} -DRWAV_API drwav_uint64 drwav_read_pcm_frames_s32be(drwav* pWav, drwav_uint64 framesToRead, drwav_int32* pBufferOut) -{ - drwav_uint64 framesRead = drwav_read_pcm_frames_s32(pWav, framesToRead, pBufferOut); - if (pBufferOut != NULL && drwav__is_little_endian() == DRWAV_TRUE) { - drwav__bswap_samples_s32(pBufferOut, framesRead*pWav->channels); - } - return framesRead; -} -DRWAV_API void drwav_u8_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = ((int)pIn[i] - 128) << 24; - } -} -DRWAV_API void drwav_s16_to_s32(drwav_int32* pOut, const drwav_int16* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = pIn[i] << 16; - } -} -DRWAV_API void drwav_s24_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - unsigned int s0 = pIn[i*3 + 0]; - unsigned int s1 = pIn[i*3 + 1]; - unsigned int s2 = pIn[i*3 + 2]; - drwav_int32 sample32 = (drwav_int32)((s0 << 8) | (s1 << 16) | (s2 << 24)); - *pOut++ = sample32; - } -} -DRWAV_API void drwav_f32_to_s32(drwav_int32* pOut, const float* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = (drwav_int32)(2147483648.0 * pIn[i]); - } -} -DRWAV_API void drwav_f64_to_s32(drwav_int32* pOut, const double* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = (drwav_int32)(2147483648.0 * pIn[i]); - } -} -DRWAV_API void drwav_alaw_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i = 0; i < sampleCount; ++i) { - *pOut++ = ((drwav_int32)drwav__alaw_to_s16(pIn[i])) << 16; - } -} -DRWAV_API void drwav_mulaw_to_s32(drwav_int32* pOut, const drwav_uint8* pIn, size_t sampleCount) -{ - size_t i; - if (pOut == NULL || pIn == NULL) { - return; - } - for (i= 0; i < sampleCount; ++i) { - *pOut++ = ((drwav_int32)drwav__mulaw_to_s16(pIn[i])) << 16; - } -} -DRWAV_PRIVATE drwav_int16* drwav__read_pcm_frames_and_close_s16(drwav* pWav, unsigned int* channels, unsigned int* sampleRate, drwav_uint64* totalFrameCount) -{ - drwav_uint64 sampleDataSize; - drwav_int16* pSampleData; - drwav_uint64 framesRead; - DRWAV_ASSERT(pWav != NULL); - sampleDataSize = pWav->totalPCMFrameCount * pWav->channels * sizeof(drwav_int16); - if (sampleDataSize > DRWAV_SIZE_MAX) { - drwav_uninit(pWav); - return NULL; - } - pSampleData = (drwav_int16*)drwav__malloc_from_callbacks((size_t)sampleDataSize, &pWav->allocationCallbacks); - if (pSampleData == NULL) { - drwav_uninit(pWav); - return NULL; - } - framesRead = drwav_read_pcm_frames_s16(pWav, (size_t)pWav->totalPCMFrameCount, pSampleData); - if (framesRead != pWav->totalPCMFrameCount) { - drwav__free_from_callbacks(pSampleData, &pWav->allocationCallbacks); - drwav_uninit(pWav); - return NULL; - } - drwav_uninit(pWav); - if (sampleRate) { - *sampleRate = pWav->sampleRate; - } - if (channels) { - *channels = pWav->channels; - } - if (totalFrameCount) { - *totalFrameCount = pWav->totalPCMFrameCount; - } - return pSampleData; -} -DRWAV_PRIVATE float* drwav__read_pcm_frames_and_close_f32(drwav* pWav, unsigned int* channels, unsigned int* sampleRate, drwav_uint64* totalFrameCount) -{ - drwav_uint64 sampleDataSize; - float* pSampleData; - drwav_uint64 framesRead; - DRWAV_ASSERT(pWav != NULL); - sampleDataSize = pWav->totalPCMFrameCount * pWav->channels * sizeof(float); - if (sampleDataSize > DRWAV_SIZE_MAX) { - drwav_uninit(pWav); - return NULL; - } - pSampleData = (float*)drwav__malloc_from_callbacks((size_t)sampleDataSize, &pWav->allocationCallbacks); - if (pSampleData == NULL) { - drwav_uninit(pWav); - return NULL; - } - framesRead = drwav_read_pcm_frames_f32(pWav, (size_t)pWav->totalPCMFrameCount, pSampleData); - if (framesRead != pWav->totalPCMFrameCount) { - drwav__free_from_callbacks(pSampleData, &pWav->allocationCallbacks); - drwav_uninit(pWav); - return NULL; - } - drwav_uninit(pWav); - if (sampleRate) { - *sampleRate = pWav->sampleRate; - } - if (channels) { - *channels = pWav->channels; - } - if (totalFrameCount) { - *totalFrameCount = pWav->totalPCMFrameCount; - } - return pSampleData; -} -DRWAV_PRIVATE drwav_int32* drwav__read_pcm_frames_and_close_s32(drwav* pWav, unsigned int* channels, unsigned int* sampleRate, drwav_uint64* totalFrameCount) -{ - drwav_uint64 sampleDataSize; - drwav_int32* pSampleData; - drwav_uint64 framesRead; - DRWAV_ASSERT(pWav != NULL); - sampleDataSize = pWav->totalPCMFrameCount * pWav->channels * sizeof(drwav_int32); - if (sampleDataSize > DRWAV_SIZE_MAX) { - drwav_uninit(pWav); - return NULL; - } - pSampleData = (drwav_int32*)drwav__malloc_from_callbacks((size_t)sampleDataSize, &pWav->allocationCallbacks); - if (pSampleData == NULL) { - drwav_uninit(pWav); - return NULL; - } - framesRead = drwav_read_pcm_frames_s32(pWav, (size_t)pWav->totalPCMFrameCount, pSampleData); - if (framesRead != pWav->totalPCMFrameCount) { - drwav__free_from_callbacks(pSampleData, &pWav->allocationCallbacks); - drwav_uninit(pWav); - return NULL; - } - drwav_uninit(pWav); - if (sampleRate) { - *sampleRate = pWav->sampleRate; - } - if (channels) { - *channels = pWav->channels; - } - if (totalFrameCount) { - *totalFrameCount = pWav->totalPCMFrameCount; - } - return pSampleData; -} -DRWAV_API drwav_int16* drwav_open_and_read_pcm_frames_s16(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init(&wav, onRead, onSeek, pUserData, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s16(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API float* drwav_open_and_read_pcm_frames_f32(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init(&wav, onRead, onSeek, pUserData, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_f32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API drwav_int32* drwav_open_and_read_pcm_frames_s32(drwav_read_proc onRead, drwav_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init(&wav, onRead, onSeek, pUserData, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -#ifndef DR_WAV_NO_STDIO -DRWAV_API drwav_int16* drwav_open_file_and_read_pcm_frames_s16(const char* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_file(&wav, filename, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s16(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API float* drwav_open_file_and_read_pcm_frames_f32(const char* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_file(&wav, filename, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_f32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API drwav_int32* drwav_open_file_and_read_pcm_frames_s32(const char* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_file(&wav, filename, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -#ifndef DR_WAV_NO_WCHAR -DRWAV_API drwav_int16* drwav_open_file_and_read_pcm_frames_s16_w(const wchar_t* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (channelsOut) { - *channelsOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_file_w(&wav, filename, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s16(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API float* drwav_open_file_and_read_pcm_frames_f32_w(const wchar_t* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (channelsOut) { - *channelsOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_file_w(&wav, filename, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_f32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API drwav_int32* drwav_open_file_and_read_pcm_frames_s32_w(const wchar_t* filename, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (channelsOut) { - *channelsOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_file_w(&wav, filename, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -#endif -#endif -DRWAV_API drwav_int16* drwav_open_memory_and_read_pcm_frames_s16(const void* data, size_t dataSize, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_memory(&wav, data, dataSize, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s16(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API float* drwav_open_memory_and_read_pcm_frames_f32(const void* data, size_t dataSize, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_memory(&wav, data, dataSize, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_f32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -DRWAV_API drwav_int32* drwav_open_memory_and_read_pcm_frames_s32(const void* data, size_t dataSize, unsigned int* channelsOut, unsigned int* sampleRateOut, drwav_uint64* totalFrameCountOut, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - drwav wav; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalFrameCountOut) { - *totalFrameCountOut = 0; - } - if (!drwav_init_memory(&wav, data, dataSize, pAllocationCallbacks)) { - return NULL; - } - return drwav__read_pcm_frames_and_close_s32(&wav, channelsOut, sampleRateOut, totalFrameCountOut); -} -#endif -DRWAV_API void drwav_free(void* p, const drwav_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - drwav__free_from_callbacks(p, pAllocationCallbacks); - } else { - drwav__free_default(p, NULL); - } -} -DRWAV_API drwav_uint16 drwav_bytes_to_u16(const drwav_uint8* data) -{ - return ((drwav_uint16)data[0] << 0) | ((drwav_uint16)data[1] << 8); -} -DRWAV_API drwav_int16 drwav_bytes_to_s16(const drwav_uint8* data) -{ - return (drwav_int16)drwav_bytes_to_u16(data); -} -DRWAV_API drwav_uint32 drwav_bytes_to_u32(const drwav_uint8* data) -{ - return ((drwav_uint32)data[0] << 0) | ((drwav_uint32)data[1] << 8) | ((drwav_uint32)data[2] << 16) | ((drwav_uint32)data[3] << 24); -} -DRWAV_API float drwav_bytes_to_f32(const drwav_uint8* data) -{ - union { - drwav_uint32 u32; - float f32; - } value; - value.u32 = drwav_bytes_to_u32(data); - return value.f32; -} -DRWAV_API drwav_int32 drwav_bytes_to_s32(const drwav_uint8* data) -{ - return (drwav_int32)drwav_bytes_to_u32(data); -} -DRWAV_API drwav_uint64 drwav_bytes_to_u64(const drwav_uint8* data) -{ - return - ((drwav_uint64)data[0] << 0) | ((drwav_uint64)data[1] << 8) | ((drwav_uint64)data[2] << 16) | ((drwav_uint64)data[3] << 24) | - ((drwav_uint64)data[4] << 32) | ((drwav_uint64)data[5] << 40) | ((drwav_uint64)data[6] << 48) | ((drwav_uint64)data[7] << 56); -} -DRWAV_API drwav_int64 drwav_bytes_to_s64(const drwav_uint8* data) -{ - return (drwav_int64)drwav_bytes_to_u64(data); -} -DRWAV_API drwav_bool32 drwav_guid_equal(const drwav_uint8 a[16], const drwav_uint8 b[16]) -{ - int i; - for (i = 0; i < 16; i += 1) { - if (a[i] != b[i]) { - return DRWAV_FALSE; - } - } - return DRWAV_TRUE; -} -DRWAV_API drwav_bool32 drwav_fourcc_equal(const drwav_uint8* a, const char* b) -{ - return - a[0] == b[0] && - a[1] == b[1] && - a[2] == b[2] && - a[3] == b[3]; -} -#ifdef __MRC__ -#pragma options opt reset -#endif -#endif -/* dr_wav_c end */ -#endif /* DRWAV_IMPLEMENTATION */ -#endif /* MA_NO_WAV */ - -#if !defined(MA_NO_FLAC) && !defined(MA_NO_DECODING) -#if !defined(DR_FLAC_IMPLEMENTATION) && !defined(DRFLAC_IMPLEMENTATION) /* For backwards compatibility. Will be removed in version 0.11 for cleanliness. */ -/* dr_flac_c begin */ -#ifndef dr_flac_c -#define dr_flac_c -#if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic push - #if __GNUC__ >= 7 - #pragma GCC diagnostic ignored "-Wimplicit-fallthrough" - #endif -#endif -#ifdef __linux__ - #ifndef _BSD_SOURCE - #define _BSD_SOURCE - #endif - #ifndef _DEFAULT_SOURCE - #define _DEFAULT_SOURCE - #endif - #ifndef __USE_BSD - #define __USE_BSD - #endif - #include -#endif -#include -#include -#ifdef _MSC_VER - #define DRFLAC_INLINE __forceinline -#elif defined(__GNUC__) - #if defined(__STRICT_ANSI__) - #define DRFLAC_GNUC_INLINE_HINT __inline__ - #else - #define DRFLAC_GNUC_INLINE_HINT inline - #endif - #if (__GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 2)) || defined(__clang__) - #define DRFLAC_INLINE DRFLAC_GNUC_INLINE_HINT __attribute__((always_inline)) - #else - #define DRFLAC_INLINE DRFLAC_GNUC_INLINE_HINT - #endif -#elif defined(__WATCOMC__) - #define DRFLAC_INLINE __inline -#else - #define DRFLAC_INLINE -#endif -#if defined(__x86_64__) || defined(_M_X64) - #define DRFLAC_X64 -#elif defined(__i386) || defined(_M_IX86) - #define DRFLAC_X86 -#elif defined(__arm__) || defined(_M_ARM) || defined(__arm64) || defined(__arm64__) || defined(__aarch64__) || defined(_M_ARM64) - #define DRFLAC_ARM -#endif -#if !defined(DR_FLAC_NO_SIMD) - #if defined(DRFLAC_X64) || defined(DRFLAC_X86) - #if defined(_MSC_VER) && !defined(__clang__) - #if _MSC_VER >= 1400 && !defined(DRFLAC_NO_SSE2) - #define DRFLAC_SUPPORT_SSE2 - #endif - #if _MSC_VER >= 1600 && !defined(DRFLAC_NO_SSE41) - #define DRFLAC_SUPPORT_SSE41 - #endif - #elif defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) - #if defined(__SSE2__) && !defined(DRFLAC_NO_SSE2) - #define DRFLAC_SUPPORT_SSE2 - #endif - #if defined(__SSE4_1__) && !defined(DRFLAC_NO_SSE41) - #define DRFLAC_SUPPORT_SSE41 - #endif - #endif - #if !defined(__GNUC__) && !defined(__clang__) && defined(__has_include) - #if !defined(DRFLAC_SUPPORT_SSE2) && !defined(DRFLAC_NO_SSE2) && __has_include() - #define DRFLAC_SUPPORT_SSE2 - #endif - #if !defined(DRFLAC_SUPPORT_SSE41) && !defined(DRFLAC_NO_SSE41) && __has_include() - #define DRFLAC_SUPPORT_SSE41 - #endif - #endif - #if defined(DRFLAC_SUPPORT_SSE41) - #include - #elif defined(DRFLAC_SUPPORT_SSE2) - #include - #endif - #endif - #if defined(DRFLAC_ARM) - #if !defined(DRFLAC_NO_NEON) && (defined(__ARM_NEON) || defined(__aarch64__) || defined(_M_ARM64)) - #define DRFLAC_SUPPORT_NEON - #include - #endif - #endif -#endif -#if !defined(DR_FLAC_NO_SIMD) && (defined(DRFLAC_X86) || defined(DRFLAC_X64)) - #if defined(_MSC_VER) && !defined(__clang__) - #if _MSC_VER >= 1400 - #include - static void drflac__cpuid(int info[4], int fid) - { - __cpuid(info, fid); - } - #else - #define DRFLAC_NO_CPUID - #endif - #else - #if defined(__GNUC__) || defined(__clang__) - static void drflac__cpuid(int info[4], int fid) - { - #if defined(DRFLAC_X86) && defined(__PIC__) - __asm__ __volatile__ ( - "xchg{l} {%%}ebx, %k1;" - "cpuid;" - "xchg{l} {%%}ebx, %k1;" - : "=a"(info[0]), "=&r"(info[1]), "=c"(info[2]), "=d"(info[3]) : "a"(fid), "c"(0) - ); - #else - __asm__ __volatile__ ( - "cpuid" : "=a"(info[0]), "=b"(info[1]), "=c"(info[2]), "=d"(info[3]) : "a"(fid), "c"(0) - ); - #endif - } - #else - #define DRFLAC_NO_CPUID - #endif - #endif -#else - #define DRFLAC_NO_CPUID -#endif -static DRFLAC_INLINE drflac_bool32 drflac_has_sse2(void) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - #if (defined(DRFLAC_X64) || defined(DRFLAC_X86)) && !defined(DRFLAC_NO_SSE2) - #if defined(DRFLAC_X64) - return DRFLAC_TRUE; - #elif (defined(_M_IX86_FP) && _M_IX86_FP == 2) || defined(__SSE2__) - return DRFLAC_TRUE; - #else - #if defined(DRFLAC_NO_CPUID) - return DRFLAC_FALSE; - #else - int info[4]; - drflac__cpuid(info, 1); - return (info[3] & (1 << 26)) != 0; - #endif - #endif - #else - return DRFLAC_FALSE; - #endif -#else - return DRFLAC_FALSE; -#endif -} -static DRFLAC_INLINE drflac_bool32 drflac_has_sse41(void) -{ -#if defined(DRFLAC_SUPPORT_SSE41) - #if (defined(DRFLAC_X64) || defined(DRFLAC_X86)) && !defined(DRFLAC_NO_SSE41) - #if defined(__SSE4_1__) || defined(__AVX__) - return DRFLAC_TRUE; - #else - #if defined(DRFLAC_NO_CPUID) - return DRFLAC_FALSE; - #else - int info[4]; - drflac__cpuid(info, 1); - return (info[2] & (1 << 19)) != 0; - #endif - #endif - #else - return DRFLAC_FALSE; - #endif -#else - return DRFLAC_FALSE; -#endif -} -#if defined(_MSC_VER) && _MSC_VER >= 1500 && (defined(DRFLAC_X86) || defined(DRFLAC_X64)) && !defined(__clang__) - #define DRFLAC_HAS_LZCNT_INTRINSIC -#elif (defined(__GNUC__) && ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7))) - #define DRFLAC_HAS_LZCNT_INTRINSIC -#elif defined(__clang__) - #if defined(__has_builtin) - #if __has_builtin(__builtin_clzll) || __has_builtin(__builtin_clzl) - #define DRFLAC_HAS_LZCNT_INTRINSIC - #endif - #endif -#endif -#if defined(_MSC_VER) && _MSC_VER >= 1400 && !defined(__clang__) - #define DRFLAC_HAS_BYTESWAP16_INTRINSIC - #define DRFLAC_HAS_BYTESWAP32_INTRINSIC - #define DRFLAC_HAS_BYTESWAP64_INTRINSIC -#elif defined(__clang__) - #if defined(__has_builtin) - #if __has_builtin(__builtin_bswap16) - #define DRFLAC_HAS_BYTESWAP16_INTRINSIC - #endif - #if __has_builtin(__builtin_bswap32) - #define DRFLAC_HAS_BYTESWAP32_INTRINSIC - #endif - #if __has_builtin(__builtin_bswap64) - #define DRFLAC_HAS_BYTESWAP64_INTRINSIC - #endif - #endif -#elif defined(__GNUC__) - #if ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)) - #define DRFLAC_HAS_BYTESWAP32_INTRINSIC - #define DRFLAC_HAS_BYTESWAP64_INTRINSIC - #endif - #if ((__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8)) - #define DRFLAC_HAS_BYTESWAP16_INTRINSIC - #endif -#elif defined(__WATCOMC__) && defined(__386__) - #define DRFLAC_HAS_BYTESWAP16_INTRINSIC - #define DRFLAC_HAS_BYTESWAP32_INTRINSIC - #define DRFLAC_HAS_BYTESWAP64_INTRINSIC - extern __inline drflac_uint16 _watcom_bswap16(drflac_uint16); - extern __inline drflac_uint32 _watcom_bswap32(drflac_uint32); - extern __inline drflac_uint64 _watcom_bswap64(drflac_uint64); -#pragma aux _watcom_bswap16 = \ - "xchg al, ah" \ - parm [ax] \ - value [ax] \ - modify nomemory; -#pragma aux _watcom_bswap32 = \ - "bswap eax" \ - parm [eax] \ - value [eax] \ - modify nomemory; -#pragma aux _watcom_bswap64 = \ - "bswap eax" \ - "bswap edx" \ - "xchg eax,edx" \ - parm [eax edx] \ - value [eax edx] \ - modify nomemory; -#endif -#ifndef DRFLAC_ASSERT -#include -#define DRFLAC_ASSERT(expression) assert(expression) -#endif -#ifndef DRFLAC_MALLOC -#define DRFLAC_MALLOC(sz) malloc((sz)) -#endif -#ifndef DRFLAC_REALLOC -#define DRFLAC_REALLOC(p, sz) realloc((p), (sz)) -#endif -#ifndef DRFLAC_FREE -#define DRFLAC_FREE(p) free((p)) -#endif -#ifndef DRFLAC_COPY_MEMORY -#define DRFLAC_COPY_MEMORY(dst, src, sz) memcpy((dst), (src), (sz)) -#endif -#ifndef DRFLAC_ZERO_MEMORY -#define DRFLAC_ZERO_MEMORY(p, sz) memset((p), 0, (sz)) -#endif -#ifndef DRFLAC_ZERO_OBJECT -#define DRFLAC_ZERO_OBJECT(p) DRFLAC_ZERO_MEMORY((p), sizeof(*(p))) -#endif -#define DRFLAC_MAX_SIMD_VECTOR_SIZE 64 -typedef drflac_int32 drflac_result; -#define DRFLAC_SUCCESS 0 -#define DRFLAC_ERROR -1 -#define DRFLAC_INVALID_ARGS -2 -#define DRFLAC_INVALID_OPERATION -3 -#define DRFLAC_OUT_OF_MEMORY -4 -#define DRFLAC_OUT_OF_RANGE -5 -#define DRFLAC_ACCESS_DENIED -6 -#define DRFLAC_DOES_NOT_EXIST -7 -#define DRFLAC_ALREADY_EXISTS -8 -#define DRFLAC_TOO_MANY_OPEN_FILES -9 -#define DRFLAC_INVALID_FILE -10 -#define DRFLAC_TOO_BIG -11 -#define DRFLAC_PATH_TOO_LONG -12 -#define DRFLAC_NAME_TOO_LONG -13 -#define DRFLAC_NOT_DIRECTORY -14 -#define DRFLAC_IS_DIRECTORY -15 -#define DRFLAC_DIRECTORY_NOT_EMPTY -16 -#define DRFLAC_END_OF_FILE -17 -#define DRFLAC_NO_SPACE -18 -#define DRFLAC_BUSY -19 -#define DRFLAC_IO_ERROR -20 -#define DRFLAC_INTERRUPT -21 -#define DRFLAC_UNAVAILABLE -22 -#define DRFLAC_ALREADY_IN_USE -23 -#define DRFLAC_BAD_ADDRESS -24 -#define DRFLAC_BAD_SEEK -25 -#define DRFLAC_BAD_PIPE -26 -#define DRFLAC_DEADLOCK -27 -#define DRFLAC_TOO_MANY_LINKS -28 -#define DRFLAC_NOT_IMPLEMENTED -29 -#define DRFLAC_NO_MESSAGE -30 -#define DRFLAC_BAD_MESSAGE -31 -#define DRFLAC_NO_DATA_AVAILABLE -32 -#define DRFLAC_INVALID_DATA -33 -#define DRFLAC_TIMEOUT -34 -#define DRFLAC_NO_NETWORK -35 -#define DRFLAC_NOT_UNIQUE -36 -#define DRFLAC_NOT_SOCKET -37 -#define DRFLAC_NO_ADDRESS -38 -#define DRFLAC_BAD_PROTOCOL -39 -#define DRFLAC_PROTOCOL_UNAVAILABLE -40 -#define DRFLAC_PROTOCOL_NOT_SUPPORTED -41 -#define DRFLAC_PROTOCOL_FAMILY_NOT_SUPPORTED -42 -#define DRFLAC_ADDRESS_FAMILY_NOT_SUPPORTED -43 -#define DRFLAC_SOCKET_NOT_SUPPORTED -44 -#define DRFLAC_CONNECTION_RESET -45 -#define DRFLAC_ALREADY_CONNECTED -46 -#define DRFLAC_NOT_CONNECTED -47 -#define DRFLAC_CONNECTION_REFUSED -48 -#define DRFLAC_NO_HOST -49 -#define DRFLAC_IN_PROGRESS -50 -#define DRFLAC_CANCELLED -51 -#define DRFLAC_MEMORY_ALREADY_MAPPED -52 -#define DRFLAC_AT_END -53 -#define DRFLAC_CRC_MISMATCH -128 -#define DRFLAC_SUBFRAME_CONSTANT 0 -#define DRFLAC_SUBFRAME_VERBATIM 1 -#define DRFLAC_SUBFRAME_FIXED 8 -#define DRFLAC_SUBFRAME_LPC 32 -#define DRFLAC_SUBFRAME_RESERVED 255 -#define DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE 0 -#define DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE2 1 -#define DRFLAC_CHANNEL_ASSIGNMENT_INDEPENDENT 0 -#define DRFLAC_CHANNEL_ASSIGNMENT_LEFT_SIDE 8 -#define DRFLAC_CHANNEL_ASSIGNMENT_RIGHT_SIDE 9 -#define DRFLAC_CHANNEL_ASSIGNMENT_MID_SIDE 10 -#define DRFLAC_SEEKPOINT_SIZE_IN_BYTES 18 -#define DRFLAC_CUESHEET_TRACK_SIZE_IN_BYTES 36 -#define DRFLAC_CUESHEET_TRACK_INDEX_SIZE_IN_BYTES 12 -#define drflac_align(x, a) ((((x) + (a) - 1) / (a)) * (a)) -DRFLAC_API void drflac_version(drflac_uint32* pMajor, drflac_uint32* pMinor, drflac_uint32* pRevision) -{ - if (pMajor) { - *pMajor = DRFLAC_VERSION_MAJOR; - } - if (pMinor) { - *pMinor = DRFLAC_VERSION_MINOR; - } - if (pRevision) { - *pRevision = DRFLAC_VERSION_REVISION; - } -} -DRFLAC_API const char* drflac_version_string(void) -{ - return DRFLAC_VERSION_STRING; -} -#if defined(__has_feature) - #if __has_feature(thread_sanitizer) - #define DRFLAC_NO_THREAD_SANITIZE __attribute__((no_sanitize("thread"))) - #else - #define DRFLAC_NO_THREAD_SANITIZE - #endif -#else - #define DRFLAC_NO_THREAD_SANITIZE -#endif -#if defined(DRFLAC_HAS_LZCNT_INTRINSIC) -static drflac_bool32 drflac__gIsLZCNTSupported = DRFLAC_FALSE; -#endif -#ifndef DRFLAC_NO_CPUID -static drflac_bool32 drflac__gIsSSE2Supported = DRFLAC_FALSE; -static drflac_bool32 drflac__gIsSSE41Supported = DRFLAC_FALSE; -DRFLAC_NO_THREAD_SANITIZE static void drflac__init_cpu_caps(void) -{ - static drflac_bool32 isCPUCapsInitialized = DRFLAC_FALSE; - if (!isCPUCapsInitialized) { -#if defined(DRFLAC_HAS_LZCNT_INTRINSIC) - int info[4] = {0}; - drflac__cpuid(info, 0x80000001); - drflac__gIsLZCNTSupported = (info[2] & (1 << 5)) != 0; -#endif - drflac__gIsSSE2Supported = drflac_has_sse2(); - drflac__gIsSSE41Supported = drflac_has_sse41(); - isCPUCapsInitialized = DRFLAC_TRUE; - } -} -#else -static drflac_bool32 drflac__gIsNEONSupported = DRFLAC_FALSE; -static DRFLAC_INLINE drflac_bool32 drflac__has_neon(void) -{ -#if defined(DRFLAC_SUPPORT_NEON) - #if defined(DRFLAC_ARM) && !defined(DRFLAC_NO_NEON) - #if (defined(__ARM_NEON) || defined(__aarch64__) || defined(_M_ARM64)) - return DRFLAC_TRUE; - #else - return DRFLAC_FALSE; - #endif - #else - return DRFLAC_FALSE; - #endif -#else - return DRFLAC_FALSE; -#endif -} -DRFLAC_NO_THREAD_SANITIZE static void drflac__init_cpu_caps(void) -{ - drflac__gIsNEONSupported = drflac__has_neon(); -#if defined(DRFLAC_HAS_LZCNT_INTRINSIC) && defined(DRFLAC_ARM) && (defined(__ARM_ARCH) && __ARM_ARCH >= 5) - drflac__gIsLZCNTSupported = DRFLAC_TRUE; -#endif -} -#endif -static DRFLAC_INLINE drflac_bool32 drflac__is_little_endian(void) -{ -#if defined(DRFLAC_X86) || defined(DRFLAC_X64) - return DRFLAC_TRUE; -#elif defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN - return DRFLAC_TRUE; -#else - int n = 1; - return (*(char*)&n) == 1; -#endif -} -static DRFLAC_INLINE drflac_uint16 drflac__swap_endian_uint16(drflac_uint16 n) -{ -#ifdef DRFLAC_HAS_BYTESWAP16_INTRINSIC - #if defined(_MSC_VER) && !defined(__clang__) - return _byteswap_ushort(n); - #elif defined(__GNUC__) || defined(__clang__) - return __builtin_bswap16(n); - #elif defined(__WATCOMC__) && defined(__386__) - return _watcom_bswap16(n); - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & 0xFF00) >> 8) | - ((n & 0x00FF) << 8); -#endif -} -static DRFLAC_INLINE drflac_uint32 drflac__swap_endian_uint32(drflac_uint32 n) -{ -#ifdef DRFLAC_HAS_BYTESWAP32_INTRINSIC - #if defined(_MSC_VER) && !defined(__clang__) - return _byteswap_ulong(n); - #elif defined(__GNUC__) || defined(__clang__) - #if defined(DRFLAC_ARM) && (defined(__ARM_ARCH) && __ARM_ARCH >= 6) && !defined(DRFLAC_64BIT) - drflac_uint32 r; - __asm__ __volatile__ ( - #if defined(DRFLAC_64BIT) - "rev %w[out], %w[in]" : [out]"=r"(r) : [in]"r"(n) - #else - "rev %[out], %[in]" : [out]"=r"(r) : [in]"r"(n) - #endif - ); - return r; - #else - return __builtin_bswap32(n); - #endif - #elif defined(__WATCOMC__) && defined(__386__) - return _watcom_bswap32(n); - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & 0xFF000000) >> 24) | - ((n & 0x00FF0000) >> 8) | - ((n & 0x0000FF00) << 8) | - ((n & 0x000000FF) << 24); -#endif -} -static DRFLAC_INLINE drflac_uint64 drflac__swap_endian_uint64(drflac_uint64 n) -{ -#ifdef DRFLAC_HAS_BYTESWAP64_INTRINSIC - #if defined(_MSC_VER) && !defined(__clang__) - return _byteswap_uint64(n); - #elif defined(__GNUC__) || defined(__clang__) - return __builtin_bswap64(n); - #elif defined(__WATCOMC__) && defined(__386__) - return _watcom_bswap64(n); - #else - #error "This compiler does not support the byte swap intrinsic." - #endif -#else - return ((n & ((drflac_uint64)0xFF000000 << 32)) >> 56) | - ((n & ((drflac_uint64)0x00FF0000 << 32)) >> 40) | - ((n & ((drflac_uint64)0x0000FF00 << 32)) >> 24) | - ((n & ((drflac_uint64)0x000000FF << 32)) >> 8) | - ((n & ((drflac_uint64)0xFF000000 )) << 8) | - ((n & ((drflac_uint64)0x00FF0000 )) << 24) | - ((n & ((drflac_uint64)0x0000FF00 )) << 40) | - ((n & ((drflac_uint64)0x000000FF )) << 56); -#endif -} -static DRFLAC_INLINE drflac_uint16 drflac__be2host_16(drflac_uint16 n) -{ - if (drflac__is_little_endian()) { - return drflac__swap_endian_uint16(n); - } - return n; -} -static DRFLAC_INLINE drflac_uint32 drflac__be2host_32(drflac_uint32 n) -{ - if (drflac__is_little_endian()) { - return drflac__swap_endian_uint32(n); - } - return n; -} -static DRFLAC_INLINE drflac_uint32 drflac__be2host_32_ptr_unaligned(const void* pData) -{ - const drflac_uint8* pNum = (drflac_uint8*)pData; - return *(pNum) << 24 | *(pNum+1) << 16 | *(pNum+2) << 8 | *(pNum+3); -} -static DRFLAC_INLINE drflac_uint64 drflac__be2host_64(drflac_uint64 n) -{ - if (drflac__is_little_endian()) { - return drflac__swap_endian_uint64(n); - } - return n; -} -static DRFLAC_INLINE drflac_uint32 drflac__le2host_32(drflac_uint32 n) -{ - if (!drflac__is_little_endian()) { - return drflac__swap_endian_uint32(n); - } - return n; -} -static DRFLAC_INLINE drflac_uint32 drflac__le2host_32_ptr_unaligned(const void* pData) -{ - const drflac_uint8* pNum = (drflac_uint8*)pData; - return *pNum | *(pNum+1) << 8 | *(pNum+2) << 16 | *(pNum+3) << 24; -} -static DRFLAC_INLINE drflac_uint32 drflac__unsynchsafe_32(drflac_uint32 n) -{ - drflac_uint32 result = 0; - result |= (n & 0x7F000000) >> 3; - result |= (n & 0x007F0000) >> 2; - result |= (n & 0x00007F00) >> 1; - result |= (n & 0x0000007F) >> 0; - return result; -} -static drflac_uint8 drflac__crc8_table[] = { - 0x00, 0x07, 0x0E, 0x09, 0x1C, 0x1B, 0x12, 0x15, 0x38, 0x3F, 0x36, 0x31, 0x24, 0x23, 0x2A, 0x2D, - 0x70, 0x77, 0x7E, 0x79, 0x6C, 0x6B, 0x62, 0x65, 0x48, 0x4F, 0x46, 0x41, 0x54, 0x53, 0x5A, 0x5D, - 0xE0, 0xE7, 0xEE, 0xE9, 0xFC, 0xFB, 0xF2, 0xF5, 0xD8, 0xDF, 0xD6, 0xD1, 0xC4, 0xC3, 0xCA, 0xCD, - 0x90, 0x97, 0x9E, 0x99, 0x8C, 0x8B, 0x82, 0x85, 0xA8, 0xAF, 0xA6, 0xA1, 0xB4, 0xB3, 0xBA, 0xBD, - 0xC7, 0xC0, 0xC9, 0xCE, 0xDB, 0xDC, 0xD5, 0xD2, 0xFF, 0xF8, 0xF1, 0xF6, 0xE3, 0xE4, 0xED, 0xEA, - 0xB7, 0xB0, 0xB9, 0xBE, 0xAB, 0xAC, 0xA5, 0xA2, 0x8F, 0x88, 0x81, 0x86, 0x93, 0x94, 0x9D, 0x9A, - 0x27, 0x20, 0x29, 0x2E, 0x3B, 0x3C, 0x35, 0x32, 0x1F, 0x18, 0x11, 0x16, 0x03, 0x04, 0x0D, 0x0A, - 0x57, 0x50, 0x59, 0x5E, 0x4B, 0x4C, 0x45, 0x42, 0x6F, 0x68, 0x61, 0x66, 0x73, 0x74, 0x7D, 0x7A, - 0x89, 0x8E, 0x87, 0x80, 0x95, 0x92, 0x9B, 0x9C, 0xB1, 0xB6, 0xBF, 0xB8, 0xAD, 0xAA, 0xA3, 0xA4, - 0xF9, 0xFE, 0xF7, 0xF0, 0xE5, 0xE2, 0xEB, 0xEC, 0xC1, 0xC6, 0xCF, 0xC8, 0xDD, 0xDA, 0xD3, 0xD4, - 0x69, 0x6E, 0x67, 0x60, 0x75, 0x72, 0x7B, 0x7C, 0x51, 0x56, 0x5F, 0x58, 0x4D, 0x4A, 0x43, 0x44, - 0x19, 0x1E, 0x17, 0x10, 0x05, 0x02, 0x0B, 0x0C, 0x21, 0x26, 0x2F, 0x28, 0x3D, 0x3A, 0x33, 0x34, - 0x4E, 0x49, 0x40, 0x47, 0x52, 0x55, 0x5C, 0x5B, 0x76, 0x71, 0x78, 0x7F, 0x6A, 0x6D, 0x64, 0x63, - 0x3E, 0x39, 0x30, 0x37, 0x22, 0x25, 0x2C, 0x2B, 0x06, 0x01, 0x08, 0x0F, 0x1A, 0x1D, 0x14, 0x13, - 0xAE, 0xA9, 0xA0, 0xA7, 0xB2, 0xB5, 0xBC, 0xBB, 0x96, 0x91, 0x98, 0x9F, 0x8A, 0x8D, 0x84, 0x83, - 0xDE, 0xD9, 0xD0, 0xD7, 0xC2, 0xC5, 0xCC, 0xCB, 0xE6, 0xE1, 0xE8, 0xEF, 0xFA, 0xFD, 0xF4, 0xF3 -}; -static drflac_uint16 drflac__crc16_table[] = { - 0x0000, 0x8005, 0x800F, 0x000A, 0x801B, 0x001E, 0x0014, 0x8011, - 0x8033, 0x0036, 0x003C, 0x8039, 0x0028, 0x802D, 0x8027, 0x0022, - 0x8063, 0x0066, 0x006C, 0x8069, 0x0078, 0x807D, 0x8077, 0x0072, - 0x0050, 0x8055, 0x805F, 0x005A, 0x804B, 0x004E, 0x0044, 0x8041, - 0x80C3, 0x00C6, 0x00CC, 0x80C9, 0x00D8, 0x80DD, 0x80D7, 0x00D2, - 0x00F0, 0x80F5, 0x80FF, 0x00FA, 0x80EB, 0x00EE, 0x00E4, 0x80E1, - 0x00A0, 0x80A5, 0x80AF, 0x00AA, 0x80BB, 0x00BE, 0x00B4, 0x80B1, - 0x8093, 0x0096, 0x009C, 0x8099, 0x0088, 0x808D, 0x8087, 0x0082, - 0x8183, 0x0186, 0x018C, 0x8189, 0x0198, 0x819D, 0x8197, 0x0192, - 0x01B0, 0x81B5, 0x81BF, 0x01BA, 0x81AB, 0x01AE, 0x01A4, 0x81A1, - 0x01E0, 0x81E5, 0x81EF, 0x01EA, 0x81FB, 0x01FE, 0x01F4, 0x81F1, - 0x81D3, 0x01D6, 0x01DC, 0x81D9, 0x01C8, 0x81CD, 0x81C7, 0x01C2, - 0x0140, 0x8145, 0x814F, 0x014A, 0x815B, 0x015E, 0x0154, 0x8151, - 0x8173, 0x0176, 0x017C, 0x8179, 0x0168, 0x816D, 0x8167, 0x0162, - 0x8123, 0x0126, 0x012C, 0x8129, 0x0138, 0x813D, 0x8137, 0x0132, - 0x0110, 0x8115, 0x811F, 0x011A, 0x810B, 0x010E, 0x0104, 0x8101, - 0x8303, 0x0306, 0x030C, 0x8309, 0x0318, 0x831D, 0x8317, 0x0312, - 0x0330, 0x8335, 0x833F, 0x033A, 0x832B, 0x032E, 0x0324, 0x8321, - 0x0360, 0x8365, 0x836F, 0x036A, 0x837B, 0x037E, 0x0374, 0x8371, - 0x8353, 0x0356, 0x035C, 0x8359, 0x0348, 0x834D, 0x8347, 0x0342, - 0x03C0, 0x83C5, 0x83CF, 0x03CA, 0x83DB, 0x03DE, 0x03D4, 0x83D1, - 0x83F3, 0x03F6, 0x03FC, 0x83F9, 0x03E8, 0x83ED, 0x83E7, 0x03E2, - 0x83A3, 0x03A6, 0x03AC, 0x83A9, 0x03B8, 0x83BD, 0x83B7, 0x03B2, - 0x0390, 0x8395, 0x839F, 0x039A, 0x838B, 0x038E, 0x0384, 0x8381, - 0x0280, 0x8285, 0x828F, 0x028A, 0x829B, 0x029E, 0x0294, 0x8291, - 0x82B3, 0x02B6, 0x02BC, 0x82B9, 0x02A8, 0x82AD, 0x82A7, 0x02A2, - 0x82E3, 0x02E6, 0x02EC, 0x82E9, 0x02F8, 0x82FD, 0x82F7, 0x02F2, - 0x02D0, 0x82D5, 0x82DF, 0x02DA, 0x82CB, 0x02CE, 0x02C4, 0x82C1, - 0x8243, 0x0246, 0x024C, 0x8249, 0x0258, 0x825D, 0x8257, 0x0252, - 0x0270, 0x8275, 0x827F, 0x027A, 0x826B, 0x026E, 0x0264, 0x8261, - 0x0220, 0x8225, 0x822F, 0x022A, 0x823B, 0x023E, 0x0234, 0x8231, - 0x8213, 0x0216, 0x021C, 0x8219, 0x0208, 0x820D, 0x8207, 0x0202 -}; -static DRFLAC_INLINE drflac_uint8 drflac_crc8_byte(drflac_uint8 crc, drflac_uint8 data) -{ - return drflac__crc8_table[crc ^ data]; -} -static DRFLAC_INLINE drflac_uint8 drflac_crc8(drflac_uint8 crc, drflac_uint32 data, drflac_uint32 count) -{ -#ifdef DR_FLAC_NO_CRC - (void)crc; - (void)data; - (void)count; - return 0; -#else -#if 0 - drflac_uint8 p = 0x07; - for (int i = count-1; i >= 0; --i) { - drflac_uint8 bit = (data & (1 << i)) >> i; - if (crc & 0x80) { - crc = ((crc << 1) | bit) ^ p; - } else { - crc = ((crc << 1) | bit); - } - } - return crc; -#else - drflac_uint32 wholeBytes; - drflac_uint32 leftoverBits; - drflac_uint64 leftoverDataMask; - static drflac_uint64 leftoverDataMaskTable[8] = { - 0x00, 0x01, 0x03, 0x07, 0x0F, 0x1F, 0x3F, 0x7F - }; - DRFLAC_ASSERT(count <= 32); - wholeBytes = count >> 3; - leftoverBits = count - (wholeBytes*8); - leftoverDataMask = leftoverDataMaskTable[leftoverBits]; - switch (wholeBytes) { - case 4: crc = drflac_crc8_byte(crc, (drflac_uint8)((data & (0xFF000000UL << leftoverBits)) >> (24 + leftoverBits))); - case 3: crc = drflac_crc8_byte(crc, (drflac_uint8)((data & (0x00FF0000UL << leftoverBits)) >> (16 + leftoverBits))); - case 2: crc = drflac_crc8_byte(crc, (drflac_uint8)((data & (0x0000FF00UL << leftoverBits)) >> ( 8 + leftoverBits))); - case 1: crc = drflac_crc8_byte(crc, (drflac_uint8)((data & (0x000000FFUL << leftoverBits)) >> ( 0 + leftoverBits))); - case 0: if (leftoverBits > 0) crc = (drflac_uint8)((crc << leftoverBits) ^ drflac__crc8_table[(crc >> (8 - leftoverBits)) ^ (data & leftoverDataMask)]); - } - return crc; -#endif -#endif -} -static DRFLAC_INLINE drflac_uint16 drflac_crc16_byte(drflac_uint16 crc, drflac_uint8 data) -{ - return (crc << 8) ^ drflac__crc16_table[(drflac_uint8)(crc >> 8) ^ data]; -} -static DRFLAC_INLINE drflac_uint16 drflac_crc16_cache(drflac_uint16 crc, drflac_cache_t data) -{ -#ifdef DRFLAC_64BIT - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 56) & 0xFF)); - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 48) & 0xFF)); - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 40) & 0xFF)); - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 32) & 0xFF)); -#endif - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 24) & 0xFF)); - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 16) & 0xFF)); - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 8) & 0xFF)); - crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 0) & 0xFF)); - return crc; -} -static DRFLAC_INLINE drflac_uint16 drflac_crc16_bytes(drflac_uint16 crc, drflac_cache_t data, drflac_uint32 byteCount) -{ - switch (byteCount) - { -#ifdef DRFLAC_64BIT - case 8: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 56) & 0xFF)); - case 7: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 48) & 0xFF)); - case 6: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 40) & 0xFF)); - case 5: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 32) & 0xFF)); -#endif - case 4: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 24) & 0xFF)); - case 3: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 16) & 0xFF)); - case 2: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 8) & 0xFF)); - case 1: crc = drflac_crc16_byte(crc, (drflac_uint8)((data >> 0) & 0xFF)); - } - return crc; -} -#if 0 -static DRFLAC_INLINE drflac_uint16 drflac_crc16__32bit(drflac_uint16 crc, drflac_uint32 data, drflac_uint32 count) -{ -#ifdef DR_FLAC_NO_CRC - (void)crc; - (void)data; - (void)count; - return 0; -#else -#if 0 - drflac_uint16 p = 0x8005; - for (int i = count-1; i >= 0; --i) { - drflac_uint16 bit = (data & (1ULL << i)) >> i; - if (r & 0x8000) { - r = ((r << 1) | bit) ^ p; - } else { - r = ((r << 1) | bit); - } - } - return crc; -#else - drflac_uint32 wholeBytes; - drflac_uint32 leftoverBits; - drflac_uint64 leftoverDataMask; - static drflac_uint64 leftoverDataMaskTable[8] = { - 0x00, 0x01, 0x03, 0x07, 0x0F, 0x1F, 0x3F, 0x7F - }; - DRFLAC_ASSERT(count <= 64); - wholeBytes = count >> 3; - leftoverBits = count & 7; - leftoverDataMask = leftoverDataMaskTable[leftoverBits]; - switch (wholeBytes) { - default: - case 4: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (0xFF000000UL << leftoverBits)) >> (24 + leftoverBits))); - case 3: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (0x00FF0000UL << leftoverBits)) >> (16 + leftoverBits))); - case 2: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (0x0000FF00UL << leftoverBits)) >> ( 8 + leftoverBits))); - case 1: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (0x000000FFUL << leftoverBits)) >> ( 0 + leftoverBits))); - case 0: if (leftoverBits > 0) crc = (crc << leftoverBits) ^ drflac__crc16_table[(crc >> (16 - leftoverBits)) ^ (data & leftoverDataMask)]; - } - return crc; -#endif -#endif -} -static DRFLAC_INLINE drflac_uint16 drflac_crc16__64bit(drflac_uint16 crc, drflac_uint64 data, drflac_uint32 count) -{ -#ifdef DR_FLAC_NO_CRC - (void)crc; - (void)data; - (void)count; - return 0; -#else - drflac_uint32 wholeBytes; - drflac_uint32 leftoverBits; - drflac_uint64 leftoverDataMask; - static drflac_uint64 leftoverDataMaskTable[8] = { - 0x00, 0x01, 0x03, 0x07, 0x0F, 0x1F, 0x3F, 0x7F - }; - DRFLAC_ASSERT(count <= 64); - wholeBytes = count >> 3; - leftoverBits = count & 7; - leftoverDataMask = leftoverDataMaskTable[leftoverBits]; - switch (wholeBytes) { - default: - case 8: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0xFF000000 << 32) << leftoverBits)) >> (56 + leftoverBits))); - case 7: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0x00FF0000 << 32) << leftoverBits)) >> (48 + leftoverBits))); - case 6: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0x0000FF00 << 32) << leftoverBits)) >> (40 + leftoverBits))); - case 5: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0x000000FF << 32) << leftoverBits)) >> (32 + leftoverBits))); - case 4: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0xFF000000 ) << leftoverBits)) >> (24 + leftoverBits))); - case 3: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0x00FF0000 ) << leftoverBits)) >> (16 + leftoverBits))); - case 2: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0x0000FF00 ) << leftoverBits)) >> ( 8 + leftoverBits))); - case 1: crc = drflac_crc16_byte(crc, (drflac_uint8)((data & (((drflac_uint64)0x000000FF ) << leftoverBits)) >> ( 0 + leftoverBits))); - case 0: if (leftoverBits > 0) crc = (crc << leftoverBits) ^ drflac__crc16_table[(crc >> (16 - leftoverBits)) ^ (data & leftoverDataMask)]; - } - return crc; -#endif -} -static DRFLAC_INLINE drflac_uint16 drflac_crc16(drflac_uint16 crc, drflac_cache_t data, drflac_uint32 count) -{ -#ifdef DRFLAC_64BIT - return drflac_crc16__64bit(crc, data, count); -#else - return drflac_crc16__32bit(crc, data, count); -#endif -} -#endif -#ifdef DRFLAC_64BIT -#define drflac__be2host__cache_line drflac__be2host_64 -#else -#define drflac__be2host__cache_line drflac__be2host_32 -#endif -#define DRFLAC_CACHE_L1_SIZE_BYTES(bs) (sizeof((bs)->cache)) -#define DRFLAC_CACHE_L1_SIZE_BITS(bs) (sizeof((bs)->cache)*8) -#define DRFLAC_CACHE_L1_BITS_REMAINING(bs) (DRFLAC_CACHE_L1_SIZE_BITS(bs) - (bs)->consumedBits) -#define DRFLAC_CACHE_L1_SELECTION_MASK(_bitCount) (~((~(drflac_cache_t)0) >> (_bitCount))) -#define DRFLAC_CACHE_L1_SELECTION_SHIFT(bs, _bitCount) (DRFLAC_CACHE_L1_SIZE_BITS(bs) - (_bitCount)) -#define DRFLAC_CACHE_L1_SELECT(bs, _bitCount) (((bs)->cache) & DRFLAC_CACHE_L1_SELECTION_MASK(_bitCount)) -#define DRFLAC_CACHE_L1_SELECT_AND_SHIFT(bs, _bitCount) (DRFLAC_CACHE_L1_SELECT((bs), (_bitCount)) >> DRFLAC_CACHE_L1_SELECTION_SHIFT((bs), (_bitCount))) -#define DRFLAC_CACHE_L1_SELECT_AND_SHIFT_SAFE(bs, _bitCount)(DRFLAC_CACHE_L1_SELECT((bs), (_bitCount)) >> (DRFLAC_CACHE_L1_SELECTION_SHIFT((bs), (_bitCount)) & (DRFLAC_CACHE_L1_SIZE_BITS(bs)-1))) -#define DRFLAC_CACHE_L2_SIZE_BYTES(bs) (sizeof((bs)->cacheL2)) -#define DRFLAC_CACHE_L2_LINE_COUNT(bs) (DRFLAC_CACHE_L2_SIZE_BYTES(bs) / sizeof((bs)->cacheL2[0])) -#define DRFLAC_CACHE_L2_LINES_REMAINING(bs) (DRFLAC_CACHE_L2_LINE_COUNT(bs) - (bs)->nextL2Line) -#ifndef DR_FLAC_NO_CRC -static DRFLAC_INLINE void drflac__reset_crc16(drflac_bs* bs) -{ - bs->crc16 = 0; - bs->crc16CacheIgnoredBytes = bs->consumedBits >> 3; -} -static DRFLAC_INLINE void drflac__update_crc16(drflac_bs* bs) -{ - if (bs->crc16CacheIgnoredBytes == 0) { - bs->crc16 = drflac_crc16_cache(bs->crc16, bs->crc16Cache); - } else { - bs->crc16 = drflac_crc16_bytes(bs->crc16, bs->crc16Cache, DRFLAC_CACHE_L1_SIZE_BYTES(bs) - bs->crc16CacheIgnoredBytes); - bs->crc16CacheIgnoredBytes = 0; - } -} -static DRFLAC_INLINE drflac_uint16 drflac__flush_crc16(drflac_bs* bs) -{ - DRFLAC_ASSERT((DRFLAC_CACHE_L1_BITS_REMAINING(bs) & 7) == 0); - if (DRFLAC_CACHE_L1_BITS_REMAINING(bs) == 0) { - drflac__update_crc16(bs); - } else { - bs->crc16 = drflac_crc16_bytes(bs->crc16, bs->crc16Cache >> DRFLAC_CACHE_L1_BITS_REMAINING(bs), (bs->consumedBits >> 3) - bs->crc16CacheIgnoredBytes); - bs->crc16CacheIgnoredBytes = bs->consumedBits >> 3; - } - return bs->crc16; -} -#endif -static DRFLAC_INLINE drflac_bool32 drflac__reload_l1_cache_from_l2(drflac_bs* bs) -{ - size_t bytesRead; - size_t alignedL1LineCount; - if (bs->nextL2Line < DRFLAC_CACHE_L2_LINE_COUNT(bs)) { - bs->cache = bs->cacheL2[bs->nextL2Line++]; - return DRFLAC_TRUE; - } - if (bs->unalignedByteCount > 0) { - return DRFLAC_FALSE; - } - bytesRead = bs->onRead(bs->pUserData, bs->cacheL2, DRFLAC_CACHE_L2_SIZE_BYTES(bs)); - bs->nextL2Line = 0; - if (bytesRead == DRFLAC_CACHE_L2_SIZE_BYTES(bs)) { - bs->cache = bs->cacheL2[bs->nextL2Line++]; - return DRFLAC_TRUE; - } - alignedL1LineCount = bytesRead / DRFLAC_CACHE_L1_SIZE_BYTES(bs); - bs->unalignedByteCount = bytesRead - (alignedL1LineCount * DRFLAC_CACHE_L1_SIZE_BYTES(bs)); - if (bs->unalignedByteCount > 0) { - bs->unalignedCache = bs->cacheL2[alignedL1LineCount]; - } - if (alignedL1LineCount > 0) { - size_t offset = DRFLAC_CACHE_L2_LINE_COUNT(bs) - alignedL1LineCount; - size_t i; - for (i = alignedL1LineCount; i > 0; --i) { - bs->cacheL2[i-1 + offset] = bs->cacheL2[i-1]; - } - bs->nextL2Line = (drflac_uint32)offset; - bs->cache = bs->cacheL2[bs->nextL2Line++]; - return DRFLAC_TRUE; - } else { - bs->nextL2Line = DRFLAC_CACHE_L2_LINE_COUNT(bs); - return DRFLAC_FALSE; - } -} -static drflac_bool32 drflac__reload_cache(drflac_bs* bs) -{ - size_t bytesRead; -#ifndef DR_FLAC_NO_CRC - drflac__update_crc16(bs); -#endif - if (drflac__reload_l1_cache_from_l2(bs)) { - bs->cache = drflac__be2host__cache_line(bs->cache); - bs->consumedBits = 0; -#ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs->cache; -#endif - return DRFLAC_TRUE; - } - bytesRead = bs->unalignedByteCount; - if (bytesRead == 0) { - bs->consumedBits = DRFLAC_CACHE_L1_SIZE_BITS(bs); - return DRFLAC_FALSE; - } - DRFLAC_ASSERT(bytesRead < DRFLAC_CACHE_L1_SIZE_BYTES(bs)); - bs->consumedBits = (drflac_uint32)(DRFLAC_CACHE_L1_SIZE_BYTES(bs) - bytesRead) * 8; - bs->cache = drflac__be2host__cache_line(bs->unalignedCache); - bs->cache &= DRFLAC_CACHE_L1_SELECTION_MASK(DRFLAC_CACHE_L1_BITS_REMAINING(bs)); - bs->unalignedByteCount = 0; -#ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs->cache >> bs->consumedBits; - bs->crc16CacheIgnoredBytes = bs->consumedBits >> 3; -#endif - return DRFLAC_TRUE; -} -static void drflac__reset_cache(drflac_bs* bs) -{ - bs->nextL2Line = DRFLAC_CACHE_L2_LINE_COUNT(bs); - bs->consumedBits = DRFLAC_CACHE_L1_SIZE_BITS(bs); - bs->cache = 0; - bs->unalignedByteCount = 0; - bs->unalignedCache = 0; -#ifndef DR_FLAC_NO_CRC - bs->crc16Cache = 0; - bs->crc16CacheIgnoredBytes = 0; -#endif -} -static DRFLAC_INLINE drflac_bool32 drflac__read_uint32(drflac_bs* bs, unsigned int bitCount, drflac_uint32* pResultOut) -{ - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pResultOut != NULL); - DRFLAC_ASSERT(bitCount > 0); - DRFLAC_ASSERT(bitCount <= 32); - if (bs->consumedBits == DRFLAC_CACHE_L1_SIZE_BITS(bs)) { - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - } - if (bitCount <= DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { -#ifdef DRFLAC_64BIT - *pResultOut = (drflac_uint32)DRFLAC_CACHE_L1_SELECT_AND_SHIFT(bs, bitCount); - bs->consumedBits += bitCount; - bs->cache <<= bitCount; -#else - if (bitCount < DRFLAC_CACHE_L1_SIZE_BITS(bs)) { - *pResultOut = (drflac_uint32)DRFLAC_CACHE_L1_SELECT_AND_SHIFT(bs, bitCount); - bs->consumedBits += bitCount; - bs->cache <<= bitCount; - } else { - *pResultOut = (drflac_uint32)bs->cache; - bs->consumedBits = DRFLAC_CACHE_L1_SIZE_BITS(bs); - bs->cache = 0; - } -#endif - return DRFLAC_TRUE; - } else { - drflac_uint32 bitCountHi = DRFLAC_CACHE_L1_BITS_REMAINING(bs); - drflac_uint32 bitCountLo = bitCount - bitCountHi; - drflac_uint32 resultHi; - DRFLAC_ASSERT(bitCountHi > 0); - DRFLAC_ASSERT(bitCountHi < 32); - resultHi = (drflac_uint32)DRFLAC_CACHE_L1_SELECT_AND_SHIFT(bs, bitCountHi); - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - if (bitCountLo > DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - return DRFLAC_FALSE; - } - *pResultOut = (resultHi << bitCountLo) | (drflac_uint32)DRFLAC_CACHE_L1_SELECT_AND_SHIFT(bs, bitCountLo); - bs->consumedBits += bitCountLo; - bs->cache <<= bitCountLo; - return DRFLAC_TRUE; - } -} -static drflac_bool32 drflac__read_int32(drflac_bs* bs, unsigned int bitCount, drflac_int32* pResult) -{ - drflac_uint32 result; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pResult != NULL); - DRFLAC_ASSERT(bitCount > 0); - DRFLAC_ASSERT(bitCount <= 32); - if (!drflac__read_uint32(bs, bitCount, &result)) { - return DRFLAC_FALSE; - } - if (bitCount < 32) { - drflac_uint32 signbit; - signbit = ((result >> (bitCount-1)) & 0x01); - result |= (~signbit + 1) << bitCount; - } - *pResult = (drflac_int32)result; - return DRFLAC_TRUE; -} -#ifdef DRFLAC_64BIT -static drflac_bool32 drflac__read_uint64(drflac_bs* bs, unsigned int bitCount, drflac_uint64* pResultOut) -{ - drflac_uint32 resultHi; - drflac_uint32 resultLo; - DRFLAC_ASSERT(bitCount <= 64); - DRFLAC_ASSERT(bitCount > 32); - if (!drflac__read_uint32(bs, bitCount - 32, &resultHi)) { - return DRFLAC_FALSE; - } - if (!drflac__read_uint32(bs, 32, &resultLo)) { - return DRFLAC_FALSE; - } - *pResultOut = (((drflac_uint64)resultHi) << 32) | ((drflac_uint64)resultLo); - return DRFLAC_TRUE; -} -#endif -#if 0 -static drflac_bool32 drflac__read_int64(drflac_bs* bs, unsigned int bitCount, drflac_int64* pResultOut) -{ - drflac_uint64 result; - drflac_uint64 signbit; - DRFLAC_ASSERT(bitCount <= 64); - if (!drflac__read_uint64(bs, bitCount, &result)) { - return DRFLAC_FALSE; - } - signbit = ((result >> (bitCount-1)) & 0x01); - result |= (~signbit + 1) << bitCount; - *pResultOut = (drflac_int64)result; - return DRFLAC_TRUE; -} -#endif -static drflac_bool32 drflac__read_uint16(drflac_bs* bs, unsigned int bitCount, drflac_uint16* pResult) -{ - drflac_uint32 result; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pResult != NULL); - DRFLAC_ASSERT(bitCount > 0); - DRFLAC_ASSERT(bitCount <= 16); - if (!drflac__read_uint32(bs, bitCount, &result)) { - return DRFLAC_FALSE; - } - *pResult = (drflac_uint16)result; - return DRFLAC_TRUE; -} -#if 0 -static drflac_bool32 drflac__read_int16(drflac_bs* bs, unsigned int bitCount, drflac_int16* pResult) -{ - drflac_int32 result; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pResult != NULL); - DRFLAC_ASSERT(bitCount > 0); - DRFLAC_ASSERT(bitCount <= 16); - if (!drflac__read_int32(bs, bitCount, &result)) { - return DRFLAC_FALSE; - } - *pResult = (drflac_int16)result; - return DRFLAC_TRUE; -} -#endif -static drflac_bool32 drflac__read_uint8(drflac_bs* bs, unsigned int bitCount, drflac_uint8* pResult) -{ - drflac_uint32 result; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pResult != NULL); - DRFLAC_ASSERT(bitCount > 0); - DRFLAC_ASSERT(bitCount <= 8); - if (!drflac__read_uint32(bs, bitCount, &result)) { - return DRFLAC_FALSE; - } - *pResult = (drflac_uint8)result; - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__read_int8(drflac_bs* bs, unsigned int bitCount, drflac_int8* pResult) -{ - drflac_int32 result; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pResult != NULL); - DRFLAC_ASSERT(bitCount > 0); - DRFLAC_ASSERT(bitCount <= 8); - if (!drflac__read_int32(bs, bitCount, &result)) { - return DRFLAC_FALSE; - } - *pResult = (drflac_int8)result; - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__seek_bits(drflac_bs* bs, size_t bitsToSeek) -{ - if (bitsToSeek <= DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - bs->consumedBits += (drflac_uint32)bitsToSeek; - bs->cache <<= bitsToSeek; - return DRFLAC_TRUE; - } else { - bitsToSeek -= DRFLAC_CACHE_L1_BITS_REMAINING(bs); - bs->consumedBits += DRFLAC_CACHE_L1_BITS_REMAINING(bs); - bs->cache = 0; -#ifdef DRFLAC_64BIT - while (bitsToSeek >= DRFLAC_CACHE_L1_SIZE_BITS(bs)) { - drflac_uint64 bin; - if (!drflac__read_uint64(bs, DRFLAC_CACHE_L1_SIZE_BITS(bs), &bin)) { - return DRFLAC_FALSE; - } - bitsToSeek -= DRFLAC_CACHE_L1_SIZE_BITS(bs); - } -#else - while (bitsToSeek >= DRFLAC_CACHE_L1_SIZE_BITS(bs)) { - drflac_uint32 bin; - if (!drflac__read_uint32(bs, DRFLAC_CACHE_L1_SIZE_BITS(bs), &bin)) { - return DRFLAC_FALSE; - } - bitsToSeek -= DRFLAC_CACHE_L1_SIZE_BITS(bs); - } -#endif - while (bitsToSeek >= 8) { - drflac_uint8 bin; - if (!drflac__read_uint8(bs, 8, &bin)) { - return DRFLAC_FALSE; - } - bitsToSeek -= 8; - } - if (bitsToSeek > 0) { - drflac_uint8 bin; - if (!drflac__read_uint8(bs, (drflac_uint32)bitsToSeek, &bin)) { - return DRFLAC_FALSE; - } - bitsToSeek = 0; - } - DRFLAC_ASSERT(bitsToSeek == 0); - return DRFLAC_TRUE; - } -} -static drflac_bool32 drflac__find_and_seek_to_next_sync_code(drflac_bs* bs) -{ - DRFLAC_ASSERT(bs != NULL); - if (!drflac__seek_bits(bs, DRFLAC_CACHE_L1_BITS_REMAINING(bs) & 7)) { - return DRFLAC_FALSE; - } - for (;;) { - drflac_uint8 hi; -#ifndef DR_FLAC_NO_CRC - drflac__reset_crc16(bs); -#endif - if (!drflac__read_uint8(bs, 8, &hi)) { - return DRFLAC_FALSE; - } - if (hi == 0xFF) { - drflac_uint8 lo; - if (!drflac__read_uint8(bs, 6, &lo)) { - return DRFLAC_FALSE; - } - if (lo == 0x3E) { - return DRFLAC_TRUE; - } else { - if (!drflac__seek_bits(bs, DRFLAC_CACHE_L1_BITS_REMAINING(bs) & 7)) { - return DRFLAC_FALSE; - } - } - } - } -} -#if defined(DRFLAC_HAS_LZCNT_INTRINSIC) -#define DRFLAC_IMPLEMENT_CLZ_LZCNT -#endif -#if defined(_MSC_VER) && _MSC_VER >= 1400 && (defined(DRFLAC_X64) || defined(DRFLAC_X86)) && !defined(__clang__) -#define DRFLAC_IMPLEMENT_CLZ_MSVC -#endif -#if defined(__WATCOMC__) && defined(__386__) -#define DRFLAC_IMPLEMENT_CLZ_WATCOM -#endif -#ifdef __MRC__ -#include -#define DRFLAC_IMPLEMENT_CLZ_MRC -#endif -static DRFLAC_INLINE drflac_uint32 drflac__clz_software(drflac_cache_t x) -{ - drflac_uint32 n; - static drflac_uint32 clz_table_4[] = { - 0, - 4, - 3, 3, - 2, 2, 2, 2, - 1, 1, 1, 1, 1, 1, 1, 1 - }; - if (x == 0) { - return sizeof(x)*8; - } - n = clz_table_4[x >> (sizeof(x)*8 - 4)]; - if (n == 0) { -#ifdef DRFLAC_64BIT - if ((x & ((drflac_uint64)0xFFFFFFFF << 32)) == 0) { n = 32; x <<= 32; } - if ((x & ((drflac_uint64)0xFFFF0000 << 32)) == 0) { n += 16; x <<= 16; } - if ((x & ((drflac_uint64)0xFF000000 << 32)) == 0) { n += 8; x <<= 8; } - if ((x & ((drflac_uint64)0xF0000000 << 32)) == 0) { n += 4; x <<= 4; } -#else - if ((x & 0xFFFF0000) == 0) { n = 16; x <<= 16; } - if ((x & 0xFF000000) == 0) { n += 8; x <<= 8; } - if ((x & 0xF0000000) == 0) { n += 4; x <<= 4; } -#endif - n += clz_table_4[x >> (sizeof(x)*8 - 4)]; - } - return n - 1; -} -#ifdef DRFLAC_IMPLEMENT_CLZ_LZCNT -static DRFLAC_INLINE drflac_bool32 drflac__is_lzcnt_supported(void) -{ -#if defined(DRFLAC_HAS_LZCNT_INTRINSIC) && defined(DRFLAC_ARM) && (defined(__ARM_ARCH) && __ARM_ARCH >= 5) - return DRFLAC_TRUE; -#elif defined(__MRC__) - return DRFLAC_TRUE; -#else - #ifdef DRFLAC_HAS_LZCNT_INTRINSIC - return drflac__gIsLZCNTSupported; - #else - return DRFLAC_FALSE; - #endif -#endif -} -static DRFLAC_INLINE drflac_uint32 drflac__clz_lzcnt(drflac_cache_t x) -{ -#if defined(_MSC_VER) - #ifdef DRFLAC_64BIT - return (drflac_uint32)__lzcnt64(x); - #else - return (drflac_uint32)__lzcnt(x); - #endif -#else - #if defined(__GNUC__) || defined(__clang__) - #if defined(DRFLAC_X64) - { - drflac_uint64 r; - __asm__ __volatile__ ( - "lzcnt{ %1, %0| %0, %1}" : "=r"(r) : "r"(x) : "cc" - ); - return (drflac_uint32)r; - } - #elif defined(DRFLAC_X86) - { - drflac_uint32 r; - __asm__ __volatile__ ( - "lzcnt{l %1, %0| %0, %1}" : "=r"(r) : "r"(x) : "cc" - ); - return r; - } - #elif defined(DRFLAC_ARM) && (defined(__ARM_ARCH) && __ARM_ARCH >= 5) && !defined(DRFLAC_64BIT) - { - unsigned int r; - __asm__ __volatile__ ( - #if defined(DRFLAC_64BIT) - "clz %w[out], %w[in]" : [out]"=r"(r) : [in]"r"(x) - #else - "clz %[out], %[in]" : [out]"=r"(r) : [in]"r"(x) - #endif - ); - return r; - } - #else - if (x == 0) { - return sizeof(x)*8; - } - #ifdef DRFLAC_64BIT - return (drflac_uint32)__builtin_clzll((drflac_uint64)x); - #else - return (drflac_uint32)__builtin_clzl((drflac_uint32)x); - #endif - #endif - #else - #error "This compiler does not support the lzcnt intrinsic." - #endif -#endif -} -#endif -#ifdef DRFLAC_IMPLEMENT_CLZ_MSVC -#include -static DRFLAC_INLINE drflac_uint32 drflac__clz_msvc(drflac_cache_t x) -{ - drflac_uint32 n; - if (x == 0) { - return sizeof(x)*8; - } -#ifdef DRFLAC_64BIT - _BitScanReverse64((unsigned long*)&n, x); -#else - _BitScanReverse((unsigned long*)&n, x); -#endif - return sizeof(x)*8 - n - 1; -} -#endif -#ifdef DRFLAC_IMPLEMENT_CLZ_WATCOM -static __inline drflac_uint32 drflac__clz_watcom (drflac_uint32); -#ifdef DRFLAC_IMPLEMENT_CLZ_WATCOM_LZCNT -#pragma aux drflac__clz_watcom_lzcnt = \ - "db 0F3h, 0Fh, 0BDh, 0C0h" \ - parm [eax] \ - value [eax] \ - modify nomemory; -#else -#pragma aux drflac__clz_watcom = \ - "bsr eax, eax" \ - "xor eax, 31" \ - parm [eax] nomemory \ - value [eax] \ - modify exact [eax] nomemory; -#endif -#endif -static DRFLAC_INLINE drflac_uint32 drflac__clz(drflac_cache_t x) -{ -#ifdef DRFLAC_IMPLEMENT_CLZ_LZCNT - if (drflac__is_lzcnt_supported()) { - return drflac__clz_lzcnt(x); - } else -#endif - { -#ifdef DRFLAC_IMPLEMENT_CLZ_MSVC - return drflac__clz_msvc(x); -#elif defined(DRFLAC_IMPLEMENT_CLZ_WATCOM_LZCNT) - return drflac__clz_watcom_lzcnt(x); -#elif defined(DRFLAC_IMPLEMENT_CLZ_WATCOM) - return (x == 0) ? sizeof(x)*8 : drflac__clz_watcom(x); -#elif defined(__MRC__) - return __cntlzw(x); -#else - return drflac__clz_software(x); -#endif - } -} -static DRFLAC_INLINE drflac_bool32 drflac__seek_past_next_set_bit(drflac_bs* bs, unsigned int* pOffsetOut) -{ - drflac_uint32 zeroCounter = 0; - drflac_uint32 setBitOffsetPlus1; - while (bs->cache == 0) { - zeroCounter += (drflac_uint32)DRFLAC_CACHE_L1_BITS_REMAINING(bs); - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - } - if (bs->cache == 1) { - *pOffsetOut = zeroCounter + (drflac_uint32)DRFLAC_CACHE_L1_BITS_REMAINING(bs) - 1; - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - return DRFLAC_TRUE; - } - setBitOffsetPlus1 = drflac__clz(bs->cache); - setBitOffsetPlus1 += 1; - if (setBitOffsetPlus1 > DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - return DRFLAC_FALSE; - } - bs->consumedBits += setBitOffsetPlus1; - bs->cache <<= setBitOffsetPlus1; - *pOffsetOut = zeroCounter + setBitOffsetPlus1 - 1; - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__seek_to_byte(drflac_bs* bs, drflac_uint64 offsetFromStart) -{ - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(offsetFromStart > 0); - if (offsetFromStart > 0x7FFFFFFF) { - drflac_uint64 bytesRemaining = offsetFromStart; - if (!bs->onSeek(bs->pUserData, 0x7FFFFFFF, drflac_seek_origin_start)) { - return DRFLAC_FALSE; - } - bytesRemaining -= 0x7FFFFFFF; - while (bytesRemaining > 0x7FFFFFFF) { - if (!bs->onSeek(bs->pUserData, 0x7FFFFFFF, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - bytesRemaining -= 0x7FFFFFFF; - } - if (bytesRemaining > 0) { - if (!bs->onSeek(bs->pUserData, (int)bytesRemaining, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - } - } else { - if (!bs->onSeek(bs->pUserData, (int)offsetFromStart, drflac_seek_origin_start)) { - return DRFLAC_FALSE; - } - } - drflac__reset_cache(bs); - return DRFLAC_TRUE; -} -static drflac_result drflac__read_utf8_coded_number(drflac_bs* bs, drflac_uint64* pNumberOut, drflac_uint8* pCRCOut) -{ - drflac_uint8 crc; - drflac_uint64 result; - drflac_uint8 utf8[7] = {0}; - int byteCount; - int i; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pNumberOut != NULL); - DRFLAC_ASSERT(pCRCOut != NULL); - crc = *pCRCOut; - if (!drflac__read_uint8(bs, 8, utf8)) { - *pNumberOut = 0; - return DRFLAC_AT_END; - } - crc = drflac_crc8(crc, utf8[0], 8); - if ((utf8[0] & 0x80) == 0) { - *pNumberOut = utf8[0]; - *pCRCOut = crc; - return DRFLAC_SUCCESS; - } - if ((utf8[0] & 0xE0) == 0xC0) { - byteCount = 2; - } else if ((utf8[0] & 0xF0) == 0xE0) { - byteCount = 3; - } else if ((utf8[0] & 0xF8) == 0xF0) { - byteCount = 4; - } else if ((utf8[0] & 0xFC) == 0xF8) { - byteCount = 5; - } else if ((utf8[0] & 0xFE) == 0xFC) { - byteCount = 6; - } else if ((utf8[0] & 0xFF) == 0xFE) { - byteCount = 7; - } else { - *pNumberOut = 0; - return DRFLAC_CRC_MISMATCH; - } - DRFLAC_ASSERT(byteCount > 1); - result = (drflac_uint64)(utf8[0] & (0xFF >> (byteCount + 1))); - for (i = 1; i < byteCount; ++i) { - if (!drflac__read_uint8(bs, 8, utf8 + i)) { - *pNumberOut = 0; - return DRFLAC_AT_END; - } - crc = drflac_crc8(crc, utf8[i], 8); - result = (result << 6) | (utf8[i] & 0x3F); - } - *pNumberOut = result; - *pCRCOut = crc; - return DRFLAC_SUCCESS; -} -static DRFLAC_INLINE drflac_uint32 drflac__ilog2_u32(drflac_uint32 x) -{ -#if 1 - drflac_uint32 result = 0; - while (x > 0) { - result += 1; - x >>= 1; - } - return result; -#endif -} -static DRFLAC_INLINE drflac_bool32 drflac__use_64_bit_prediction(drflac_uint32 bitsPerSample, drflac_uint32 order, drflac_uint32 precision) -{ - return bitsPerSample + precision + drflac__ilog2_u32(order) > 32; -} -#if defined(__clang__) -__attribute__((no_sanitize("signed-integer-overflow"))) -#endif -static DRFLAC_INLINE drflac_int32 drflac__calculate_prediction_32(drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pDecodedSamples) -{ - drflac_int32 prediction = 0; - DRFLAC_ASSERT(order <= 32); - switch (order) - { - case 32: prediction += coefficients[31] * pDecodedSamples[-32]; - case 31: prediction += coefficients[30] * pDecodedSamples[-31]; - case 30: prediction += coefficients[29] * pDecodedSamples[-30]; - case 29: prediction += coefficients[28] * pDecodedSamples[-29]; - case 28: prediction += coefficients[27] * pDecodedSamples[-28]; - case 27: prediction += coefficients[26] * pDecodedSamples[-27]; - case 26: prediction += coefficients[25] * pDecodedSamples[-26]; - case 25: prediction += coefficients[24] * pDecodedSamples[-25]; - case 24: prediction += coefficients[23] * pDecodedSamples[-24]; - case 23: prediction += coefficients[22] * pDecodedSamples[-23]; - case 22: prediction += coefficients[21] * pDecodedSamples[-22]; - case 21: prediction += coefficients[20] * pDecodedSamples[-21]; - case 20: prediction += coefficients[19] * pDecodedSamples[-20]; - case 19: prediction += coefficients[18] * pDecodedSamples[-19]; - case 18: prediction += coefficients[17] * pDecodedSamples[-18]; - case 17: prediction += coefficients[16] * pDecodedSamples[-17]; - case 16: prediction += coefficients[15] * pDecodedSamples[-16]; - case 15: prediction += coefficients[14] * pDecodedSamples[-15]; - case 14: prediction += coefficients[13] * pDecodedSamples[-14]; - case 13: prediction += coefficients[12] * pDecodedSamples[-13]; - case 12: prediction += coefficients[11] * pDecodedSamples[-12]; - case 11: prediction += coefficients[10] * pDecodedSamples[-11]; - case 10: prediction += coefficients[ 9] * pDecodedSamples[-10]; - case 9: prediction += coefficients[ 8] * pDecodedSamples[- 9]; - case 8: prediction += coefficients[ 7] * pDecodedSamples[- 8]; - case 7: prediction += coefficients[ 6] * pDecodedSamples[- 7]; - case 6: prediction += coefficients[ 5] * pDecodedSamples[- 6]; - case 5: prediction += coefficients[ 4] * pDecodedSamples[- 5]; - case 4: prediction += coefficients[ 3] * pDecodedSamples[- 4]; - case 3: prediction += coefficients[ 2] * pDecodedSamples[- 3]; - case 2: prediction += coefficients[ 1] * pDecodedSamples[- 2]; - case 1: prediction += coefficients[ 0] * pDecodedSamples[- 1]; - } - return (drflac_int32)(prediction >> shift); -} -static DRFLAC_INLINE drflac_int32 drflac__calculate_prediction_64(drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pDecodedSamples) -{ - drflac_int64 prediction; - DRFLAC_ASSERT(order <= 32); -#ifndef DRFLAC_64BIT - if (order == 8) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - prediction += coefficients[6] * (drflac_int64)pDecodedSamples[-7]; - prediction += coefficients[7] * (drflac_int64)pDecodedSamples[-8]; - } - else if (order == 7) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - prediction += coefficients[6] * (drflac_int64)pDecodedSamples[-7]; - } - else if (order == 3) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - } - else if (order == 6) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - } - else if (order == 5) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - } - else if (order == 4) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - } - else if (order == 12) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - prediction += coefficients[6] * (drflac_int64)pDecodedSamples[-7]; - prediction += coefficients[7] * (drflac_int64)pDecodedSamples[-8]; - prediction += coefficients[8] * (drflac_int64)pDecodedSamples[-9]; - prediction += coefficients[9] * (drflac_int64)pDecodedSamples[-10]; - prediction += coefficients[10] * (drflac_int64)pDecodedSamples[-11]; - prediction += coefficients[11] * (drflac_int64)pDecodedSamples[-12]; - } - else if (order == 2) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - } - else if (order == 1) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - } - else if (order == 10) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - prediction += coefficients[6] * (drflac_int64)pDecodedSamples[-7]; - prediction += coefficients[7] * (drflac_int64)pDecodedSamples[-8]; - prediction += coefficients[8] * (drflac_int64)pDecodedSamples[-9]; - prediction += coefficients[9] * (drflac_int64)pDecodedSamples[-10]; - } - else if (order == 9) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - prediction += coefficients[6] * (drflac_int64)pDecodedSamples[-7]; - prediction += coefficients[7] * (drflac_int64)pDecodedSamples[-8]; - prediction += coefficients[8] * (drflac_int64)pDecodedSamples[-9]; - } - else if (order == 11) - { - prediction = coefficients[0] * (drflac_int64)pDecodedSamples[-1]; - prediction += coefficients[1] * (drflac_int64)pDecodedSamples[-2]; - prediction += coefficients[2] * (drflac_int64)pDecodedSamples[-3]; - prediction += coefficients[3] * (drflac_int64)pDecodedSamples[-4]; - prediction += coefficients[4] * (drflac_int64)pDecodedSamples[-5]; - prediction += coefficients[5] * (drflac_int64)pDecodedSamples[-6]; - prediction += coefficients[6] * (drflac_int64)pDecodedSamples[-7]; - prediction += coefficients[7] * (drflac_int64)pDecodedSamples[-8]; - prediction += coefficients[8] * (drflac_int64)pDecodedSamples[-9]; - prediction += coefficients[9] * (drflac_int64)pDecodedSamples[-10]; - prediction += coefficients[10] * (drflac_int64)pDecodedSamples[-11]; - } - else - { - int j; - prediction = 0; - for (j = 0; j < (int)order; ++j) { - prediction += coefficients[j] * (drflac_int64)pDecodedSamples[-j-1]; - } - } -#endif -#ifdef DRFLAC_64BIT - prediction = 0; - switch (order) - { - case 32: prediction += coefficients[31] * (drflac_int64)pDecodedSamples[-32]; - case 31: prediction += coefficients[30] * (drflac_int64)pDecodedSamples[-31]; - case 30: prediction += coefficients[29] * (drflac_int64)pDecodedSamples[-30]; - case 29: prediction += coefficients[28] * (drflac_int64)pDecodedSamples[-29]; - case 28: prediction += coefficients[27] * (drflac_int64)pDecodedSamples[-28]; - case 27: prediction += coefficients[26] * (drflac_int64)pDecodedSamples[-27]; - case 26: prediction += coefficients[25] * (drflac_int64)pDecodedSamples[-26]; - case 25: prediction += coefficients[24] * (drflac_int64)pDecodedSamples[-25]; - case 24: prediction += coefficients[23] * (drflac_int64)pDecodedSamples[-24]; - case 23: prediction += coefficients[22] * (drflac_int64)pDecodedSamples[-23]; - case 22: prediction += coefficients[21] * (drflac_int64)pDecodedSamples[-22]; - case 21: prediction += coefficients[20] * (drflac_int64)pDecodedSamples[-21]; - case 20: prediction += coefficients[19] * (drflac_int64)pDecodedSamples[-20]; - case 19: prediction += coefficients[18] * (drflac_int64)pDecodedSamples[-19]; - case 18: prediction += coefficients[17] * (drflac_int64)pDecodedSamples[-18]; - case 17: prediction += coefficients[16] * (drflac_int64)pDecodedSamples[-17]; - case 16: prediction += coefficients[15] * (drflac_int64)pDecodedSamples[-16]; - case 15: prediction += coefficients[14] * (drflac_int64)pDecodedSamples[-15]; - case 14: prediction += coefficients[13] * (drflac_int64)pDecodedSamples[-14]; - case 13: prediction += coefficients[12] * (drflac_int64)pDecodedSamples[-13]; - case 12: prediction += coefficients[11] * (drflac_int64)pDecodedSamples[-12]; - case 11: prediction += coefficients[10] * (drflac_int64)pDecodedSamples[-11]; - case 10: prediction += coefficients[ 9] * (drflac_int64)pDecodedSamples[-10]; - case 9: prediction += coefficients[ 8] * (drflac_int64)pDecodedSamples[- 9]; - case 8: prediction += coefficients[ 7] * (drflac_int64)pDecodedSamples[- 8]; - case 7: prediction += coefficients[ 6] * (drflac_int64)pDecodedSamples[- 7]; - case 6: prediction += coefficients[ 5] * (drflac_int64)pDecodedSamples[- 6]; - case 5: prediction += coefficients[ 4] * (drflac_int64)pDecodedSamples[- 5]; - case 4: prediction += coefficients[ 3] * (drflac_int64)pDecodedSamples[- 4]; - case 3: prediction += coefficients[ 2] * (drflac_int64)pDecodedSamples[- 3]; - case 2: prediction += coefficients[ 1] * (drflac_int64)pDecodedSamples[- 2]; - case 1: prediction += coefficients[ 0] * (drflac_int64)pDecodedSamples[- 1]; - } -#endif - return (drflac_int32)(prediction >> shift); -} -#if 0 -static drflac_bool32 drflac__decode_samples_with_residual__rice__reference(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - drflac_uint32 i; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pSamplesOut != NULL); - for (i = 0; i < count; ++i) { - drflac_uint32 zeroCounter = 0; - for (;;) { - drflac_uint8 bit; - if (!drflac__read_uint8(bs, 1, &bit)) { - return DRFLAC_FALSE; - } - if (bit == 0) { - zeroCounter += 1; - } else { - break; - } - } - drflac_uint32 decodedRice; - if (riceParam > 0) { - if (!drflac__read_uint32(bs, riceParam, &decodedRice)) { - return DRFLAC_FALSE; - } - } else { - decodedRice = 0; - } - decodedRice |= (zeroCounter << riceParam); - if ((decodedRice & 0x01)) { - decodedRice = ~(decodedRice >> 1); - } else { - decodedRice = (decodedRice >> 1); - } - if (drflac__use_64_bit_prediction(bitsPerSample, lpcOrder, lpcPrecision)) { - pSamplesOut[i] = decodedRice + drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + i); - } else { - pSamplesOut[i] = decodedRice + drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + i); - } - } - return DRFLAC_TRUE; -} -#endif -#if 0 -static drflac_bool32 drflac__read_rice_parts__reference(drflac_bs* bs, drflac_uint8 riceParam, drflac_uint32* pZeroCounterOut, drflac_uint32* pRiceParamPartOut) -{ - drflac_uint32 zeroCounter = 0; - drflac_uint32 decodedRice; - for (;;) { - drflac_uint8 bit; - if (!drflac__read_uint8(bs, 1, &bit)) { - return DRFLAC_FALSE; - } - if (bit == 0) { - zeroCounter += 1; - } else { - break; - } - } - if (riceParam > 0) { - if (!drflac__read_uint32(bs, riceParam, &decodedRice)) { - return DRFLAC_FALSE; - } - } else { - decodedRice = 0; - } - *pZeroCounterOut = zeroCounter; - *pRiceParamPartOut = decodedRice; - return DRFLAC_TRUE; -} -#endif -#if 0 -static DRFLAC_INLINE drflac_bool32 drflac__read_rice_parts(drflac_bs* bs, drflac_uint8 riceParam, drflac_uint32* pZeroCounterOut, drflac_uint32* pRiceParamPartOut) -{ - drflac_cache_t riceParamMask; - drflac_uint32 zeroCounter; - drflac_uint32 setBitOffsetPlus1; - drflac_uint32 riceParamPart; - drflac_uint32 riceLength; - DRFLAC_ASSERT(riceParam > 0); - riceParamMask = DRFLAC_CACHE_L1_SELECTION_MASK(riceParam); - zeroCounter = 0; - while (bs->cache == 0) { - zeroCounter += (drflac_uint32)DRFLAC_CACHE_L1_BITS_REMAINING(bs); - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - } - setBitOffsetPlus1 = drflac__clz(bs->cache); - zeroCounter += setBitOffsetPlus1; - setBitOffsetPlus1 += 1; - riceLength = setBitOffsetPlus1 + riceParam; - if (riceLength < DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - riceParamPart = (drflac_uint32)((bs->cache & (riceParamMask >> setBitOffsetPlus1)) >> DRFLAC_CACHE_L1_SELECTION_SHIFT(bs, riceLength)); - bs->consumedBits += riceLength; - bs->cache <<= riceLength; - } else { - drflac_uint32 bitCountLo; - drflac_cache_t resultHi; - bs->consumedBits += riceLength; - bs->cache <<= setBitOffsetPlus1 & (DRFLAC_CACHE_L1_SIZE_BITS(bs)-1); - bitCountLo = bs->consumedBits - DRFLAC_CACHE_L1_SIZE_BITS(bs); - resultHi = DRFLAC_CACHE_L1_SELECT_AND_SHIFT(bs, riceParam); - if (bs->nextL2Line < DRFLAC_CACHE_L2_LINE_COUNT(bs)) { -#ifndef DR_FLAC_NO_CRC - drflac__update_crc16(bs); -#endif - bs->cache = drflac__be2host__cache_line(bs->cacheL2[bs->nextL2Line++]); - bs->consumedBits = 0; -#ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs->cache; -#endif - } else { - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - if (bitCountLo > DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - return DRFLAC_FALSE; - } - } - riceParamPart = (drflac_uint32)(resultHi | DRFLAC_CACHE_L1_SELECT_AND_SHIFT_SAFE(bs, bitCountLo)); - bs->consumedBits += bitCountLo; - bs->cache <<= bitCountLo; - } - pZeroCounterOut[0] = zeroCounter; - pRiceParamPartOut[0] = riceParamPart; - return DRFLAC_TRUE; -} -#endif -static DRFLAC_INLINE drflac_bool32 drflac__read_rice_parts_x1(drflac_bs* bs, drflac_uint8 riceParam, drflac_uint32* pZeroCounterOut, drflac_uint32* pRiceParamPartOut) -{ - drflac_uint32 riceParamPlus1 = riceParam + 1; - drflac_uint32 riceParamPlus1Shift = DRFLAC_CACHE_L1_SELECTION_SHIFT(bs, riceParamPlus1); - drflac_uint32 riceParamPlus1MaxConsumedBits = DRFLAC_CACHE_L1_SIZE_BITS(bs) - riceParamPlus1; - drflac_cache_t bs_cache = bs->cache; - drflac_uint32 bs_consumedBits = bs->consumedBits; - drflac_uint32 lzcount = drflac__clz(bs_cache); - if (lzcount < sizeof(bs_cache)*8) { - pZeroCounterOut[0] = lzcount; - extract_rice_param_part: - bs_cache <<= lzcount; - bs_consumedBits += lzcount; - if (bs_consumedBits <= riceParamPlus1MaxConsumedBits) { - pRiceParamPartOut[0] = (drflac_uint32)(bs_cache >> riceParamPlus1Shift); - bs_cache <<= riceParamPlus1; - bs_consumedBits += riceParamPlus1; - } else { - drflac_uint32 riceParamPartHi; - drflac_uint32 riceParamPartLo; - drflac_uint32 riceParamPartLoBitCount; - riceParamPartHi = (drflac_uint32)(bs_cache >> riceParamPlus1Shift); - riceParamPartLoBitCount = bs_consumedBits - riceParamPlus1MaxConsumedBits; - DRFLAC_ASSERT(riceParamPartLoBitCount > 0 && riceParamPartLoBitCount < 32); - if (bs->nextL2Line < DRFLAC_CACHE_L2_LINE_COUNT(bs)) { - #ifndef DR_FLAC_NO_CRC - drflac__update_crc16(bs); - #endif - bs_cache = drflac__be2host__cache_line(bs->cacheL2[bs->nextL2Line++]); - bs_consumedBits = riceParamPartLoBitCount; - #ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs_cache; - #endif - } else { - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - if (riceParamPartLoBitCount > DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - return DRFLAC_FALSE; - } - bs_cache = bs->cache; - bs_consumedBits = bs->consumedBits + riceParamPartLoBitCount; - } - riceParamPartLo = (drflac_uint32)(bs_cache >> (DRFLAC_CACHE_L1_SELECTION_SHIFT(bs, riceParamPartLoBitCount))); - pRiceParamPartOut[0] = riceParamPartHi | riceParamPartLo; - bs_cache <<= riceParamPartLoBitCount; - } - } else { - drflac_uint32 zeroCounter = (drflac_uint32)(DRFLAC_CACHE_L1_SIZE_BITS(bs) - bs_consumedBits); - for (;;) { - if (bs->nextL2Line < DRFLAC_CACHE_L2_LINE_COUNT(bs)) { - #ifndef DR_FLAC_NO_CRC - drflac__update_crc16(bs); - #endif - bs_cache = drflac__be2host__cache_line(bs->cacheL2[bs->nextL2Line++]); - bs_consumedBits = 0; - #ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs_cache; - #endif - } else { - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - bs_cache = bs->cache; - bs_consumedBits = bs->consumedBits; - } - lzcount = drflac__clz(bs_cache); - zeroCounter += lzcount; - if (lzcount < sizeof(bs_cache)*8) { - break; - } - } - pZeroCounterOut[0] = zeroCounter; - goto extract_rice_param_part; - } - bs->cache = bs_cache; - bs->consumedBits = bs_consumedBits; - return DRFLAC_TRUE; -} -static DRFLAC_INLINE drflac_bool32 drflac__seek_rice_parts(drflac_bs* bs, drflac_uint8 riceParam) -{ - drflac_uint32 riceParamPlus1 = riceParam + 1; - drflac_uint32 riceParamPlus1MaxConsumedBits = DRFLAC_CACHE_L1_SIZE_BITS(bs) - riceParamPlus1; - drflac_cache_t bs_cache = bs->cache; - drflac_uint32 bs_consumedBits = bs->consumedBits; - drflac_uint32 lzcount = drflac__clz(bs_cache); - if (lzcount < sizeof(bs_cache)*8) { - extract_rice_param_part: - bs_cache <<= lzcount; - bs_consumedBits += lzcount; - if (bs_consumedBits <= riceParamPlus1MaxConsumedBits) { - bs_cache <<= riceParamPlus1; - bs_consumedBits += riceParamPlus1; - } else { - drflac_uint32 riceParamPartLoBitCount = bs_consumedBits - riceParamPlus1MaxConsumedBits; - DRFLAC_ASSERT(riceParamPartLoBitCount > 0 && riceParamPartLoBitCount < 32); - if (bs->nextL2Line < DRFLAC_CACHE_L2_LINE_COUNT(bs)) { - #ifndef DR_FLAC_NO_CRC - drflac__update_crc16(bs); - #endif - bs_cache = drflac__be2host__cache_line(bs->cacheL2[bs->nextL2Line++]); - bs_consumedBits = riceParamPartLoBitCount; - #ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs_cache; - #endif - } else { - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - if (riceParamPartLoBitCount > DRFLAC_CACHE_L1_BITS_REMAINING(bs)) { - return DRFLAC_FALSE; - } - bs_cache = bs->cache; - bs_consumedBits = bs->consumedBits + riceParamPartLoBitCount; - } - bs_cache <<= riceParamPartLoBitCount; - } - } else { - for (;;) { - if (bs->nextL2Line < DRFLAC_CACHE_L2_LINE_COUNT(bs)) { - #ifndef DR_FLAC_NO_CRC - drflac__update_crc16(bs); - #endif - bs_cache = drflac__be2host__cache_line(bs->cacheL2[bs->nextL2Line++]); - bs_consumedBits = 0; - #ifndef DR_FLAC_NO_CRC - bs->crc16Cache = bs_cache; - #endif - } else { - if (!drflac__reload_cache(bs)) { - return DRFLAC_FALSE; - } - bs_cache = bs->cache; - bs_consumedBits = bs->consumedBits; - } - lzcount = drflac__clz(bs_cache); - if (lzcount < sizeof(bs_cache)*8) { - break; - } - } - goto extract_rice_param_part; - } - bs->cache = bs_cache; - bs->consumedBits = bs_consumedBits; - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__scalar_zeroorder(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - drflac_uint32 t[2] = {0x00000000, 0xFFFFFFFF}; - drflac_uint32 zeroCountPart0; - drflac_uint32 riceParamPart0; - drflac_uint32 riceParamMask; - drflac_uint32 i; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pSamplesOut != NULL); - (void)bitsPerSample; - (void)order; - (void)shift; - (void)coefficients; - riceParamMask = (drflac_uint32)~((~0UL) << riceParam); - i = 0; - while (i < count) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart0, &riceParamPart0)) { - return DRFLAC_FALSE; - } - riceParamPart0 &= riceParamMask; - riceParamPart0 |= (zeroCountPart0 << riceParam); - riceParamPart0 = (riceParamPart0 >> 1) ^ t[riceParamPart0 & 0x01]; - pSamplesOut[i] = riceParamPart0; - i += 1; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__scalar(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - drflac_uint32 t[2] = {0x00000000, 0xFFFFFFFF}; - drflac_uint32 zeroCountPart0 = 0; - drflac_uint32 zeroCountPart1 = 0; - drflac_uint32 zeroCountPart2 = 0; - drflac_uint32 zeroCountPart3 = 0; - drflac_uint32 riceParamPart0 = 0; - drflac_uint32 riceParamPart1 = 0; - drflac_uint32 riceParamPart2 = 0; - drflac_uint32 riceParamPart3 = 0; - drflac_uint32 riceParamMask; - const drflac_int32* pSamplesOutEnd; - drflac_uint32 i; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pSamplesOut != NULL); - if (lpcOrder == 0) { - return drflac__decode_samples_with_residual__rice__scalar_zeroorder(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, coefficients, pSamplesOut); - } - riceParamMask = (drflac_uint32)~((~0UL) << riceParam); - pSamplesOutEnd = pSamplesOut + (count & ~3); - if (drflac__use_64_bit_prediction(bitsPerSample, lpcOrder, lpcPrecision)) { - while (pSamplesOut < pSamplesOutEnd) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart0, &riceParamPart0) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart1, &riceParamPart1) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart2, &riceParamPart2) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart3, &riceParamPart3)) { - return DRFLAC_FALSE; - } - riceParamPart0 &= riceParamMask; - riceParamPart1 &= riceParamMask; - riceParamPart2 &= riceParamMask; - riceParamPart3 &= riceParamMask; - riceParamPart0 |= (zeroCountPart0 << riceParam); - riceParamPart1 |= (zeroCountPart1 << riceParam); - riceParamPart2 |= (zeroCountPart2 << riceParam); - riceParamPart3 |= (zeroCountPart3 << riceParam); - riceParamPart0 = (riceParamPart0 >> 1) ^ t[riceParamPart0 & 0x01]; - riceParamPart1 = (riceParamPart1 >> 1) ^ t[riceParamPart1 & 0x01]; - riceParamPart2 = (riceParamPart2 >> 1) ^ t[riceParamPart2 & 0x01]; - riceParamPart3 = (riceParamPart3 >> 1) ^ t[riceParamPart3 & 0x01]; - pSamplesOut[0] = riceParamPart0 + drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + 0); - pSamplesOut[1] = riceParamPart1 + drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + 1); - pSamplesOut[2] = riceParamPart2 + drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + 2); - pSamplesOut[3] = riceParamPart3 + drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + 3); - pSamplesOut += 4; - } - } else { - while (pSamplesOut < pSamplesOutEnd) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart0, &riceParamPart0) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart1, &riceParamPart1) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart2, &riceParamPart2) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart3, &riceParamPart3)) { - return DRFLAC_FALSE; - } - riceParamPart0 &= riceParamMask; - riceParamPart1 &= riceParamMask; - riceParamPart2 &= riceParamMask; - riceParamPart3 &= riceParamMask; - riceParamPart0 |= (zeroCountPart0 << riceParam); - riceParamPart1 |= (zeroCountPart1 << riceParam); - riceParamPart2 |= (zeroCountPart2 << riceParam); - riceParamPart3 |= (zeroCountPart3 << riceParam); - riceParamPart0 = (riceParamPart0 >> 1) ^ t[riceParamPart0 & 0x01]; - riceParamPart1 = (riceParamPart1 >> 1) ^ t[riceParamPart1 & 0x01]; - riceParamPart2 = (riceParamPart2 >> 1) ^ t[riceParamPart2 & 0x01]; - riceParamPart3 = (riceParamPart3 >> 1) ^ t[riceParamPart3 & 0x01]; - pSamplesOut[0] = riceParamPart0 + drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + 0); - pSamplesOut[1] = riceParamPart1 + drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + 1); - pSamplesOut[2] = riceParamPart2 + drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + 2); - pSamplesOut[3] = riceParamPart3 + drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + 3); - pSamplesOut += 4; - } - } - i = (count & ~3); - while (i < count) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountPart0, &riceParamPart0)) { - return DRFLAC_FALSE; - } - riceParamPart0 &= riceParamMask; - riceParamPart0 |= (zeroCountPart0 << riceParam); - riceParamPart0 = (riceParamPart0 >> 1) ^ t[riceParamPart0 & 0x01]; - if (drflac__use_64_bit_prediction(bitsPerSample, lpcOrder, lpcPrecision)) { - pSamplesOut[0] = riceParamPart0 + drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + 0); - } else { - pSamplesOut[0] = riceParamPart0 + drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + 0); - } - i += 1; - pSamplesOut += 1; - } - return DRFLAC_TRUE; -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE __m128i drflac__mm_packs_interleaved_epi32(__m128i a, __m128i b) -{ - __m128i r; - r = _mm_packs_epi32(a, b); - r = _mm_shuffle_epi32(r, _MM_SHUFFLE(3, 1, 2, 0)); - r = _mm_shufflehi_epi16(r, _MM_SHUFFLE(3, 1, 2, 0)); - r = _mm_shufflelo_epi16(r, _MM_SHUFFLE(3, 1, 2, 0)); - return r; -} -#endif -#if defined(DRFLAC_SUPPORT_SSE41) -static DRFLAC_INLINE __m128i drflac__mm_not_si128(__m128i a) -{ - return _mm_xor_si128(a, _mm_cmpeq_epi32(_mm_setzero_si128(), _mm_setzero_si128())); -} -static DRFLAC_INLINE __m128i drflac__mm_hadd_epi32(__m128i x) -{ - __m128i x64 = _mm_add_epi32(x, _mm_shuffle_epi32(x, _MM_SHUFFLE(1, 0, 3, 2))); - __m128i x32 = _mm_shufflelo_epi16(x64, _MM_SHUFFLE(1, 0, 3, 2)); - return _mm_add_epi32(x64, x32); -} -static DRFLAC_INLINE __m128i drflac__mm_hadd_epi64(__m128i x) -{ - return _mm_add_epi64(x, _mm_shuffle_epi32(x, _MM_SHUFFLE(1, 0, 3, 2))); -} -static DRFLAC_INLINE __m128i drflac__mm_srai_epi64(__m128i x, int count) -{ - __m128i lo = _mm_srli_epi64(x, count); - __m128i hi = _mm_srai_epi32(x, count); - hi = _mm_and_si128(hi, _mm_set_epi32(0xFFFFFFFF, 0, 0xFFFFFFFF, 0)); - return _mm_or_si128(lo, hi); -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__sse41_32(drflac_bs* bs, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - int i; - drflac_uint32 riceParamMask; - drflac_int32* pDecodedSamples = pSamplesOut; - drflac_int32* pDecodedSamplesEnd = pSamplesOut + (count & ~3); - drflac_uint32 zeroCountParts0 = 0; - drflac_uint32 zeroCountParts1 = 0; - drflac_uint32 zeroCountParts2 = 0; - drflac_uint32 zeroCountParts3 = 0; - drflac_uint32 riceParamParts0 = 0; - drflac_uint32 riceParamParts1 = 0; - drflac_uint32 riceParamParts2 = 0; - drflac_uint32 riceParamParts3 = 0; - __m128i coefficients128_0; - __m128i coefficients128_4; - __m128i coefficients128_8; - __m128i samples128_0; - __m128i samples128_4; - __m128i samples128_8; - __m128i riceParamMask128; - const drflac_uint32 t[2] = {0x00000000, 0xFFFFFFFF}; - riceParamMask = (drflac_uint32)~((~0UL) << riceParam); - riceParamMask128 = _mm_set1_epi32(riceParamMask); - coefficients128_0 = _mm_setzero_si128(); - coefficients128_4 = _mm_setzero_si128(); - coefficients128_8 = _mm_setzero_si128(); - samples128_0 = _mm_setzero_si128(); - samples128_4 = _mm_setzero_si128(); - samples128_8 = _mm_setzero_si128(); -#if 1 - { - int runningOrder = order; - if (runningOrder >= 4) { - coefficients128_0 = _mm_loadu_si128((const __m128i*)(coefficients + 0)); - samples128_0 = _mm_loadu_si128((const __m128i*)(pSamplesOut - 4)); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: coefficients128_0 = _mm_set_epi32(0, coefficients[2], coefficients[1], coefficients[0]); samples128_0 = _mm_set_epi32(pSamplesOut[-1], pSamplesOut[-2], pSamplesOut[-3], 0); break; - case 2: coefficients128_0 = _mm_set_epi32(0, 0, coefficients[1], coefficients[0]); samples128_0 = _mm_set_epi32(pSamplesOut[-1], pSamplesOut[-2], 0, 0); break; - case 1: coefficients128_0 = _mm_set_epi32(0, 0, 0, coefficients[0]); samples128_0 = _mm_set_epi32(pSamplesOut[-1], 0, 0, 0); break; - } - runningOrder = 0; - } - if (runningOrder >= 4) { - coefficients128_4 = _mm_loadu_si128((const __m128i*)(coefficients + 4)); - samples128_4 = _mm_loadu_si128((const __m128i*)(pSamplesOut - 8)); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: coefficients128_4 = _mm_set_epi32(0, coefficients[6], coefficients[5], coefficients[4]); samples128_4 = _mm_set_epi32(pSamplesOut[-5], pSamplesOut[-6], pSamplesOut[-7], 0); break; - case 2: coefficients128_4 = _mm_set_epi32(0, 0, coefficients[5], coefficients[4]); samples128_4 = _mm_set_epi32(pSamplesOut[-5], pSamplesOut[-6], 0, 0); break; - case 1: coefficients128_4 = _mm_set_epi32(0, 0, 0, coefficients[4]); samples128_4 = _mm_set_epi32(pSamplesOut[-5], 0, 0, 0); break; - } - runningOrder = 0; - } - if (runningOrder == 4) { - coefficients128_8 = _mm_loadu_si128((const __m128i*)(coefficients + 8)); - samples128_8 = _mm_loadu_si128((const __m128i*)(pSamplesOut - 12)); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: coefficients128_8 = _mm_set_epi32(0, coefficients[10], coefficients[9], coefficients[8]); samples128_8 = _mm_set_epi32(pSamplesOut[-9], pSamplesOut[-10], pSamplesOut[-11], 0); break; - case 2: coefficients128_8 = _mm_set_epi32(0, 0, coefficients[9], coefficients[8]); samples128_8 = _mm_set_epi32(pSamplesOut[-9], pSamplesOut[-10], 0, 0); break; - case 1: coefficients128_8 = _mm_set_epi32(0, 0, 0, coefficients[8]); samples128_8 = _mm_set_epi32(pSamplesOut[-9], 0, 0, 0); break; - } - runningOrder = 0; - } - coefficients128_0 = _mm_shuffle_epi32(coefficients128_0, _MM_SHUFFLE(0, 1, 2, 3)); - coefficients128_4 = _mm_shuffle_epi32(coefficients128_4, _MM_SHUFFLE(0, 1, 2, 3)); - coefficients128_8 = _mm_shuffle_epi32(coefficients128_8, _MM_SHUFFLE(0, 1, 2, 3)); - } -#else - switch (order) - { - case 12: ((drflac_int32*)&coefficients128_8)[0] = coefficients[11]; ((drflac_int32*)&samples128_8)[0] = pDecodedSamples[-12]; - case 11: ((drflac_int32*)&coefficients128_8)[1] = coefficients[10]; ((drflac_int32*)&samples128_8)[1] = pDecodedSamples[-11]; - case 10: ((drflac_int32*)&coefficients128_8)[2] = coefficients[ 9]; ((drflac_int32*)&samples128_8)[2] = pDecodedSamples[-10]; - case 9: ((drflac_int32*)&coefficients128_8)[3] = coefficients[ 8]; ((drflac_int32*)&samples128_8)[3] = pDecodedSamples[- 9]; - case 8: ((drflac_int32*)&coefficients128_4)[0] = coefficients[ 7]; ((drflac_int32*)&samples128_4)[0] = pDecodedSamples[- 8]; - case 7: ((drflac_int32*)&coefficients128_4)[1] = coefficients[ 6]; ((drflac_int32*)&samples128_4)[1] = pDecodedSamples[- 7]; - case 6: ((drflac_int32*)&coefficients128_4)[2] = coefficients[ 5]; ((drflac_int32*)&samples128_4)[2] = pDecodedSamples[- 6]; - case 5: ((drflac_int32*)&coefficients128_4)[3] = coefficients[ 4]; ((drflac_int32*)&samples128_4)[3] = pDecodedSamples[- 5]; - case 4: ((drflac_int32*)&coefficients128_0)[0] = coefficients[ 3]; ((drflac_int32*)&samples128_0)[0] = pDecodedSamples[- 4]; - case 3: ((drflac_int32*)&coefficients128_0)[1] = coefficients[ 2]; ((drflac_int32*)&samples128_0)[1] = pDecodedSamples[- 3]; - case 2: ((drflac_int32*)&coefficients128_0)[2] = coefficients[ 1]; ((drflac_int32*)&samples128_0)[2] = pDecodedSamples[- 2]; - case 1: ((drflac_int32*)&coefficients128_0)[3] = coefficients[ 0]; ((drflac_int32*)&samples128_0)[3] = pDecodedSamples[- 1]; - } -#endif - while (pDecodedSamples < pDecodedSamplesEnd) { - __m128i prediction128; - __m128i zeroCountPart128; - __m128i riceParamPart128; - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts0, &riceParamParts0) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts1, &riceParamParts1) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts2, &riceParamParts2) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts3, &riceParamParts3)) { - return DRFLAC_FALSE; - } - zeroCountPart128 = _mm_set_epi32(zeroCountParts3, zeroCountParts2, zeroCountParts1, zeroCountParts0); - riceParamPart128 = _mm_set_epi32(riceParamParts3, riceParamParts2, riceParamParts1, riceParamParts0); - riceParamPart128 = _mm_and_si128(riceParamPart128, riceParamMask128); - riceParamPart128 = _mm_or_si128(riceParamPart128, _mm_slli_epi32(zeroCountPart128, riceParam)); - riceParamPart128 = _mm_xor_si128(_mm_srli_epi32(riceParamPart128, 1), _mm_add_epi32(drflac__mm_not_si128(_mm_and_si128(riceParamPart128, _mm_set1_epi32(0x01))), _mm_set1_epi32(0x01))); - if (order <= 4) { - for (i = 0; i < 4; i += 1) { - prediction128 = _mm_mullo_epi32(coefficients128_0, samples128_0); - prediction128 = drflac__mm_hadd_epi32(prediction128); - prediction128 = _mm_srai_epi32(prediction128, shift); - prediction128 = _mm_add_epi32(riceParamPart128, prediction128); - samples128_0 = _mm_alignr_epi8(prediction128, samples128_0, 4); - riceParamPart128 = _mm_alignr_epi8(_mm_setzero_si128(), riceParamPart128, 4); - } - } else if (order <= 8) { - for (i = 0; i < 4; i += 1) { - prediction128 = _mm_mullo_epi32(coefficients128_4, samples128_4); - prediction128 = _mm_add_epi32(prediction128, _mm_mullo_epi32(coefficients128_0, samples128_0)); - prediction128 = drflac__mm_hadd_epi32(prediction128); - prediction128 = _mm_srai_epi32(prediction128, shift); - prediction128 = _mm_add_epi32(riceParamPart128, prediction128); - samples128_4 = _mm_alignr_epi8(samples128_0, samples128_4, 4); - samples128_0 = _mm_alignr_epi8(prediction128, samples128_0, 4); - riceParamPart128 = _mm_alignr_epi8(_mm_setzero_si128(), riceParamPart128, 4); - } - } else { - for (i = 0; i < 4; i += 1) { - prediction128 = _mm_mullo_epi32(coefficients128_8, samples128_8); - prediction128 = _mm_add_epi32(prediction128, _mm_mullo_epi32(coefficients128_4, samples128_4)); - prediction128 = _mm_add_epi32(prediction128, _mm_mullo_epi32(coefficients128_0, samples128_0)); - prediction128 = drflac__mm_hadd_epi32(prediction128); - prediction128 = _mm_srai_epi32(prediction128, shift); - prediction128 = _mm_add_epi32(riceParamPart128, prediction128); - samples128_8 = _mm_alignr_epi8(samples128_4, samples128_8, 4); - samples128_4 = _mm_alignr_epi8(samples128_0, samples128_4, 4); - samples128_0 = _mm_alignr_epi8(prediction128, samples128_0, 4); - riceParamPart128 = _mm_alignr_epi8(_mm_setzero_si128(), riceParamPart128, 4); - } - } - _mm_storeu_si128((__m128i*)pDecodedSamples, samples128_0); - pDecodedSamples += 4; - } - i = (count & ~3); - while (i < (int)count) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts0, &riceParamParts0)) { - return DRFLAC_FALSE; - } - riceParamParts0 &= riceParamMask; - riceParamParts0 |= (zeroCountParts0 << riceParam); - riceParamParts0 = (riceParamParts0 >> 1) ^ t[riceParamParts0 & 0x01]; - pDecodedSamples[0] = riceParamParts0 + drflac__calculate_prediction_32(order, shift, coefficients, pDecodedSamples); - i += 1; - pDecodedSamples += 1; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__sse41_64(drflac_bs* bs, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - int i; - drflac_uint32 riceParamMask; - drflac_int32* pDecodedSamples = pSamplesOut; - drflac_int32* pDecodedSamplesEnd = pSamplesOut + (count & ~3); - drflac_uint32 zeroCountParts0 = 0; - drflac_uint32 zeroCountParts1 = 0; - drflac_uint32 zeroCountParts2 = 0; - drflac_uint32 zeroCountParts3 = 0; - drflac_uint32 riceParamParts0 = 0; - drflac_uint32 riceParamParts1 = 0; - drflac_uint32 riceParamParts2 = 0; - drflac_uint32 riceParamParts3 = 0; - __m128i coefficients128_0; - __m128i coefficients128_4; - __m128i coefficients128_8; - __m128i samples128_0; - __m128i samples128_4; - __m128i samples128_8; - __m128i prediction128; - __m128i riceParamMask128; - const drflac_uint32 t[2] = {0x00000000, 0xFFFFFFFF}; - DRFLAC_ASSERT(order <= 12); - riceParamMask = (drflac_uint32)~((~0UL) << riceParam); - riceParamMask128 = _mm_set1_epi32(riceParamMask); - prediction128 = _mm_setzero_si128(); - coefficients128_0 = _mm_setzero_si128(); - coefficients128_4 = _mm_setzero_si128(); - coefficients128_8 = _mm_setzero_si128(); - samples128_0 = _mm_setzero_si128(); - samples128_4 = _mm_setzero_si128(); - samples128_8 = _mm_setzero_si128(); -#if 1 - { - int runningOrder = order; - if (runningOrder >= 4) { - coefficients128_0 = _mm_loadu_si128((const __m128i*)(coefficients + 0)); - samples128_0 = _mm_loadu_si128((const __m128i*)(pSamplesOut - 4)); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: coefficients128_0 = _mm_set_epi32(0, coefficients[2], coefficients[1], coefficients[0]); samples128_0 = _mm_set_epi32(pSamplesOut[-1], pSamplesOut[-2], pSamplesOut[-3], 0); break; - case 2: coefficients128_0 = _mm_set_epi32(0, 0, coefficients[1], coefficients[0]); samples128_0 = _mm_set_epi32(pSamplesOut[-1], pSamplesOut[-2], 0, 0); break; - case 1: coefficients128_0 = _mm_set_epi32(0, 0, 0, coefficients[0]); samples128_0 = _mm_set_epi32(pSamplesOut[-1], 0, 0, 0); break; - } - runningOrder = 0; - } - if (runningOrder >= 4) { - coefficients128_4 = _mm_loadu_si128((const __m128i*)(coefficients + 4)); - samples128_4 = _mm_loadu_si128((const __m128i*)(pSamplesOut - 8)); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: coefficients128_4 = _mm_set_epi32(0, coefficients[6], coefficients[5], coefficients[4]); samples128_4 = _mm_set_epi32(pSamplesOut[-5], pSamplesOut[-6], pSamplesOut[-7], 0); break; - case 2: coefficients128_4 = _mm_set_epi32(0, 0, coefficients[5], coefficients[4]); samples128_4 = _mm_set_epi32(pSamplesOut[-5], pSamplesOut[-6], 0, 0); break; - case 1: coefficients128_4 = _mm_set_epi32(0, 0, 0, coefficients[4]); samples128_4 = _mm_set_epi32(pSamplesOut[-5], 0, 0, 0); break; - } - runningOrder = 0; - } - if (runningOrder == 4) { - coefficients128_8 = _mm_loadu_si128((const __m128i*)(coefficients + 8)); - samples128_8 = _mm_loadu_si128((const __m128i*)(pSamplesOut - 12)); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: coefficients128_8 = _mm_set_epi32(0, coefficients[10], coefficients[9], coefficients[8]); samples128_8 = _mm_set_epi32(pSamplesOut[-9], pSamplesOut[-10], pSamplesOut[-11], 0); break; - case 2: coefficients128_8 = _mm_set_epi32(0, 0, coefficients[9], coefficients[8]); samples128_8 = _mm_set_epi32(pSamplesOut[-9], pSamplesOut[-10], 0, 0); break; - case 1: coefficients128_8 = _mm_set_epi32(0, 0, 0, coefficients[8]); samples128_8 = _mm_set_epi32(pSamplesOut[-9], 0, 0, 0); break; - } - runningOrder = 0; - } - coefficients128_0 = _mm_shuffle_epi32(coefficients128_0, _MM_SHUFFLE(0, 1, 2, 3)); - coefficients128_4 = _mm_shuffle_epi32(coefficients128_4, _MM_SHUFFLE(0, 1, 2, 3)); - coefficients128_8 = _mm_shuffle_epi32(coefficients128_8, _MM_SHUFFLE(0, 1, 2, 3)); - } -#else - switch (order) - { - case 12: ((drflac_int32*)&coefficients128_8)[0] = coefficients[11]; ((drflac_int32*)&samples128_8)[0] = pDecodedSamples[-12]; - case 11: ((drflac_int32*)&coefficients128_8)[1] = coefficients[10]; ((drflac_int32*)&samples128_8)[1] = pDecodedSamples[-11]; - case 10: ((drflac_int32*)&coefficients128_8)[2] = coefficients[ 9]; ((drflac_int32*)&samples128_8)[2] = pDecodedSamples[-10]; - case 9: ((drflac_int32*)&coefficients128_8)[3] = coefficients[ 8]; ((drflac_int32*)&samples128_8)[3] = pDecodedSamples[- 9]; - case 8: ((drflac_int32*)&coefficients128_4)[0] = coefficients[ 7]; ((drflac_int32*)&samples128_4)[0] = pDecodedSamples[- 8]; - case 7: ((drflac_int32*)&coefficients128_4)[1] = coefficients[ 6]; ((drflac_int32*)&samples128_4)[1] = pDecodedSamples[- 7]; - case 6: ((drflac_int32*)&coefficients128_4)[2] = coefficients[ 5]; ((drflac_int32*)&samples128_4)[2] = pDecodedSamples[- 6]; - case 5: ((drflac_int32*)&coefficients128_4)[3] = coefficients[ 4]; ((drflac_int32*)&samples128_4)[3] = pDecodedSamples[- 5]; - case 4: ((drflac_int32*)&coefficients128_0)[0] = coefficients[ 3]; ((drflac_int32*)&samples128_0)[0] = pDecodedSamples[- 4]; - case 3: ((drflac_int32*)&coefficients128_0)[1] = coefficients[ 2]; ((drflac_int32*)&samples128_0)[1] = pDecodedSamples[- 3]; - case 2: ((drflac_int32*)&coefficients128_0)[2] = coefficients[ 1]; ((drflac_int32*)&samples128_0)[2] = pDecodedSamples[- 2]; - case 1: ((drflac_int32*)&coefficients128_0)[3] = coefficients[ 0]; ((drflac_int32*)&samples128_0)[3] = pDecodedSamples[- 1]; - } -#endif - while (pDecodedSamples < pDecodedSamplesEnd) { - __m128i zeroCountPart128; - __m128i riceParamPart128; - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts0, &riceParamParts0) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts1, &riceParamParts1) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts2, &riceParamParts2) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts3, &riceParamParts3)) { - return DRFLAC_FALSE; - } - zeroCountPart128 = _mm_set_epi32(zeroCountParts3, zeroCountParts2, zeroCountParts1, zeroCountParts0); - riceParamPart128 = _mm_set_epi32(riceParamParts3, riceParamParts2, riceParamParts1, riceParamParts0); - riceParamPart128 = _mm_and_si128(riceParamPart128, riceParamMask128); - riceParamPart128 = _mm_or_si128(riceParamPart128, _mm_slli_epi32(zeroCountPart128, riceParam)); - riceParamPart128 = _mm_xor_si128(_mm_srli_epi32(riceParamPart128, 1), _mm_add_epi32(drflac__mm_not_si128(_mm_and_si128(riceParamPart128, _mm_set1_epi32(1))), _mm_set1_epi32(1))); - for (i = 0; i < 4; i += 1) { - prediction128 = _mm_xor_si128(prediction128, prediction128); - switch (order) - { - case 12: - case 11: prediction128 = _mm_add_epi64(prediction128, _mm_mul_epi32(_mm_shuffle_epi32(coefficients128_8, _MM_SHUFFLE(1, 1, 0, 0)), _mm_shuffle_epi32(samples128_8, _MM_SHUFFLE(1, 1, 0, 0)))); - case 10: - case 9: prediction128 = _mm_add_epi64(prediction128, _mm_mul_epi32(_mm_shuffle_epi32(coefficients128_8, _MM_SHUFFLE(3, 3, 2, 2)), _mm_shuffle_epi32(samples128_8, _MM_SHUFFLE(3, 3, 2, 2)))); - case 8: - case 7: prediction128 = _mm_add_epi64(prediction128, _mm_mul_epi32(_mm_shuffle_epi32(coefficients128_4, _MM_SHUFFLE(1, 1, 0, 0)), _mm_shuffle_epi32(samples128_4, _MM_SHUFFLE(1, 1, 0, 0)))); - case 6: - case 5: prediction128 = _mm_add_epi64(prediction128, _mm_mul_epi32(_mm_shuffle_epi32(coefficients128_4, _MM_SHUFFLE(3, 3, 2, 2)), _mm_shuffle_epi32(samples128_4, _MM_SHUFFLE(3, 3, 2, 2)))); - case 4: - case 3: prediction128 = _mm_add_epi64(prediction128, _mm_mul_epi32(_mm_shuffle_epi32(coefficients128_0, _MM_SHUFFLE(1, 1, 0, 0)), _mm_shuffle_epi32(samples128_0, _MM_SHUFFLE(1, 1, 0, 0)))); - case 2: - case 1: prediction128 = _mm_add_epi64(prediction128, _mm_mul_epi32(_mm_shuffle_epi32(coefficients128_0, _MM_SHUFFLE(3, 3, 2, 2)), _mm_shuffle_epi32(samples128_0, _MM_SHUFFLE(3, 3, 2, 2)))); - } - prediction128 = drflac__mm_hadd_epi64(prediction128); - prediction128 = drflac__mm_srai_epi64(prediction128, shift); - prediction128 = _mm_add_epi32(riceParamPart128, prediction128); - samples128_8 = _mm_alignr_epi8(samples128_4, samples128_8, 4); - samples128_4 = _mm_alignr_epi8(samples128_0, samples128_4, 4); - samples128_0 = _mm_alignr_epi8(prediction128, samples128_0, 4); - riceParamPart128 = _mm_alignr_epi8(_mm_setzero_si128(), riceParamPart128, 4); - } - _mm_storeu_si128((__m128i*)pDecodedSamples, samples128_0); - pDecodedSamples += 4; - } - i = (count & ~3); - while (i < (int)count) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts0, &riceParamParts0)) { - return DRFLAC_FALSE; - } - riceParamParts0 &= riceParamMask; - riceParamParts0 |= (zeroCountParts0 << riceParam); - riceParamParts0 = (riceParamParts0 >> 1) ^ t[riceParamParts0 & 0x01]; - pDecodedSamples[0] = riceParamParts0 + drflac__calculate_prediction_64(order, shift, coefficients, pDecodedSamples); - i += 1; - pDecodedSamples += 1; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__sse41(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pSamplesOut != NULL); - if (lpcOrder > 0 && lpcOrder <= 12) { - if (drflac__use_64_bit_prediction(bitsPerSample, lpcOrder, lpcPrecision)) { - return drflac__decode_samples_with_residual__rice__sse41_64(bs, count, riceParam, lpcOrder, lpcShift, coefficients, pSamplesOut); - } else { - return drflac__decode_samples_with_residual__rice__sse41_32(bs, count, riceParam, lpcOrder, lpcShift, coefficients, pSamplesOut); - } - } else { - return drflac__decode_samples_with_residual__rice__scalar(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pSamplesOut); - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac__vst2q_s32(drflac_int32* p, int32x4x2_t x) -{ - vst1q_s32(p+0, x.val[0]); - vst1q_s32(p+4, x.val[1]); -} -static DRFLAC_INLINE void drflac__vst2q_u32(drflac_uint32* p, uint32x4x2_t x) -{ - vst1q_u32(p+0, x.val[0]); - vst1q_u32(p+4, x.val[1]); -} -static DRFLAC_INLINE void drflac__vst2q_f32(float* p, float32x4x2_t x) -{ - vst1q_f32(p+0, x.val[0]); - vst1q_f32(p+4, x.val[1]); -} -static DRFLAC_INLINE void drflac__vst2q_s16(drflac_int16* p, int16x4x2_t x) -{ - vst1q_s16(p, vcombine_s16(x.val[0], x.val[1])); -} -static DRFLAC_INLINE void drflac__vst2q_u16(drflac_uint16* p, uint16x4x2_t x) -{ - vst1q_u16(p, vcombine_u16(x.val[0], x.val[1])); -} -static DRFLAC_INLINE int32x4_t drflac__vdupq_n_s32x4(drflac_int32 x3, drflac_int32 x2, drflac_int32 x1, drflac_int32 x0) -{ - drflac_int32 x[4]; - x[3] = x3; - x[2] = x2; - x[1] = x1; - x[0] = x0; - return vld1q_s32(x); -} -static DRFLAC_INLINE int32x4_t drflac__valignrq_s32_1(int32x4_t a, int32x4_t b) -{ - return vextq_s32(b, a, 1); -} -static DRFLAC_INLINE uint32x4_t drflac__valignrq_u32_1(uint32x4_t a, uint32x4_t b) -{ - return vextq_u32(b, a, 1); -} -static DRFLAC_INLINE int32x2_t drflac__vhaddq_s32(int32x4_t x) -{ - int32x2_t r = vadd_s32(vget_high_s32(x), vget_low_s32(x)); - return vpadd_s32(r, r); -} -static DRFLAC_INLINE int64x1_t drflac__vhaddq_s64(int64x2_t x) -{ - return vadd_s64(vget_high_s64(x), vget_low_s64(x)); -} -static DRFLAC_INLINE int32x4_t drflac__vrevq_s32(int32x4_t x) -{ - return vrev64q_s32(vcombine_s32(vget_high_s32(x), vget_low_s32(x))); -} -static DRFLAC_INLINE int32x4_t drflac__vnotq_s32(int32x4_t x) -{ - return veorq_s32(x, vdupq_n_s32(0xFFFFFFFF)); -} -static DRFLAC_INLINE uint32x4_t drflac__vnotq_u32(uint32x4_t x) -{ - return veorq_u32(x, vdupq_n_u32(0xFFFFFFFF)); -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__neon_32(drflac_bs* bs, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - int i; - drflac_uint32 riceParamMask; - drflac_int32* pDecodedSamples = pSamplesOut; - drflac_int32* pDecodedSamplesEnd = pSamplesOut + (count & ~3); - drflac_uint32 zeroCountParts[4]; - drflac_uint32 riceParamParts[4]; - int32x4_t coefficients128_0; - int32x4_t coefficients128_4; - int32x4_t coefficients128_8; - int32x4_t samples128_0; - int32x4_t samples128_4; - int32x4_t samples128_8; - uint32x4_t riceParamMask128; - int32x4_t riceParam128; - int32x2_t shift64; - uint32x4_t one128; - const drflac_uint32 t[2] = {0x00000000, 0xFFFFFFFF}; - riceParamMask = (drflac_uint32)~((~0UL) << riceParam); - riceParamMask128 = vdupq_n_u32(riceParamMask); - riceParam128 = vdupq_n_s32(riceParam); - shift64 = vdup_n_s32(-shift); - one128 = vdupq_n_u32(1); - { - int runningOrder = order; - drflac_int32 tempC[4] = {0, 0, 0, 0}; - drflac_int32 tempS[4] = {0, 0, 0, 0}; - if (runningOrder >= 4) { - coefficients128_0 = vld1q_s32(coefficients + 0); - samples128_0 = vld1q_s32(pSamplesOut - 4); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: tempC[2] = coefficients[2]; tempS[1] = pSamplesOut[-3]; - case 2: tempC[1] = coefficients[1]; tempS[2] = pSamplesOut[-2]; - case 1: tempC[0] = coefficients[0]; tempS[3] = pSamplesOut[-1]; - } - coefficients128_0 = vld1q_s32(tempC); - samples128_0 = vld1q_s32(tempS); - runningOrder = 0; - } - if (runningOrder >= 4) { - coefficients128_4 = vld1q_s32(coefficients + 4); - samples128_4 = vld1q_s32(pSamplesOut - 8); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: tempC[2] = coefficients[6]; tempS[1] = pSamplesOut[-7]; - case 2: tempC[1] = coefficients[5]; tempS[2] = pSamplesOut[-6]; - case 1: tempC[0] = coefficients[4]; tempS[3] = pSamplesOut[-5]; - } - coefficients128_4 = vld1q_s32(tempC); - samples128_4 = vld1q_s32(tempS); - runningOrder = 0; - } - if (runningOrder == 4) { - coefficients128_8 = vld1q_s32(coefficients + 8); - samples128_8 = vld1q_s32(pSamplesOut - 12); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: tempC[2] = coefficients[10]; tempS[1] = pSamplesOut[-11]; - case 2: tempC[1] = coefficients[ 9]; tempS[2] = pSamplesOut[-10]; - case 1: tempC[0] = coefficients[ 8]; tempS[3] = pSamplesOut[- 9]; - } - coefficients128_8 = vld1q_s32(tempC); - samples128_8 = vld1q_s32(tempS); - runningOrder = 0; - } - coefficients128_0 = drflac__vrevq_s32(coefficients128_0); - coefficients128_4 = drflac__vrevq_s32(coefficients128_4); - coefficients128_8 = drflac__vrevq_s32(coefficients128_8); - } - while (pDecodedSamples < pDecodedSamplesEnd) { - int32x4_t prediction128; - int32x2_t prediction64; - uint32x4_t zeroCountPart128; - uint32x4_t riceParamPart128; - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[0], &riceParamParts[0]) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[1], &riceParamParts[1]) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[2], &riceParamParts[2]) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[3], &riceParamParts[3])) { - return DRFLAC_FALSE; - } - zeroCountPart128 = vld1q_u32(zeroCountParts); - riceParamPart128 = vld1q_u32(riceParamParts); - riceParamPart128 = vandq_u32(riceParamPart128, riceParamMask128); - riceParamPart128 = vorrq_u32(riceParamPart128, vshlq_u32(zeroCountPart128, riceParam128)); - riceParamPart128 = veorq_u32(vshrq_n_u32(riceParamPart128, 1), vaddq_u32(drflac__vnotq_u32(vandq_u32(riceParamPart128, one128)), one128)); - if (order <= 4) { - for (i = 0; i < 4; i += 1) { - prediction128 = vmulq_s32(coefficients128_0, samples128_0); - prediction64 = drflac__vhaddq_s32(prediction128); - prediction64 = vshl_s32(prediction64, shift64); - prediction64 = vadd_s32(prediction64, vget_low_s32(vreinterpretq_s32_u32(riceParamPart128))); - samples128_0 = drflac__valignrq_s32_1(vcombine_s32(prediction64, vdup_n_s32(0)), samples128_0); - riceParamPart128 = drflac__valignrq_u32_1(vdupq_n_u32(0), riceParamPart128); - } - } else if (order <= 8) { - for (i = 0; i < 4; i += 1) { - prediction128 = vmulq_s32(coefficients128_4, samples128_4); - prediction128 = vmlaq_s32(prediction128, coefficients128_0, samples128_0); - prediction64 = drflac__vhaddq_s32(prediction128); - prediction64 = vshl_s32(prediction64, shift64); - prediction64 = vadd_s32(prediction64, vget_low_s32(vreinterpretq_s32_u32(riceParamPart128))); - samples128_4 = drflac__valignrq_s32_1(samples128_0, samples128_4); - samples128_0 = drflac__valignrq_s32_1(vcombine_s32(prediction64, vdup_n_s32(0)), samples128_0); - riceParamPart128 = drflac__valignrq_u32_1(vdupq_n_u32(0), riceParamPart128); - } - } else { - for (i = 0; i < 4; i += 1) { - prediction128 = vmulq_s32(coefficients128_8, samples128_8); - prediction128 = vmlaq_s32(prediction128, coefficients128_4, samples128_4); - prediction128 = vmlaq_s32(prediction128, coefficients128_0, samples128_0); - prediction64 = drflac__vhaddq_s32(prediction128); - prediction64 = vshl_s32(prediction64, shift64); - prediction64 = vadd_s32(prediction64, vget_low_s32(vreinterpretq_s32_u32(riceParamPart128))); - samples128_8 = drflac__valignrq_s32_1(samples128_4, samples128_8); - samples128_4 = drflac__valignrq_s32_1(samples128_0, samples128_4); - samples128_0 = drflac__valignrq_s32_1(vcombine_s32(prediction64, vdup_n_s32(0)), samples128_0); - riceParamPart128 = drflac__valignrq_u32_1(vdupq_n_u32(0), riceParamPart128); - } - } - vst1q_s32(pDecodedSamples, samples128_0); - pDecodedSamples += 4; - } - i = (count & ~3); - while (i < (int)count) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[0], &riceParamParts[0])) { - return DRFLAC_FALSE; - } - riceParamParts[0] &= riceParamMask; - riceParamParts[0] |= (zeroCountParts[0] << riceParam); - riceParamParts[0] = (riceParamParts[0] >> 1) ^ t[riceParamParts[0] & 0x01]; - pDecodedSamples[0] = riceParamParts[0] + drflac__calculate_prediction_32(order, shift, coefficients, pDecodedSamples); - i += 1; - pDecodedSamples += 1; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__neon_64(drflac_bs* bs, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 order, drflac_int32 shift, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - int i; - drflac_uint32 riceParamMask; - drflac_int32* pDecodedSamples = pSamplesOut; - drflac_int32* pDecodedSamplesEnd = pSamplesOut + (count & ~3); - drflac_uint32 zeroCountParts[4]; - drflac_uint32 riceParamParts[4]; - int32x4_t coefficients128_0; - int32x4_t coefficients128_4; - int32x4_t coefficients128_8; - int32x4_t samples128_0; - int32x4_t samples128_4; - int32x4_t samples128_8; - uint32x4_t riceParamMask128; - int32x4_t riceParam128; - int64x1_t shift64; - uint32x4_t one128; - int64x2_t prediction128 = { 0 }; - uint32x4_t zeroCountPart128; - uint32x4_t riceParamPart128; - const drflac_uint32 t[2] = {0x00000000, 0xFFFFFFFF}; - riceParamMask = (drflac_uint32)~((~0UL) << riceParam); - riceParamMask128 = vdupq_n_u32(riceParamMask); - riceParam128 = vdupq_n_s32(riceParam); - shift64 = vdup_n_s64(-shift); - one128 = vdupq_n_u32(1); - { - int runningOrder = order; - drflac_int32 tempC[4] = {0, 0, 0, 0}; - drflac_int32 tempS[4] = {0, 0, 0, 0}; - if (runningOrder >= 4) { - coefficients128_0 = vld1q_s32(coefficients + 0); - samples128_0 = vld1q_s32(pSamplesOut - 4); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: tempC[2] = coefficients[2]; tempS[1] = pSamplesOut[-3]; - case 2: tempC[1] = coefficients[1]; tempS[2] = pSamplesOut[-2]; - case 1: tempC[0] = coefficients[0]; tempS[3] = pSamplesOut[-1]; - } - coefficients128_0 = vld1q_s32(tempC); - samples128_0 = vld1q_s32(tempS); - runningOrder = 0; - } - if (runningOrder >= 4) { - coefficients128_4 = vld1q_s32(coefficients + 4); - samples128_4 = vld1q_s32(pSamplesOut - 8); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: tempC[2] = coefficients[6]; tempS[1] = pSamplesOut[-7]; - case 2: tempC[1] = coefficients[5]; tempS[2] = pSamplesOut[-6]; - case 1: tempC[0] = coefficients[4]; tempS[3] = pSamplesOut[-5]; - } - coefficients128_4 = vld1q_s32(tempC); - samples128_4 = vld1q_s32(tempS); - runningOrder = 0; - } - if (runningOrder == 4) { - coefficients128_8 = vld1q_s32(coefficients + 8); - samples128_8 = vld1q_s32(pSamplesOut - 12); - runningOrder -= 4; - } else { - switch (runningOrder) { - case 3: tempC[2] = coefficients[10]; tempS[1] = pSamplesOut[-11]; - case 2: tempC[1] = coefficients[ 9]; tempS[2] = pSamplesOut[-10]; - case 1: tempC[0] = coefficients[ 8]; tempS[3] = pSamplesOut[- 9]; - } - coefficients128_8 = vld1q_s32(tempC); - samples128_8 = vld1q_s32(tempS); - runningOrder = 0; - } - coefficients128_0 = drflac__vrevq_s32(coefficients128_0); - coefficients128_4 = drflac__vrevq_s32(coefficients128_4); - coefficients128_8 = drflac__vrevq_s32(coefficients128_8); - } - while (pDecodedSamples < pDecodedSamplesEnd) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[0], &riceParamParts[0]) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[1], &riceParamParts[1]) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[2], &riceParamParts[2]) || - !drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[3], &riceParamParts[3])) { - return DRFLAC_FALSE; - } - zeroCountPart128 = vld1q_u32(zeroCountParts); - riceParamPart128 = vld1q_u32(riceParamParts); - riceParamPart128 = vandq_u32(riceParamPart128, riceParamMask128); - riceParamPart128 = vorrq_u32(riceParamPart128, vshlq_u32(zeroCountPart128, riceParam128)); - riceParamPart128 = veorq_u32(vshrq_n_u32(riceParamPart128, 1), vaddq_u32(drflac__vnotq_u32(vandq_u32(riceParamPart128, one128)), one128)); - for (i = 0; i < 4; i += 1) { - int64x1_t prediction64; - prediction128 = veorq_s64(prediction128, prediction128); - switch (order) - { - case 12: - case 11: prediction128 = vaddq_s64(prediction128, vmull_s32(vget_low_s32(coefficients128_8), vget_low_s32(samples128_8))); - case 10: - case 9: prediction128 = vaddq_s64(prediction128, vmull_s32(vget_high_s32(coefficients128_8), vget_high_s32(samples128_8))); - case 8: - case 7: prediction128 = vaddq_s64(prediction128, vmull_s32(vget_low_s32(coefficients128_4), vget_low_s32(samples128_4))); - case 6: - case 5: prediction128 = vaddq_s64(prediction128, vmull_s32(vget_high_s32(coefficients128_4), vget_high_s32(samples128_4))); - case 4: - case 3: prediction128 = vaddq_s64(prediction128, vmull_s32(vget_low_s32(coefficients128_0), vget_low_s32(samples128_0))); - case 2: - case 1: prediction128 = vaddq_s64(prediction128, vmull_s32(vget_high_s32(coefficients128_0), vget_high_s32(samples128_0))); - } - prediction64 = drflac__vhaddq_s64(prediction128); - prediction64 = vshl_s64(prediction64, shift64); - prediction64 = vadd_s64(prediction64, vdup_n_s64(vgetq_lane_u32(riceParamPart128, 0))); - samples128_8 = drflac__valignrq_s32_1(samples128_4, samples128_8); - samples128_4 = drflac__valignrq_s32_1(samples128_0, samples128_4); - samples128_0 = drflac__valignrq_s32_1(vcombine_s32(vreinterpret_s32_s64(prediction64), vdup_n_s32(0)), samples128_0); - riceParamPart128 = drflac__valignrq_u32_1(vdupq_n_u32(0), riceParamPart128); - } - vst1q_s32(pDecodedSamples, samples128_0); - pDecodedSamples += 4; - } - i = (count & ~3); - while (i < (int)count) { - if (!drflac__read_rice_parts_x1(bs, riceParam, &zeroCountParts[0], &riceParamParts[0])) { - return DRFLAC_FALSE; - } - riceParamParts[0] &= riceParamMask; - riceParamParts[0] |= (zeroCountParts[0] << riceParam); - riceParamParts[0] = (riceParamParts[0] >> 1) ^ t[riceParamParts[0] & 0x01]; - pDecodedSamples[0] = riceParamParts[0] + drflac__calculate_prediction_64(order, shift, coefficients, pDecodedSamples); - i += 1; - pDecodedSamples += 1; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual__rice__neon(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(pSamplesOut != NULL); - if (lpcOrder > 0 && lpcOrder <= 12) { - if (drflac__use_64_bit_prediction(bitsPerSample, lpcOrder, lpcPrecision)) { - return drflac__decode_samples_with_residual__rice__neon_64(bs, count, riceParam, lpcOrder, lpcShift, coefficients, pSamplesOut); - } else { - return drflac__decode_samples_with_residual__rice__neon_32(bs, count, riceParam, lpcOrder, lpcShift, coefficients, pSamplesOut); - } - } else { - return drflac__decode_samples_with_residual__rice__scalar(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pSamplesOut); - } -} -#endif -static drflac_bool32 drflac__decode_samples_with_residual__rice(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 riceParam, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ -#if defined(DRFLAC_SUPPORT_SSE41) - if (drflac__gIsSSE41Supported) { - return drflac__decode_samples_with_residual__rice__sse41(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pSamplesOut); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported) { - return drflac__decode_samples_with_residual__rice__neon(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pSamplesOut); - } else -#endif - { - #if 0 - return drflac__decode_samples_with_residual__rice__reference(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pSamplesOut); - #else - return drflac__decode_samples_with_residual__rice__scalar(bs, bitsPerSample, count, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pSamplesOut); - #endif - } -} -static drflac_bool32 drflac__read_and_seek_residual__rice(drflac_bs* bs, drflac_uint32 count, drflac_uint8 riceParam) -{ - drflac_uint32 i; - DRFLAC_ASSERT(bs != NULL); - for (i = 0; i < count; ++i) { - if (!drflac__seek_rice_parts(bs, riceParam)) { - return DRFLAC_FALSE; - } - } - return DRFLAC_TRUE; -} -#if defined(__clang__) -__attribute__((no_sanitize("signed-integer-overflow"))) -#endif -static drflac_bool32 drflac__decode_samples_with_residual__unencoded(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 count, drflac_uint8 unencodedBitsPerSample, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pSamplesOut) -{ - drflac_uint32 i; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(unencodedBitsPerSample <= 31); - DRFLAC_ASSERT(pSamplesOut != NULL); - for (i = 0; i < count; ++i) { - if (unencodedBitsPerSample > 0) { - if (!drflac__read_int32(bs, unencodedBitsPerSample, pSamplesOut + i)) { - return DRFLAC_FALSE; - } - } else { - pSamplesOut[i] = 0; - } - if (drflac__use_64_bit_prediction(bitsPerSample, lpcOrder, lpcPrecision)) { - pSamplesOut[i] += drflac__calculate_prediction_64(lpcOrder, lpcShift, coefficients, pSamplesOut + i); - } else { - pSamplesOut[i] += drflac__calculate_prediction_32(lpcOrder, lpcShift, coefficients, pSamplesOut + i); - } - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples_with_residual(drflac_bs* bs, drflac_uint32 bitsPerSample, drflac_uint32 blockSize, drflac_uint32 lpcOrder, drflac_int32 lpcShift, drflac_uint32 lpcPrecision, const drflac_int32* coefficients, drflac_int32* pDecodedSamples) -{ - drflac_uint8 residualMethod; - drflac_uint8 partitionOrder; - drflac_uint32 samplesInPartition; - drflac_uint32 partitionsRemaining; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(blockSize != 0); - DRFLAC_ASSERT(pDecodedSamples != NULL); - if (!drflac__read_uint8(bs, 2, &residualMethod)) { - return DRFLAC_FALSE; - } - if (residualMethod != DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE && residualMethod != DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE2) { - return DRFLAC_FALSE; - } - pDecodedSamples += lpcOrder; - if (!drflac__read_uint8(bs, 4, &partitionOrder)) { - return DRFLAC_FALSE; - } - if (partitionOrder > 8) { - return DRFLAC_FALSE; - } - if ((blockSize / (1 << partitionOrder)) < lpcOrder) { - return DRFLAC_FALSE; - } - samplesInPartition = (blockSize / (1 << partitionOrder)) - lpcOrder; - partitionsRemaining = (1 << partitionOrder); - for (;;) { - drflac_uint8 riceParam = 0; - if (residualMethod == DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE) { - if (!drflac__read_uint8(bs, 4, &riceParam)) { - return DRFLAC_FALSE; - } - if (riceParam == 15) { - riceParam = 0xFF; - } - } else if (residualMethod == DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE2) { - if (!drflac__read_uint8(bs, 5, &riceParam)) { - return DRFLAC_FALSE; - } - if (riceParam == 31) { - riceParam = 0xFF; - } - } - if (riceParam != 0xFF) { - if (!drflac__decode_samples_with_residual__rice(bs, bitsPerSample, samplesInPartition, riceParam, lpcOrder, lpcShift, lpcPrecision, coefficients, pDecodedSamples)) { - return DRFLAC_FALSE; - } - } else { - drflac_uint8 unencodedBitsPerSample = 0; - if (!drflac__read_uint8(bs, 5, &unencodedBitsPerSample)) { - return DRFLAC_FALSE; - } - if (!drflac__decode_samples_with_residual__unencoded(bs, bitsPerSample, samplesInPartition, unencodedBitsPerSample, lpcOrder, lpcShift, lpcPrecision, coefficients, pDecodedSamples)) { - return DRFLAC_FALSE; - } - } - pDecodedSamples += samplesInPartition; - if (partitionsRemaining == 1) { - break; - } - partitionsRemaining -= 1; - if (partitionOrder != 0) { - samplesInPartition = blockSize / (1 << partitionOrder); - } - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__read_and_seek_residual(drflac_bs* bs, drflac_uint32 blockSize, drflac_uint32 order) -{ - drflac_uint8 residualMethod; - drflac_uint8 partitionOrder; - drflac_uint32 samplesInPartition; - drflac_uint32 partitionsRemaining; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(blockSize != 0); - if (!drflac__read_uint8(bs, 2, &residualMethod)) { - return DRFLAC_FALSE; - } - if (residualMethod != DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE && residualMethod != DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE2) { - return DRFLAC_FALSE; - } - if (!drflac__read_uint8(bs, 4, &partitionOrder)) { - return DRFLAC_FALSE; - } - if (partitionOrder > 8) { - return DRFLAC_FALSE; - } - if ((blockSize / (1 << partitionOrder)) <= order) { - return DRFLAC_FALSE; - } - samplesInPartition = (blockSize / (1 << partitionOrder)) - order; - partitionsRemaining = (1 << partitionOrder); - for (;;) - { - drflac_uint8 riceParam = 0; - if (residualMethod == DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE) { - if (!drflac__read_uint8(bs, 4, &riceParam)) { - return DRFLAC_FALSE; - } - if (riceParam == 15) { - riceParam = 0xFF; - } - } else if (residualMethod == DRFLAC_RESIDUAL_CODING_METHOD_PARTITIONED_RICE2) { - if (!drflac__read_uint8(bs, 5, &riceParam)) { - return DRFLAC_FALSE; - } - if (riceParam == 31) { - riceParam = 0xFF; - } - } - if (riceParam != 0xFF) { - if (!drflac__read_and_seek_residual__rice(bs, samplesInPartition, riceParam)) { - return DRFLAC_FALSE; - } - } else { - drflac_uint8 unencodedBitsPerSample = 0; - if (!drflac__read_uint8(bs, 5, &unencodedBitsPerSample)) { - return DRFLAC_FALSE; - } - if (!drflac__seek_bits(bs, unencodedBitsPerSample * samplesInPartition)) { - return DRFLAC_FALSE; - } - } - if (partitionsRemaining == 1) { - break; - } - partitionsRemaining -= 1; - samplesInPartition = blockSize / (1 << partitionOrder); - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples__constant(drflac_bs* bs, drflac_uint32 blockSize, drflac_uint32 subframeBitsPerSample, drflac_int32* pDecodedSamples) -{ - drflac_uint32 i; - drflac_int32 sample; - if (!drflac__read_int32(bs, subframeBitsPerSample, &sample)) { - return DRFLAC_FALSE; - } - for (i = 0; i < blockSize; ++i) { - pDecodedSamples[i] = sample; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples__verbatim(drflac_bs* bs, drflac_uint32 blockSize, drflac_uint32 subframeBitsPerSample, drflac_int32* pDecodedSamples) -{ - drflac_uint32 i; - for (i = 0; i < blockSize; ++i) { - drflac_int32 sample; - if (!drflac__read_int32(bs, subframeBitsPerSample, &sample)) { - return DRFLAC_FALSE; - } - pDecodedSamples[i] = sample; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples__fixed(drflac_bs* bs, drflac_uint32 blockSize, drflac_uint32 subframeBitsPerSample, drflac_uint8 lpcOrder, drflac_int32* pDecodedSamples) -{ - drflac_uint32 i; - static drflac_int32 lpcCoefficientsTable[5][4] = { - {0, 0, 0, 0}, - {1, 0, 0, 0}, - {2, -1, 0, 0}, - {3, -3, 1, 0}, - {4, -6, 4, -1} - }; - for (i = 0; i < lpcOrder; ++i) { - drflac_int32 sample; - if (!drflac__read_int32(bs, subframeBitsPerSample, &sample)) { - return DRFLAC_FALSE; - } - pDecodedSamples[i] = sample; - } - if (!drflac__decode_samples_with_residual(bs, subframeBitsPerSample, blockSize, lpcOrder, 0, 4, lpcCoefficientsTable[lpcOrder], pDecodedSamples)) { - return DRFLAC_FALSE; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_samples__lpc(drflac_bs* bs, drflac_uint32 blockSize, drflac_uint32 bitsPerSample, drflac_uint8 lpcOrder, drflac_int32* pDecodedSamples) -{ - drflac_uint8 i; - drflac_uint8 lpcPrecision; - drflac_int8 lpcShift; - drflac_int32 coefficients[32]; - for (i = 0; i < lpcOrder; ++i) { - drflac_int32 sample; - if (!drflac__read_int32(bs, bitsPerSample, &sample)) { - return DRFLAC_FALSE; - } - pDecodedSamples[i] = sample; - } - if (!drflac__read_uint8(bs, 4, &lpcPrecision)) { - return DRFLAC_FALSE; - } - if (lpcPrecision == 15) { - return DRFLAC_FALSE; - } - lpcPrecision += 1; - if (!drflac__read_int8(bs, 5, &lpcShift)) { - return DRFLAC_FALSE; - } - if (lpcShift < 0) { - return DRFLAC_FALSE; - } - DRFLAC_ZERO_MEMORY(coefficients, sizeof(coefficients)); - for (i = 0; i < lpcOrder; ++i) { - if (!drflac__read_int32(bs, lpcPrecision, coefficients + i)) { - return DRFLAC_FALSE; - } - } - if (!drflac__decode_samples_with_residual(bs, bitsPerSample, blockSize, lpcOrder, lpcShift, lpcPrecision, coefficients, pDecodedSamples)) { - return DRFLAC_FALSE; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__read_next_flac_frame_header(drflac_bs* bs, drflac_uint8 streaminfoBitsPerSample, drflac_frame_header* header) -{ - const drflac_uint32 sampleRateTable[12] = {0, 88200, 176400, 192000, 8000, 16000, 22050, 24000, 32000, 44100, 48000, 96000}; - const drflac_uint8 bitsPerSampleTable[8] = {0, 8, 12, (drflac_uint8)-1, 16, 20, 24, (drflac_uint8)-1}; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(header != NULL); - for (;;) { - drflac_uint8 crc8 = 0xCE; - drflac_uint8 reserved = 0; - drflac_uint8 blockingStrategy = 0; - drflac_uint8 blockSize = 0; - drflac_uint8 sampleRate = 0; - drflac_uint8 channelAssignment = 0; - drflac_uint8 bitsPerSample = 0; - drflac_bool32 isVariableBlockSize; - if (!drflac__find_and_seek_to_next_sync_code(bs)) { - return DRFLAC_FALSE; - } - if (!drflac__read_uint8(bs, 1, &reserved)) { - return DRFLAC_FALSE; - } - if (reserved == 1) { - continue; - } - crc8 = drflac_crc8(crc8, reserved, 1); - if (!drflac__read_uint8(bs, 1, &blockingStrategy)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, blockingStrategy, 1); - if (!drflac__read_uint8(bs, 4, &blockSize)) { - return DRFLAC_FALSE; - } - if (blockSize == 0) { - continue; - } - crc8 = drflac_crc8(crc8, blockSize, 4); - if (!drflac__read_uint8(bs, 4, &sampleRate)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, sampleRate, 4); - if (!drflac__read_uint8(bs, 4, &channelAssignment)) { - return DRFLAC_FALSE; - } - if (channelAssignment > 10) { - continue; - } - crc8 = drflac_crc8(crc8, channelAssignment, 4); - if (!drflac__read_uint8(bs, 3, &bitsPerSample)) { - return DRFLAC_FALSE; - } - if (bitsPerSample == 3 || bitsPerSample == 7) { - continue; - } - crc8 = drflac_crc8(crc8, bitsPerSample, 3); - if (!drflac__read_uint8(bs, 1, &reserved)) { - return DRFLAC_FALSE; - } - if (reserved == 1) { - continue; - } - crc8 = drflac_crc8(crc8, reserved, 1); - isVariableBlockSize = blockingStrategy == 1; - if (isVariableBlockSize) { - drflac_uint64 pcmFrameNumber; - drflac_result result = drflac__read_utf8_coded_number(bs, &pcmFrameNumber, &crc8); - if (result != DRFLAC_SUCCESS) { - if (result == DRFLAC_AT_END) { - return DRFLAC_FALSE; - } else { - continue; - } - } - header->flacFrameNumber = 0; - header->pcmFrameNumber = pcmFrameNumber; - } else { - drflac_uint64 flacFrameNumber = 0; - drflac_result result = drflac__read_utf8_coded_number(bs, &flacFrameNumber, &crc8); - if (result != DRFLAC_SUCCESS) { - if (result == DRFLAC_AT_END) { - return DRFLAC_FALSE; - } else { - continue; - } - } - header->flacFrameNumber = (drflac_uint32)flacFrameNumber; - header->pcmFrameNumber = 0; - } - DRFLAC_ASSERT(blockSize > 0); - if (blockSize == 1) { - header->blockSizeInPCMFrames = 192; - } else if (blockSize <= 5) { - DRFLAC_ASSERT(blockSize >= 2); - header->blockSizeInPCMFrames = 576 * (1 << (blockSize - 2)); - } else if (blockSize == 6) { - if (!drflac__read_uint16(bs, 8, &header->blockSizeInPCMFrames)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, header->blockSizeInPCMFrames, 8); - header->blockSizeInPCMFrames += 1; - } else if (blockSize == 7) { - if (!drflac__read_uint16(bs, 16, &header->blockSizeInPCMFrames)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, header->blockSizeInPCMFrames, 16); - if (header->blockSizeInPCMFrames == 0xFFFF) { - return DRFLAC_FALSE; - } - header->blockSizeInPCMFrames += 1; - } else { - DRFLAC_ASSERT(blockSize >= 8); - header->blockSizeInPCMFrames = 256 * (1 << (blockSize - 8)); - } - if (sampleRate <= 11) { - header->sampleRate = sampleRateTable[sampleRate]; - } else if (sampleRate == 12) { - if (!drflac__read_uint32(bs, 8, &header->sampleRate)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, header->sampleRate, 8); - header->sampleRate *= 1000; - } else if (sampleRate == 13) { - if (!drflac__read_uint32(bs, 16, &header->sampleRate)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, header->sampleRate, 16); - } else if (sampleRate == 14) { - if (!drflac__read_uint32(bs, 16, &header->sampleRate)) { - return DRFLAC_FALSE; - } - crc8 = drflac_crc8(crc8, header->sampleRate, 16); - header->sampleRate *= 10; - } else { - continue; - } - header->channelAssignment = channelAssignment; - header->bitsPerSample = bitsPerSampleTable[bitsPerSample]; - if (header->bitsPerSample == 0) { - header->bitsPerSample = streaminfoBitsPerSample; - } - if (header->bitsPerSample != streaminfoBitsPerSample) { - return DRFLAC_FALSE; - } - if (!drflac__read_uint8(bs, 8, &header->crc8)) { - return DRFLAC_FALSE; - } -#ifndef DR_FLAC_NO_CRC - if (header->crc8 != crc8) { - continue; - } -#endif - return DRFLAC_TRUE; - } -} -static drflac_bool32 drflac__read_subframe_header(drflac_bs* bs, drflac_subframe* pSubframe) -{ - drflac_uint8 header; - int type; - if (!drflac__read_uint8(bs, 8, &header)) { - return DRFLAC_FALSE; - } - if ((header & 0x80) != 0) { - return DRFLAC_FALSE; - } - type = (header & 0x7E) >> 1; - if (type == 0) { - pSubframe->subframeType = DRFLAC_SUBFRAME_CONSTANT; - } else if (type == 1) { - pSubframe->subframeType = DRFLAC_SUBFRAME_VERBATIM; - } else { - if ((type & 0x20) != 0) { - pSubframe->subframeType = DRFLAC_SUBFRAME_LPC; - pSubframe->lpcOrder = (drflac_uint8)(type & 0x1F) + 1; - } else if ((type & 0x08) != 0) { - pSubframe->subframeType = DRFLAC_SUBFRAME_FIXED; - pSubframe->lpcOrder = (drflac_uint8)(type & 0x07); - if (pSubframe->lpcOrder > 4) { - pSubframe->subframeType = DRFLAC_SUBFRAME_RESERVED; - pSubframe->lpcOrder = 0; - } - } else { - pSubframe->subframeType = DRFLAC_SUBFRAME_RESERVED; - } - } - if (pSubframe->subframeType == DRFLAC_SUBFRAME_RESERVED) { - return DRFLAC_FALSE; - } - pSubframe->wastedBitsPerSample = 0; - if ((header & 0x01) == 1) { - unsigned int wastedBitsPerSample; - if (!drflac__seek_past_next_set_bit(bs, &wastedBitsPerSample)) { - return DRFLAC_FALSE; - } - pSubframe->wastedBitsPerSample = (drflac_uint8)wastedBitsPerSample + 1; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_subframe(drflac_bs* bs, drflac_frame* frame, int subframeIndex, drflac_int32* pDecodedSamplesOut) -{ - drflac_subframe* pSubframe; - drflac_uint32 subframeBitsPerSample; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(frame != NULL); - pSubframe = frame->subframes + subframeIndex; - if (!drflac__read_subframe_header(bs, pSubframe)) { - return DRFLAC_FALSE; - } - subframeBitsPerSample = frame->header.bitsPerSample; - if ((frame->header.channelAssignment == DRFLAC_CHANNEL_ASSIGNMENT_LEFT_SIDE || frame->header.channelAssignment == DRFLAC_CHANNEL_ASSIGNMENT_MID_SIDE) && subframeIndex == 1) { - subframeBitsPerSample += 1; - } else if (frame->header.channelAssignment == DRFLAC_CHANNEL_ASSIGNMENT_RIGHT_SIDE && subframeIndex == 0) { - subframeBitsPerSample += 1; - } - if (subframeBitsPerSample > 32) { - return DRFLAC_FALSE; - } - if (pSubframe->wastedBitsPerSample >= subframeBitsPerSample) { - return DRFLAC_FALSE; - } - subframeBitsPerSample -= pSubframe->wastedBitsPerSample; - pSubframe->pSamplesS32 = pDecodedSamplesOut; - switch (pSubframe->subframeType) - { - case DRFLAC_SUBFRAME_CONSTANT: - { - drflac__decode_samples__constant(bs, frame->header.blockSizeInPCMFrames, subframeBitsPerSample, pSubframe->pSamplesS32); - } break; - case DRFLAC_SUBFRAME_VERBATIM: - { - drflac__decode_samples__verbatim(bs, frame->header.blockSizeInPCMFrames, subframeBitsPerSample, pSubframe->pSamplesS32); - } break; - case DRFLAC_SUBFRAME_FIXED: - { - drflac__decode_samples__fixed(bs, frame->header.blockSizeInPCMFrames, subframeBitsPerSample, pSubframe->lpcOrder, pSubframe->pSamplesS32); - } break; - case DRFLAC_SUBFRAME_LPC: - { - drflac__decode_samples__lpc(bs, frame->header.blockSizeInPCMFrames, subframeBitsPerSample, pSubframe->lpcOrder, pSubframe->pSamplesS32); - } break; - default: return DRFLAC_FALSE; - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__seek_subframe(drflac_bs* bs, drflac_frame* frame, int subframeIndex) -{ - drflac_subframe* pSubframe; - drflac_uint32 subframeBitsPerSample; - DRFLAC_ASSERT(bs != NULL); - DRFLAC_ASSERT(frame != NULL); - pSubframe = frame->subframes + subframeIndex; - if (!drflac__read_subframe_header(bs, pSubframe)) { - return DRFLAC_FALSE; - } - subframeBitsPerSample = frame->header.bitsPerSample; - if ((frame->header.channelAssignment == DRFLAC_CHANNEL_ASSIGNMENT_LEFT_SIDE || frame->header.channelAssignment == DRFLAC_CHANNEL_ASSIGNMENT_MID_SIDE) && subframeIndex == 1) { - subframeBitsPerSample += 1; - } else if (frame->header.channelAssignment == DRFLAC_CHANNEL_ASSIGNMENT_RIGHT_SIDE && subframeIndex == 0) { - subframeBitsPerSample += 1; - } - if (pSubframe->wastedBitsPerSample >= subframeBitsPerSample) { - return DRFLAC_FALSE; - } - subframeBitsPerSample -= pSubframe->wastedBitsPerSample; - pSubframe->pSamplesS32 = NULL; - switch (pSubframe->subframeType) - { - case DRFLAC_SUBFRAME_CONSTANT: - { - if (!drflac__seek_bits(bs, subframeBitsPerSample)) { - return DRFLAC_FALSE; - } - } break; - case DRFLAC_SUBFRAME_VERBATIM: - { - unsigned int bitsToSeek = frame->header.blockSizeInPCMFrames * subframeBitsPerSample; - if (!drflac__seek_bits(bs, bitsToSeek)) { - return DRFLAC_FALSE; - } - } break; - case DRFLAC_SUBFRAME_FIXED: - { - unsigned int bitsToSeek = pSubframe->lpcOrder * subframeBitsPerSample; - if (!drflac__seek_bits(bs, bitsToSeek)) { - return DRFLAC_FALSE; - } - if (!drflac__read_and_seek_residual(bs, frame->header.blockSizeInPCMFrames, pSubframe->lpcOrder)) { - return DRFLAC_FALSE; - } - } break; - case DRFLAC_SUBFRAME_LPC: - { - drflac_uint8 lpcPrecision; - unsigned int bitsToSeek = pSubframe->lpcOrder * subframeBitsPerSample; - if (!drflac__seek_bits(bs, bitsToSeek)) { - return DRFLAC_FALSE; - } - if (!drflac__read_uint8(bs, 4, &lpcPrecision)) { - return DRFLAC_FALSE; - } - if (lpcPrecision == 15) { - return DRFLAC_FALSE; - } - lpcPrecision += 1; - bitsToSeek = (pSubframe->lpcOrder * lpcPrecision) + 5; - if (!drflac__seek_bits(bs, bitsToSeek)) { - return DRFLAC_FALSE; - } - if (!drflac__read_and_seek_residual(bs, frame->header.blockSizeInPCMFrames, pSubframe->lpcOrder)) { - return DRFLAC_FALSE; - } - } break; - default: return DRFLAC_FALSE; - } - return DRFLAC_TRUE; -} -static DRFLAC_INLINE drflac_uint8 drflac__get_channel_count_from_channel_assignment(drflac_int8 channelAssignment) -{ - drflac_uint8 lookup[] = {1, 2, 3, 4, 5, 6, 7, 8, 2, 2, 2}; - DRFLAC_ASSERT(channelAssignment <= 10); - return lookup[channelAssignment]; -} -static drflac_result drflac__decode_flac_frame(drflac* pFlac) -{ - int channelCount; - int i; - drflac_uint8 paddingSizeInBits; - drflac_uint16 desiredCRC16; -#ifndef DR_FLAC_NO_CRC - drflac_uint16 actualCRC16; -#endif - DRFLAC_ZERO_MEMORY(pFlac->currentFLACFrame.subframes, sizeof(pFlac->currentFLACFrame.subframes)); - if (pFlac->currentFLACFrame.header.blockSizeInPCMFrames > pFlac->maxBlockSizeInPCMFrames) { - return DRFLAC_ERROR; - } - channelCount = drflac__get_channel_count_from_channel_assignment(pFlac->currentFLACFrame.header.channelAssignment); - if (channelCount != (int)pFlac->channels) { - return DRFLAC_ERROR; - } - for (i = 0; i < channelCount; ++i) { - if (!drflac__decode_subframe(&pFlac->bs, &pFlac->currentFLACFrame, i, pFlac->pDecodedSamples + (pFlac->currentFLACFrame.header.blockSizeInPCMFrames * i))) { - return DRFLAC_ERROR; - } - } - paddingSizeInBits = (drflac_uint8)(DRFLAC_CACHE_L1_BITS_REMAINING(&pFlac->bs) & 7); - if (paddingSizeInBits > 0) { - drflac_uint8 padding = 0; - if (!drflac__read_uint8(&pFlac->bs, paddingSizeInBits, &padding)) { - return DRFLAC_AT_END; - } - } -#ifndef DR_FLAC_NO_CRC - actualCRC16 = drflac__flush_crc16(&pFlac->bs); -#endif - if (!drflac__read_uint16(&pFlac->bs, 16, &desiredCRC16)) { - return DRFLAC_AT_END; - } -#ifndef DR_FLAC_NO_CRC - if (actualCRC16 != desiredCRC16) { - return DRFLAC_CRC_MISMATCH; - } -#endif - pFlac->currentFLACFrame.pcmFramesRemaining = pFlac->currentFLACFrame.header.blockSizeInPCMFrames; - return DRFLAC_SUCCESS; -} -static drflac_result drflac__seek_flac_frame(drflac* pFlac) -{ - int channelCount; - int i; - drflac_uint16 desiredCRC16; -#ifndef DR_FLAC_NO_CRC - drflac_uint16 actualCRC16; -#endif - channelCount = drflac__get_channel_count_from_channel_assignment(pFlac->currentFLACFrame.header.channelAssignment); - for (i = 0; i < channelCount; ++i) { - if (!drflac__seek_subframe(&pFlac->bs, &pFlac->currentFLACFrame, i)) { - return DRFLAC_ERROR; - } - } - if (!drflac__seek_bits(&pFlac->bs, DRFLAC_CACHE_L1_BITS_REMAINING(&pFlac->bs) & 7)) { - return DRFLAC_ERROR; - } -#ifndef DR_FLAC_NO_CRC - actualCRC16 = drflac__flush_crc16(&pFlac->bs); -#endif - if (!drflac__read_uint16(&pFlac->bs, 16, &desiredCRC16)) { - return DRFLAC_AT_END; - } -#ifndef DR_FLAC_NO_CRC - if (actualCRC16 != desiredCRC16) { - return DRFLAC_CRC_MISMATCH; - } -#endif - return DRFLAC_SUCCESS; -} -static drflac_bool32 drflac__read_and_decode_next_flac_frame(drflac* pFlac) -{ - DRFLAC_ASSERT(pFlac != NULL); - for (;;) { - drflac_result result; - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - result = drflac__decode_flac_frame(pFlac); - if (result != DRFLAC_SUCCESS) { - if (result == DRFLAC_CRC_MISMATCH) { - continue; - } else { - return DRFLAC_FALSE; - } - } - return DRFLAC_TRUE; - } -} -static void drflac__get_pcm_frame_range_of_current_flac_frame(drflac* pFlac, drflac_uint64* pFirstPCMFrame, drflac_uint64* pLastPCMFrame) -{ - drflac_uint64 firstPCMFrame; - drflac_uint64 lastPCMFrame; - DRFLAC_ASSERT(pFlac != NULL); - firstPCMFrame = pFlac->currentFLACFrame.header.pcmFrameNumber; - if (firstPCMFrame == 0) { - firstPCMFrame = ((drflac_uint64)pFlac->currentFLACFrame.header.flacFrameNumber) * pFlac->maxBlockSizeInPCMFrames; - } - lastPCMFrame = firstPCMFrame + pFlac->currentFLACFrame.header.blockSizeInPCMFrames; - if (lastPCMFrame > 0) { - lastPCMFrame -= 1; - } - if (pFirstPCMFrame) { - *pFirstPCMFrame = firstPCMFrame; - } - if (pLastPCMFrame) { - *pLastPCMFrame = lastPCMFrame; - } -} -static drflac_bool32 drflac__seek_to_first_frame(drflac* pFlac) -{ - drflac_bool32 result; - DRFLAC_ASSERT(pFlac != NULL); - result = drflac__seek_to_byte(&pFlac->bs, pFlac->firstFLACFramePosInBytes); - DRFLAC_ZERO_MEMORY(&pFlac->currentFLACFrame, sizeof(pFlac->currentFLACFrame)); - pFlac->currentPCMFrame = 0; - return result; -} -static DRFLAC_INLINE drflac_result drflac__seek_to_next_flac_frame(drflac* pFlac) -{ - DRFLAC_ASSERT(pFlac != NULL); - return drflac__seek_flac_frame(pFlac); -} -static drflac_uint64 drflac__seek_forward_by_pcm_frames(drflac* pFlac, drflac_uint64 pcmFramesToSeek) -{ - drflac_uint64 pcmFramesRead = 0; - while (pcmFramesToSeek > 0) { - if (pFlac->currentFLACFrame.pcmFramesRemaining == 0) { - if (!drflac__read_and_decode_next_flac_frame(pFlac)) { - break; - } - } else { - if (pFlac->currentFLACFrame.pcmFramesRemaining > pcmFramesToSeek) { - pcmFramesRead += pcmFramesToSeek; - pFlac->currentFLACFrame.pcmFramesRemaining -= (drflac_uint32)pcmFramesToSeek; - pcmFramesToSeek = 0; - } else { - pcmFramesRead += pFlac->currentFLACFrame.pcmFramesRemaining; - pcmFramesToSeek -= pFlac->currentFLACFrame.pcmFramesRemaining; - pFlac->currentFLACFrame.pcmFramesRemaining = 0; - } - } - } - pFlac->currentPCMFrame += pcmFramesRead; - return pcmFramesRead; -} -static drflac_bool32 drflac__seek_to_pcm_frame__brute_force(drflac* pFlac, drflac_uint64 pcmFrameIndex) -{ - drflac_bool32 isMidFrame = DRFLAC_FALSE; - drflac_uint64 runningPCMFrameCount; - DRFLAC_ASSERT(pFlac != NULL); - if (pcmFrameIndex >= pFlac->currentPCMFrame) { - runningPCMFrameCount = pFlac->currentPCMFrame; - if (pFlac->currentPCMFrame == 0 && pFlac->currentFLACFrame.pcmFramesRemaining == 0) { - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - } else { - isMidFrame = DRFLAC_TRUE; - } - } else { - runningPCMFrameCount = 0; - if (!drflac__seek_to_first_frame(pFlac)) { - return DRFLAC_FALSE; - } - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - } - for (;;) { - drflac_uint64 pcmFrameCountInThisFLACFrame; - drflac_uint64 firstPCMFrameInFLACFrame = 0; - drflac_uint64 lastPCMFrameInFLACFrame = 0; - drflac__get_pcm_frame_range_of_current_flac_frame(pFlac, &firstPCMFrameInFLACFrame, &lastPCMFrameInFLACFrame); - pcmFrameCountInThisFLACFrame = (lastPCMFrameInFLACFrame - firstPCMFrameInFLACFrame) + 1; - if (pcmFrameIndex < (runningPCMFrameCount + pcmFrameCountInThisFLACFrame)) { - drflac_uint64 pcmFramesToDecode = pcmFrameIndex - runningPCMFrameCount; - if (!isMidFrame) { - drflac_result result = drflac__decode_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - return drflac__seek_forward_by_pcm_frames(pFlac, pcmFramesToDecode) == pcmFramesToDecode; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - goto next_iteration; - } else { - return DRFLAC_FALSE; - } - } - } else { - return drflac__seek_forward_by_pcm_frames(pFlac, pcmFramesToDecode) == pcmFramesToDecode; - } - } else { - if (!isMidFrame) { - drflac_result result = drflac__seek_to_next_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - runningPCMFrameCount += pcmFrameCountInThisFLACFrame; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - goto next_iteration; - } else { - return DRFLAC_FALSE; - } - } - } else { - runningPCMFrameCount += pFlac->currentFLACFrame.pcmFramesRemaining; - pFlac->currentFLACFrame.pcmFramesRemaining = 0; - isMidFrame = DRFLAC_FALSE; - } - if (pcmFrameIndex == pFlac->totalPCMFrameCount && runningPCMFrameCount == pFlac->totalPCMFrameCount) { - return DRFLAC_TRUE; - } - } - next_iteration: - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - } -} -#if !defined(DR_FLAC_NO_CRC) -#define DRFLAC_BINARY_SEARCH_APPROX_COMPRESSION_RATIO 0.6f -static drflac_bool32 drflac__seek_to_approximate_flac_frame_to_byte(drflac* pFlac, drflac_uint64 targetByte, drflac_uint64 rangeLo, drflac_uint64 rangeHi, drflac_uint64* pLastSuccessfulSeekOffset) -{ - DRFLAC_ASSERT(pFlac != NULL); - DRFLAC_ASSERT(pLastSuccessfulSeekOffset != NULL); - DRFLAC_ASSERT(targetByte >= rangeLo); - DRFLAC_ASSERT(targetByte <= rangeHi); - *pLastSuccessfulSeekOffset = pFlac->firstFLACFramePosInBytes; - for (;;) { - drflac_uint64 lastTargetByte = targetByte; - if (!drflac__seek_to_byte(&pFlac->bs, targetByte)) { - if (targetByte == 0) { - drflac__seek_to_first_frame(pFlac); - return DRFLAC_FALSE; - } - targetByte = rangeLo + ((rangeHi - rangeLo)/2); - rangeHi = targetByte; - } else { - DRFLAC_ZERO_MEMORY(&pFlac->currentFLACFrame, sizeof(pFlac->currentFLACFrame)); -#if 1 - if (!drflac__read_and_decode_next_flac_frame(pFlac)) { - targetByte = rangeLo + ((rangeHi - rangeLo)/2); - rangeHi = targetByte; - } else { - break; - } -#else - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - targetByte = rangeLo + ((rangeHi - rangeLo)/2); - rangeHi = targetByte; - } else { - break; - } -#endif - } - if(targetByte == lastTargetByte) { - return DRFLAC_FALSE; - } - } - drflac__get_pcm_frame_range_of_current_flac_frame(pFlac, &pFlac->currentPCMFrame, NULL); - DRFLAC_ASSERT(targetByte <= rangeHi); - *pLastSuccessfulSeekOffset = targetByte; - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__decode_flac_frame_and_seek_forward_by_pcm_frames(drflac* pFlac, drflac_uint64 offset) -{ -#if 0 - if (drflac__decode_flac_frame(pFlac) != DRFLAC_SUCCESS) { - if (drflac__read_and_decode_next_flac_frame(pFlac) == DRFLAC_FALSE) { - return DRFLAC_FALSE; - } - } -#endif - return drflac__seek_forward_by_pcm_frames(pFlac, offset) == offset; -} -static drflac_bool32 drflac__seek_to_pcm_frame__binary_search_internal(drflac* pFlac, drflac_uint64 pcmFrameIndex, drflac_uint64 byteRangeLo, drflac_uint64 byteRangeHi) -{ - drflac_uint64 targetByte; - drflac_uint64 pcmRangeLo = pFlac->totalPCMFrameCount; - drflac_uint64 pcmRangeHi = 0; - drflac_uint64 lastSuccessfulSeekOffset = (drflac_uint64)-1; - drflac_uint64 closestSeekOffsetBeforeTargetPCMFrame = byteRangeLo; - drflac_uint32 seekForwardThreshold = (pFlac->maxBlockSizeInPCMFrames != 0) ? pFlac->maxBlockSizeInPCMFrames*2 : 4096; - targetByte = byteRangeLo + (drflac_uint64)(((drflac_int64)((pcmFrameIndex - pFlac->currentPCMFrame) * pFlac->channels * pFlac->bitsPerSample)/8.0f) * DRFLAC_BINARY_SEARCH_APPROX_COMPRESSION_RATIO); - if (targetByte > byteRangeHi) { - targetByte = byteRangeHi; - } - for (;;) { - if (drflac__seek_to_approximate_flac_frame_to_byte(pFlac, targetByte, byteRangeLo, byteRangeHi, &lastSuccessfulSeekOffset)) { - drflac_uint64 newPCMRangeLo; - drflac_uint64 newPCMRangeHi; - drflac__get_pcm_frame_range_of_current_flac_frame(pFlac, &newPCMRangeLo, &newPCMRangeHi); - if (pcmRangeLo == newPCMRangeLo) { - if (!drflac__seek_to_approximate_flac_frame_to_byte(pFlac, closestSeekOffsetBeforeTargetPCMFrame, closestSeekOffsetBeforeTargetPCMFrame, byteRangeHi, &lastSuccessfulSeekOffset)) { - break; - } - if (drflac__decode_flac_frame_and_seek_forward_by_pcm_frames(pFlac, pcmFrameIndex - pFlac->currentPCMFrame)) { - return DRFLAC_TRUE; - } else { - break; - } - } - pcmRangeLo = newPCMRangeLo; - pcmRangeHi = newPCMRangeHi; - if (pcmRangeLo <= pcmFrameIndex && pcmRangeHi >= pcmFrameIndex) { - if (drflac__decode_flac_frame_and_seek_forward_by_pcm_frames(pFlac, pcmFrameIndex - pFlac->currentPCMFrame) ) { - return DRFLAC_TRUE; - } else { - break; - } - } else { - const float approxCompressionRatio = (drflac_int64)(lastSuccessfulSeekOffset - pFlac->firstFLACFramePosInBytes) / ((drflac_int64)(pcmRangeLo * pFlac->channels * pFlac->bitsPerSample)/8.0f); - if (pcmRangeLo > pcmFrameIndex) { - byteRangeHi = lastSuccessfulSeekOffset; - if (byteRangeLo > byteRangeHi) { - byteRangeLo = byteRangeHi; - } - targetByte = byteRangeLo + ((byteRangeHi - byteRangeLo) / 2); - if (targetByte < byteRangeLo) { - targetByte = byteRangeLo; - } - } else { - if ((pcmFrameIndex - pcmRangeLo) < seekForwardThreshold) { - if (drflac__decode_flac_frame_and_seek_forward_by_pcm_frames(pFlac, pcmFrameIndex - pFlac->currentPCMFrame)) { - return DRFLAC_TRUE; - } else { - break; - } - } else { - byteRangeLo = lastSuccessfulSeekOffset; - if (byteRangeHi < byteRangeLo) { - byteRangeHi = byteRangeLo; - } - targetByte = lastSuccessfulSeekOffset + (drflac_uint64)(((drflac_int64)((pcmFrameIndex-pcmRangeLo) * pFlac->channels * pFlac->bitsPerSample)/8.0f) * approxCompressionRatio); - if (targetByte > byteRangeHi) { - targetByte = byteRangeHi; - } - if (closestSeekOffsetBeforeTargetPCMFrame < lastSuccessfulSeekOffset) { - closestSeekOffsetBeforeTargetPCMFrame = lastSuccessfulSeekOffset; - } - } - } - } - } else { - break; - } - } - drflac__seek_to_first_frame(pFlac); - return DRFLAC_FALSE; -} -static drflac_bool32 drflac__seek_to_pcm_frame__binary_search(drflac* pFlac, drflac_uint64 pcmFrameIndex) -{ - drflac_uint64 byteRangeLo; - drflac_uint64 byteRangeHi; - drflac_uint32 seekForwardThreshold = (pFlac->maxBlockSizeInPCMFrames != 0) ? pFlac->maxBlockSizeInPCMFrames*2 : 4096; - if (drflac__seek_to_first_frame(pFlac) == DRFLAC_FALSE) { - return DRFLAC_FALSE; - } - if (pcmFrameIndex < seekForwardThreshold) { - return drflac__seek_forward_by_pcm_frames(pFlac, pcmFrameIndex) == pcmFrameIndex; - } - byteRangeLo = pFlac->firstFLACFramePosInBytes; - byteRangeHi = pFlac->firstFLACFramePosInBytes + (drflac_uint64)((drflac_int64)(pFlac->totalPCMFrameCount * pFlac->channels * pFlac->bitsPerSample)/8.0f); - return drflac__seek_to_pcm_frame__binary_search_internal(pFlac, pcmFrameIndex, byteRangeLo, byteRangeHi); -} -#endif -static drflac_bool32 drflac__seek_to_pcm_frame__seek_table(drflac* pFlac, drflac_uint64 pcmFrameIndex) -{ - drflac_uint32 iClosestSeekpoint = 0; - drflac_bool32 isMidFrame = DRFLAC_FALSE; - drflac_uint64 runningPCMFrameCount; - drflac_uint32 iSeekpoint; - DRFLAC_ASSERT(pFlac != NULL); - if (pFlac->pSeekpoints == NULL || pFlac->seekpointCount == 0) { - return DRFLAC_FALSE; - } - if (pFlac->pSeekpoints[0].firstPCMFrame > pcmFrameIndex) { - return DRFLAC_FALSE; - } - for (iSeekpoint = 0; iSeekpoint < pFlac->seekpointCount; ++iSeekpoint) { - if (pFlac->pSeekpoints[iSeekpoint].firstPCMFrame >= pcmFrameIndex) { - break; - } - iClosestSeekpoint = iSeekpoint; - } - if (pFlac->pSeekpoints[iClosestSeekpoint].pcmFrameCount == 0 || pFlac->pSeekpoints[iClosestSeekpoint].pcmFrameCount > pFlac->maxBlockSizeInPCMFrames) { - return DRFLAC_FALSE; - } - if (pFlac->pSeekpoints[iClosestSeekpoint].firstPCMFrame > pFlac->totalPCMFrameCount && pFlac->totalPCMFrameCount > 0) { - return DRFLAC_FALSE; - } -#if !defined(DR_FLAC_NO_CRC) - if (pFlac->totalPCMFrameCount > 0) { - drflac_uint64 byteRangeLo; - drflac_uint64 byteRangeHi; - byteRangeHi = pFlac->firstFLACFramePosInBytes + (drflac_uint64)((drflac_int64)(pFlac->totalPCMFrameCount * pFlac->channels * pFlac->bitsPerSample)/8.0f); - byteRangeLo = pFlac->firstFLACFramePosInBytes + pFlac->pSeekpoints[iClosestSeekpoint].flacFrameOffset; - if (iClosestSeekpoint < pFlac->seekpointCount-1) { - drflac_uint32 iNextSeekpoint = iClosestSeekpoint + 1; - if (pFlac->pSeekpoints[iClosestSeekpoint].flacFrameOffset >= pFlac->pSeekpoints[iNextSeekpoint].flacFrameOffset || pFlac->pSeekpoints[iNextSeekpoint].pcmFrameCount == 0) { - return DRFLAC_FALSE; - } - if (pFlac->pSeekpoints[iNextSeekpoint].firstPCMFrame != (((drflac_uint64)0xFFFFFFFF << 32) | 0xFFFFFFFF)) { - byteRangeHi = pFlac->firstFLACFramePosInBytes + pFlac->pSeekpoints[iNextSeekpoint].flacFrameOffset - 1; - } - } - if (drflac__seek_to_byte(&pFlac->bs, pFlac->firstFLACFramePosInBytes + pFlac->pSeekpoints[iClosestSeekpoint].flacFrameOffset)) { - if (drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - drflac__get_pcm_frame_range_of_current_flac_frame(pFlac, &pFlac->currentPCMFrame, NULL); - if (drflac__seek_to_pcm_frame__binary_search_internal(pFlac, pcmFrameIndex, byteRangeLo, byteRangeHi)) { - return DRFLAC_TRUE; - } - } - } - } -#endif - if (pcmFrameIndex >= pFlac->currentPCMFrame && pFlac->pSeekpoints[iClosestSeekpoint].firstPCMFrame <= pFlac->currentPCMFrame) { - runningPCMFrameCount = pFlac->currentPCMFrame; - if (pFlac->currentPCMFrame == 0 && pFlac->currentFLACFrame.pcmFramesRemaining == 0) { - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - } else { - isMidFrame = DRFLAC_TRUE; - } - } else { - runningPCMFrameCount = pFlac->pSeekpoints[iClosestSeekpoint].firstPCMFrame; - if (!drflac__seek_to_byte(&pFlac->bs, pFlac->firstFLACFramePosInBytes + pFlac->pSeekpoints[iClosestSeekpoint].flacFrameOffset)) { - return DRFLAC_FALSE; - } - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - } - for (;;) { - drflac_uint64 pcmFrameCountInThisFLACFrame; - drflac_uint64 firstPCMFrameInFLACFrame = 0; - drflac_uint64 lastPCMFrameInFLACFrame = 0; - drflac__get_pcm_frame_range_of_current_flac_frame(pFlac, &firstPCMFrameInFLACFrame, &lastPCMFrameInFLACFrame); - pcmFrameCountInThisFLACFrame = (lastPCMFrameInFLACFrame - firstPCMFrameInFLACFrame) + 1; - if (pcmFrameIndex < (runningPCMFrameCount + pcmFrameCountInThisFLACFrame)) { - drflac_uint64 pcmFramesToDecode = pcmFrameIndex - runningPCMFrameCount; - if (!isMidFrame) { - drflac_result result = drflac__decode_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - return drflac__seek_forward_by_pcm_frames(pFlac, pcmFramesToDecode) == pcmFramesToDecode; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - goto next_iteration; - } else { - return DRFLAC_FALSE; - } - } - } else { - return drflac__seek_forward_by_pcm_frames(pFlac, pcmFramesToDecode) == pcmFramesToDecode; - } - } else { - if (!isMidFrame) { - drflac_result result = drflac__seek_to_next_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - runningPCMFrameCount += pcmFrameCountInThisFLACFrame; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - goto next_iteration; - } else { - return DRFLAC_FALSE; - } - } - } else { - runningPCMFrameCount += pFlac->currentFLACFrame.pcmFramesRemaining; - pFlac->currentFLACFrame.pcmFramesRemaining = 0; - isMidFrame = DRFLAC_FALSE; - } - if (pcmFrameIndex == pFlac->totalPCMFrameCount && runningPCMFrameCount == pFlac->totalPCMFrameCount) { - return DRFLAC_TRUE; - } - } - next_iteration: - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - } -} -#ifndef DR_FLAC_NO_OGG -typedef struct -{ - drflac_uint8 capturePattern[4]; - drflac_uint8 structureVersion; - drflac_uint8 headerType; - drflac_uint64 granulePosition; - drflac_uint32 serialNumber; - drflac_uint32 sequenceNumber; - drflac_uint32 checksum; - drflac_uint8 segmentCount; - drflac_uint8 segmentTable[255]; -} drflac_ogg_page_header; -#endif -typedef struct -{ - drflac_read_proc onRead; - drflac_seek_proc onSeek; - drflac_meta_proc onMeta; - drflac_container container; - void* pUserData; - void* pUserDataMD; - drflac_uint32 sampleRate; - drflac_uint8 channels; - drflac_uint8 bitsPerSample; - drflac_uint64 totalPCMFrameCount; - drflac_uint16 maxBlockSizeInPCMFrames; - drflac_uint64 runningFilePos; - drflac_bool32 hasStreamInfoBlock; - drflac_bool32 hasMetadataBlocks; - drflac_bs bs; - drflac_frame_header firstFrameHeader; -#ifndef DR_FLAC_NO_OGG - drflac_uint32 oggSerial; - drflac_uint64 oggFirstBytePos; - drflac_ogg_page_header oggBosHeader; -#endif -} drflac_init_info; -static DRFLAC_INLINE void drflac__decode_block_header(drflac_uint32 blockHeader, drflac_uint8* isLastBlock, drflac_uint8* blockType, drflac_uint32* blockSize) -{ - blockHeader = drflac__be2host_32(blockHeader); - *isLastBlock = (drflac_uint8)((blockHeader & 0x80000000UL) >> 31); - *blockType = (drflac_uint8)((blockHeader & 0x7F000000UL) >> 24); - *blockSize = (blockHeader & 0x00FFFFFFUL); -} -static DRFLAC_INLINE drflac_bool32 drflac__read_and_decode_block_header(drflac_read_proc onRead, void* pUserData, drflac_uint8* isLastBlock, drflac_uint8* blockType, drflac_uint32* blockSize) -{ - drflac_uint32 blockHeader; - *blockSize = 0; - if (onRead(pUserData, &blockHeader, 4) != 4) { - return DRFLAC_FALSE; - } - drflac__decode_block_header(blockHeader, isLastBlock, blockType, blockSize); - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__read_streaminfo(drflac_read_proc onRead, void* pUserData, drflac_streaminfo* pStreamInfo) -{ - drflac_uint32 blockSizes; - drflac_uint64 frameSizes = 0; - drflac_uint64 importantProps; - drflac_uint8 md5[16]; - if (onRead(pUserData, &blockSizes, 4) != 4) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, &frameSizes, 6) != 6) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, &importantProps, 8) != 8) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, md5, sizeof(md5)) != sizeof(md5)) { - return DRFLAC_FALSE; - } - blockSizes = drflac__be2host_32(blockSizes); - frameSizes = drflac__be2host_64(frameSizes); - importantProps = drflac__be2host_64(importantProps); - pStreamInfo->minBlockSizeInPCMFrames = (drflac_uint16)((blockSizes & 0xFFFF0000) >> 16); - pStreamInfo->maxBlockSizeInPCMFrames = (drflac_uint16) (blockSizes & 0x0000FFFF); - pStreamInfo->minFrameSizeInPCMFrames = (drflac_uint32)((frameSizes & (((drflac_uint64)0x00FFFFFF << 16) << 24)) >> 40); - pStreamInfo->maxFrameSizeInPCMFrames = (drflac_uint32)((frameSizes & (((drflac_uint64)0x00FFFFFF << 16) << 0)) >> 16); - pStreamInfo->sampleRate = (drflac_uint32)((importantProps & (((drflac_uint64)0x000FFFFF << 16) << 28)) >> 44); - pStreamInfo->channels = (drflac_uint8 )((importantProps & (((drflac_uint64)0x0000000E << 16) << 24)) >> 41) + 1; - pStreamInfo->bitsPerSample = (drflac_uint8 )((importantProps & (((drflac_uint64)0x0000001F << 16) << 20)) >> 36) + 1; - pStreamInfo->totalPCMFrameCount = ((importantProps & ((((drflac_uint64)0x0000000F << 16) << 16) | 0xFFFFFFFF))); - DRFLAC_COPY_MEMORY(pStreamInfo->md5, md5, sizeof(md5)); - return DRFLAC_TRUE; -} -static void* drflac__malloc_default(size_t sz, void* pUserData) -{ - (void)pUserData; - return DRFLAC_MALLOC(sz); -} -static void* drflac__realloc_default(void* p, size_t sz, void* pUserData) -{ - (void)pUserData; - return DRFLAC_REALLOC(p, sz); -} -static void drflac__free_default(void* p, void* pUserData) -{ - (void)pUserData; - DRFLAC_FREE(p); -} -static void* drflac__malloc_from_callbacks(size_t sz, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks == NULL) { - return NULL; - } - if (pAllocationCallbacks->onMalloc != NULL) { - return pAllocationCallbacks->onMalloc(sz, pAllocationCallbacks->pUserData); - } - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(NULL, sz, pAllocationCallbacks->pUserData); - } - return NULL; -} -static void* drflac__realloc_from_callbacks(void* p, size_t szNew, size_t szOld, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks == NULL) { - return NULL; - } - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(p, szNew, pAllocationCallbacks->pUserData); - } - if (pAllocationCallbacks->onMalloc != NULL && pAllocationCallbacks->onFree != NULL) { - void* p2; - p2 = pAllocationCallbacks->onMalloc(szNew, pAllocationCallbacks->pUserData); - if (p2 == NULL) { - return NULL; - } - if (p != NULL) { - DRFLAC_COPY_MEMORY(p2, p, szOld); - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } - return p2; - } - return NULL; -} -static void drflac__free_from_callbacks(void* p, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - if (p == NULL || pAllocationCallbacks == NULL) { - return; - } - if (pAllocationCallbacks->onFree != NULL) { - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } -} -static drflac_bool32 drflac__read_and_decode_metadata(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, void* pUserData, void* pUserDataMD, drflac_uint64* pFirstFramePos, drflac_uint64* pSeektablePos, drflac_uint32* pSeekpointCount, drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac_uint64 runningFilePos = 42; - drflac_uint64 seektablePos = 0; - drflac_uint32 seektableSize = 0; - for (;;) { - drflac_metadata metadata; - drflac_uint8 isLastBlock = 0; - drflac_uint8 blockType; - drflac_uint32 blockSize; - if (drflac__read_and_decode_block_header(onRead, pUserData, &isLastBlock, &blockType, &blockSize) == DRFLAC_FALSE) { - return DRFLAC_FALSE; - } - runningFilePos += 4; - metadata.type = blockType; - metadata.pRawData = NULL; - metadata.rawDataSize = 0; - switch (blockType) - { - case DRFLAC_METADATA_BLOCK_TYPE_APPLICATION: - { - if (blockSize < 4) { - return DRFLAC_FALSE; - } - if (onMeta) { - void* pRawData = drflac__malloc_from_callbacks(blockSize, pAllocationCallbacks); - if (pRawData == NULL) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, pRawData, blockSize) != blockSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.pRawData = pRawData; - metadata.rawDataSize = blockSize; - metadata.data.application.id = drflac__be2host_32(*(drflac_uint32*)pRawData); - metadata.data.application.pData = (const void*)((drflac_uint8*)pRawData + sizeof(drflac_uint32)); - metadata.data.application.dataSize = blockSize - sizeof(drflac_uint32); - onMeta(pUserDataMD, &metadata); - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - } - } break; - case DRFLAC_METADATA_BLOCK_TYPE_SEEKTABLE: - { - seektablePos = runningFilePos; - seektableSize = blockSize; - if (onMeta) { - drflac_uint32 seekpointCount; - drflac_uint32 iSeekpoint; - void* pRawData; - seekpointCount = blockSize/DRFLAC_SEEKPOINT_SIZE_IN_BYTES; - pRawData = drflac__malloc_from_callbacks(seekpointCount * sizeof(drflac_seekpoint), pAllocationCallbacks); - if (pRawData == NULL) { - return DRFLAC_FALSE; - } - for (iSeekpoint = 0; iSeekpoint < seekpointCount; ++iSeekpoint) { - drflac_seekpoint* pSeekpoint = (drflac_seekpoint*)pRawData + iSeekpoint; - if (onRead(pUserData, pSeekpoint, DRFLAC_SEEKPOINT_SIZE_IN_BYTES) != DRFLAC_SEEKPOINT_SIZE_IN_BYTES) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - pSeekpoint->firstPCMFrame = drflac__be2host_64(pSeekpoint->firstPCMFrame); - pSeekpoint->flacFrameOffset = drflac__be2host_64(pSeekpoint->flacFrameOffset); - pSeekpoint->pcmFrameCount = drflac__be2host_16(pSeekpoint->pcmFrameCount); - } - metadata.pRawData = pRawData; - metadata.rawDataSize = blockSize; - metadata.data.seektable.seekpointCount = seekpointCount; - metadata.data.seektable.pSeekpoints = (const drflac_seekpoint*)pRawData; - onMeta(pUserDataMD, &metadata); - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - } - } break; - case DRFLAC_METADATA_BLOCK_TYPE_VORBIS_COMMENT: - { - if (blockSize < 8) { - return DRFLAC_FALSE; - } - if (onMeta) { - void* pRawData; - const char* pRunningData; - const char* pRunningDataEnd; - drflac_uint32 i; - pRawData = drflac__malloc_from_callbacks(blockSize, pAllocationCallbacks); - if (pRawData == NULL) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, pRawData, blockSize) != blockSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.pRawData = pRawData; - metadata.rawDataSize = blockSize; - pRunningData = (const char*)pRawData; - pRunningDataEnd = (const char*)pRawData + blockSize; - metadata.data.vorbis_comment.vendorLength = drflac__le2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - if ((pRunningDataEnd - pRunningData) - 4 < (drflac_int64)metadata.data.vorbis_comment.vendorLength) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.data.vorbis_comment.vendor = pRunningData; pRunningData += metadata.data.vorbis_comment.vendorLength; - metadata.data.vorbis_comment.commentCount = drflac__le2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - if ((pRunningDataEnd - pRunningData) / sizeof(drflac_uint32) < metadata.data.vorbis_comment.commentCount) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.data.vorbis_comment.pComments = pRunningData; - for (i = 0; i < metadata.data.vorbis_comment.commentCount; ++i) { - drflac_uint32 commentLength; - if (pRunningDataEnd - pRunningData < 4) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - commentLength = drflac__le2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - if (pRunningDataEnd - pRunningData < (drflac_int64)commentLength) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - pRunningData += commentLength; - } - onMeta(pUserDataMD, &metadata); - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - } - } break; - case DRFLAC_METADATA_BLOCK_TYPE_CUESHEET: - { - if (blockSize < 396) { - return DRFLAC_FALSE; - } - if (onMeta) { - void* pRawData; - const char* pRunningData; - const char* pRunningDataEnd; - size_t bufferSize; - drflac_uint8 iTrack; - drflac_uint8 iIndex; - void* pTrackData; - pRawData = drflac__malloc_from_callbacks(blockSize, pAllocationCallbacks); - if (pRawData == NULL) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, pRawData, blockSize) != blockSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.pRawData = pRawData; - metadata.rawDataSize = blockSize; - pRunningData = (const char*)pRawData; - pRunningDataEnd = (const char*)pRawData + blockSize; - DRFLAC_COPY_MEMORY(metadata.data.cuesheet.catalog, pRunningData, 128); pRunningData += 128; - metadata.data.cuesheet.leadInSampleCount = drflac__be2host_64(*(const drflac_uint64*)pRunningData); pRunningData += 8; - metadata.data.cuesheet.isCD = (pRunningData[0] & 0x80) != 0; pRunningData += 259; - metadata.data.cuesheet.trackCount = pRunningData[0]; pRunningData += 1; - metadata.data.cuesheet.pTrackData = NULL; - { - const char* pRunningDataSaved = pRunningData; - bufferSize = metadata.data.cuesheet.trackCount * DRFLAC_CUESHEET_TRACK_SIZE_IN_BYTES; - for (iTrack = 0; iTrack < metadata.data.cuesheet.trackCount; ++iTrack) { - drflac_uint8 indexCount; - drflac_uint32 indexPointSize; - if (pRunningDataEnd - pRunningData < DRFLAC_CUESHEET_TRACK_SIZE_IN_BYTES) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - pRunningData += 35; - indexCount = pRunningData[0]; - pRunningData += 1; - bufferSize += indexCount * sizeof(drflac_cuesheet_track_index); - indexPointSize = indexCount * DRFLAC_CUESHEET_TRACK_INDEX_SIZE_IN_BYTES; - if (pRunningDataEnd - pRunningData < (drflac_int64)indexPointSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - pRunningData += indexPointSize; - } - pRunningData = pRunningDataSaved; - } - { - char* pRunningTrackData; - pTrackData = drflac__malloc_from_callbacks(bufferSize, pAllocationCallbacks); - if (pTrackData == NULL) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - pRunningTrackData = (char*)pTrackData; - for (iTrack = 0; iTrack < metadata.data.cuesheet.trackCount; ++iTrack) { - drflac_uint8 indexCount; - DRFLAC_COPY_MEMORY(pRunningTrackData, pRunningData, DRFLAC_CUESHEET_TRACK_SIZE_IN_BYTES); - pRunningData += DRFLAC_CUESHEET_TRACK_SIZE_IN_BYTES-1; - pRunningTrackData += DRFLAC_CUESHEET_TRACK_SIZE_IN_BYTES-1; - indexCount = pRunningData[0]; - pRunningData += 1; - pRunningTrackData += 1; - for (iIndex = 0; iIndex < indexCount; ++iIndex) { - drflac_cuesheet_track_index* pTrackIndex = (drflac_cuesheet_track_index*)pRunningTrackData; - DRFLAC_COPY_MEMORY(pRunningTrackData, pRunningData, DRFLAC_CUESHEET_TRACK_INDEX_SIZE_IN_BYTES); - pRunningData += DRFLAC_CUESHEET_TRACK_INDEX_SIZE_IN_BYTES; - pRunningTrackData += sizeof(drflac_cuesheet_track_index); - pTrackIndex->offset = drflac__be2host_64(pTrackIndex->offset); - } - } - metadata.data.cuesheet.pTrackData = pTrackData; - } - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - pRawData = NULL; - onMeta(pUserDataMD, &metadata); - drflac__free_from_callbacks(pTrackData, pAllocationCallbacks); - pTrackData = NULL; - } - } break; - case DRFLAC_METADATA_BLOCK_TYPE_PICTURE: - { - if (blockSize < 32) { - return DRFLAC_FALSE; - } - if (onMeta) { - void* pRawData; - const char* pRunningData; - const char* pRunningDataEnd; - pRawData = drflac__malloc_from_callbacks(blockSize, pAllocationCallbacks); - if (pRawData == NULL) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, pRawData, blockSize) != blockSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.pRawData = pRawData; - metadata.rawDataSize = blockSize; - pRunningData = (const char*)pRawData; - pRunningDataEnd = (const char*)pRawData + blockSize; - metadata.data.picture.type = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - metadata.data.picture.mimeLength = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - if ((pRunningDataEnd - pRunningData) - 24 < (drflac_int64)metadata.data.picture.mimeLength) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.data.picture.mime = pRunningData; pRunningData += metadata.data.picture.mimeLength; - metadata.data.picture.descriptionLength = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - if ((pRunningDataEnd - pRunningData) - 20 < (drflac_int64)metadata.data.picture.descriptionLength) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.data.picture.description = pRunningData; pRunningData += metadata.data.picture.descriptionLength; - metadata.data.picture.width = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - metadata.data.picture.height = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - metadata.data.picture.colorDepth = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - metadata.data.picture.indexColorCount = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - metadata.data.picture.pictureDataSize = drflac__be2host_32_ptr_unaligned(pRunningData); pRunningData += 4; - metadata.data.picture.pPictureData = (const drflac_uint8*)pRunningData; - if (pRunningDataEnd - pRunningData < (drflac_int64)metadata.data.picture.pictureDataSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - onMeta(pUserDataMD, &metadata); - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - } - } break; - case DRFLAC_METADATA_BLOCK_TYPE_PADDING: - { - if (onMeta) { - metadata.data.padding.unused = 0; - if (!onSeek(pUserData, blockSize, drflac_seek_origin_current)) { - isLastBlock = DRFLAC_TRUE; - } else { - onMeta(pUserDataMD, &metadata); - } - } - } break; - case DRFLAC_METADATA_BLOCK_TYPE_INVALID: - { - if (onMeta) { - if (!onSeek(pUserData, blockSize, drflac_seek_origin_current)) { - isLastBlock = DRFLAC_TRUE; - } - } - } break; - default: - { - if (onMeta) { - void* pRawData = drflac__malloc_from_callbacks(blockSize, pAllocationCallbacks); - if (pRawData == NULL) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, pRawData, blockSize) != blockSize) { - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - return DRFLAC_FALSE; - } - metadata.pRawData = pRawData; - metadata.rawDataSize = blockSize; - onMeta(pUserDataMD, &metadata); - drflac__free_from_callbacks(pRawData, pAllocationCallbacks); - } - } break; - } - if (onMeta == NULL && blockSize > 0) { - if (!onSeek(pUserData, blockSize, drflac_seek_origin_current)) { - isLastBlock = DRFLAC_TRUE; - } - } - runningFilePos += blockSize; - if (isLastBlock) { - break; - } - } - *pSeektablePos = seektablePos; - *pSeekpointCount = seektableSize / DRFLAC_SEEKPOINT_SIZE_IN_BYTES; - *pFirstFramePos = runningFilePos; - return DRFLAC_TRUE; -} -static drflac_bool32 drflac__init_private__native(drflac_init_info* pInit, drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, void* pUserData, void* pUserDataMD, drflac_bool32 relaxed) -{ - drflac_uint8 isLastBlock; - drflac_uint8 blockType; - drflac_uint32 blockSize; - (void)onSeek; - pInit->container = drflac_container_native; - if (!drflac__read_and_decode_block_header(onRead, pUserData, &isLastBlock, &blockType, &blockSize)) { - return DRFLAC_FALSE; - } - if (blockType != DRFLAC_METADATA_BLOCK_TYPE_STREAMINFO || blockSize != 34) { - if (!relaxed) { - return DRFLAC_FALSE; - } else { - pInit->hasStreamInfoBlock = DRFLAC_FALSE; - pInit->hasMetadataBlocks = DRFLAC_FALSE; - if (!drflac__read_next_flac_frame_header(&pInit->bs, 0, &pInit->firstFrameHeader)) { - return DRFLAC_FALSE; - } - if (pInit->firstFrameHeader.bitsPerSample == 0) { - return DRFLAC_FALSE; - } - pInit->sampleRate = pInit->firstFrameHeader.sampleRate; - pInit->channels = drflac__get_channel_count_from_channel_assignment(pInit->firstFrameHeader.channelAssignment); - pInit->bitsPerSample = pInit->firstFrameHeader.bitsPerSample; - pInit->maxBlockSizeInPCMFrames = 65535; - return DRFLAC_TRUE; - } - } else { - drflac_streaminfo streaminfo; - if (!drflac__read_streaminfo(onRead, pUserData, &streaminfo)) { - return DRFLAC_FALSE; - } - pInit->hasStreamInfoBlock = DRFLAC_TRUE; - pInit->sampleRate = streaminfo.sampleRate; - pInit->channels = streaminfo.channels; - pInit->bitsPerSample = streaminfo.bitsPerSample; - pInit->totalPCMFrameCount = streaminfo.totalPCMFrameCount; - pInit->maxBlockSizeInPCMFrames = streaminfo.maxBlockSizeInPCMFrames; - pInit->hasMetadataBlocks = !isLastBlock; - if (onMeta) { - drflac_metadata metadata; - metadata.type = DRFLAC_METADATA_BLOCK_TYPE_STREAMINFO; - metadata.pRawData = NULL; - metadata.rawDataSize = 0; - metadata.data.streaminfo = streaminfo; - onMeta(pUserDataMD, &metadata); - } - return DRFLAC_TRUE; - } -} -#ifndef DR_FLAC_NO_OGG -#define DRFLAC_OGG_MAX_PAGE_SIZE 65307 -#define DRFLAC_OGG_CAPTURE_PATTERN_CRC32 1605413199 -typedef enum -{ - drflac_ogg_recover_on_crc_mismatch, - drflac_ogg_fail_on_crc_mismatch -} drflac_ogg_crc_mismatch_recovery; -#ifndef DR_FLAC_NO_CRC -static drflac_uint32 drflac__crc32_table[] = { - 0x00000000L, 0x04C11DB7L, 0x09823B6EL, 0x0D4326D9L, - 0x130476DCL, 0x17C56B6BL, 0x1A864DB2L, 0x1E475005L, - 0x2608EDB8L, 0x22C9F00FL, 0x2F8AD6D6L, 0x2B4BCB61L, - 0x350C9B64L, 0x31CD86D3L, 0x3C8EA00AL, 0x384FBDBDL, - 0x4C11DB70L, 0x48D0C6C7L, 0x4593E01EL, 0x4152FDA9L, - 0x5F15ADACL, 0x5BD4B01BL, 0x569796C2L, 0x52568B75L, - 0x6A1936C8L, 0x6ED82B7FL, 0x639B0DA6L, 0x675A1011L, - 0x791D4014L, 0x7DDC5DA3L, 0x709F7B7AL, 0x745E66CDL, - 0x9823B6E0L, 0x9CE2AB57L, 0x91A18D8EL, 0x95609039L, - 0x8B27C03CL, 0x8FE6DD8BL, 0x82A5FB52L, 0x8664E6E5L, - 0xBE2B5B58L, 0xBAEA46EFL, 0xB7A96036L, 0xB3687D81L, - 0xAD2F2D84L, 0xA9EE3033L, 0xA4AD16EAL, 0xA06C0B5DL, - 0xD4326D90L, 0xD0F37027L, 0xDDB056FEL, 0xD9714B49L, - 0xC7361B4CL, 0xC3F706FBL, 0xCEB42022L, 0xCA753D95L, - 0xF23A8028L, 0xF6FB9D9FL, 0xFBB8BB46L, 0xFF79A6F1L, - 0xE13EF6F4L, 0xE5FFEB43L, 0xE8BCCD9AL, 0xEC7DD02DL, - 0x34867077L, 0x30476DC0L, 0x3D044B19L, 0x39C556AEL, - 0x278206ABL, 0x23431B1CL, 0x2E003DC5L, 0x2AC12072L, - 0x128E9DCFL, 0x164F8078L, 0x1B0CA6A1L, 0x1FCDBB16L, - 0x018AEB13L, 0x054BF6A4L, 0x0808D07DL, 0x0CC9CDCAL, - 0x7897AB07L, 0x7C56B6B0L, 0x71159069L, 0x75D48DDEL, - 0x6B93DDDBL, 0x6F52C06CL, 0x6211E6B5L, 0x66D0FB02L, - 0x5E9F46BFL, 0x5A5E5B08L, 0x571D7DD1L, 0x53DC6066L, - 0x4D9B3063L, 0x495A2DD4L, 0x44190B0DL, 0x40D816BAL, - 0xACA5C697L, 0xA864DB20L, 0xA527FDF9L, 0xA1E6E04EL, - 0xBFA1B04BL, 0xBB60ADFCL, 0xB6238B25L, 0xB2E29692L, - 0x8AAD2B2FL, 0x8E6C3698L, 0x832F1041L, 0x87EE0DF6L, - 0x99A95DF3L, 0x9D684044L, 0x902B669DL, 0x94EA7B2AL, - 0xE0B41DE7L, 0xE4750050L, 0xE9362689L, 0xEDF73B3EL, - 0xF3B06B3BL, 0xF771768CL, 0xFA325055L, 0xFEF34DE2L, - 0xC6BCF05FL, 0xC27DEDE8L, 0xCF3ECB31L, 0xCBFFD686L, - 0xD5B88683L, 0xD1799B34L, 0xDC3ABDEDL, 0xD8FBA05AL, - 0x690CE0EEL, 0x6DCDFD59L, 0x608EDB80L, 0x644FC637L, - 0x7A089632L, 0x7EC98B85L, 0x738AAD5CL, 0x774BB0EBL, - 0x4F040D56L, 0x4BC510E1L, 0x46863638L, 0x42472B8FL, - 0x5C007B8AL, 0x58C1663DL, 0x558240E4L, 0x51435D53L, - 0x251D3B9EL, 0x21DC2629L, 0x2C9F00F0L, 0x285E1D47L, - 0x36194D42L, 0x32D850F5L, 0x3F9B762CL, 0x3B5A6B9BL, - 0x0315D626L, 0x07D4CB91L, 0x0A97ED48L, 0x0E56F0FFL, - 0x1011A0FAL, 0x14D0BD4DL, 0x19939B94L, 0x1D528623L, - 0xF12F560EL, 0xF5EE4BB9L, 0xF8AD6D60L, 0xFC6C70D7L, - 0xE22B20D2L, 0xE6EA3D65L, 0xEBA91BBCL, 0xEF68060BL, - 0xD727BBB6L, 0xD3E6A601L, 0xDEA580D8L, 0xDA649D6FL, - 0xC423CD6AL, 0xC0E2D0DDL, 0xCDA1F604L, 0xC960EBB3L, - 0xBD3E8D7EL, 0xB9FF90C9L, 0xB4BCB610L, 0xB07DABA7L, - 0xAE3AFBA2L, 0xAAFBE615L, 0xA7B8C0CCL, 0xA379DD7BL, - 0x9B3660C6L, 0x9FF77D71L, 0x92B45BA8L, 0x9675461FL, - 0x8832161AL, 0x8CF30BADL, 0x81B02D74L, 0x857130C3L, - 0x5D8A9099L, 0x594B8D2EL, 0x5408ABF7L, 0x50C9B640L, - 0x4E8EE645L, 0x4A4FFBF2L, 0x470CDD2BL, 0x43CDC09CL, - 0x7B827D21L, 0x7F436096L, 0x7200464FL, 0x76C15BF8L, - 0x68860BFDL, 0x6C47164AL, 0x61043093L, 0x65C52D24L, - 0x119B4BE9L, 0x155A565EL, 0x18197087L, 0x1CD86D30L, - 0x029F3D35L, 0x065E2082L, 0x0B1D065BL, 0x0FDC1BECL, - 0x3793A651L, 0x3352BBE6L, 0x3E119D3FL, 0x3AD08088L, - 0x2497D08DL, 0x2056CD3AL, 0x2D15EBE3L, 0x29D4F654L, - 0xC5A92679L, 0xC1683BCEL, 0xCC2B1D17L, 0xC8EA00A0L, - 0xD6AD50A5L, 0xD26C4D12L, 0xDF2F6BCBL, 0xDBEE767CL, - 0xE3A1CBC1L, 0xE760D676L, 0xEA23F0AFL, 0xEEE2ED18L, - 0xF0A5BD1DL, 0xF464A0AAL, 0xF9278673L, 0xFDE69BC4L, - 0x89B8FD09L, 0x8D79E0BEL, 0x803AC667L, 0x84FBDBD0L, - 0x9ABC8BD5L, 0x9E7D9662L, 0x933EB0BBL, 0x97FFAD0CL, - 0xAFB010B1L, 0xAB710D06L, 0xA6322BDFL, 0xA2F33668L, - 0xBCB4666DL, 0xB8757BDAL, 0xB5365D03L, 0xB1F740B4L -}; -#endif -static DRFLAC_INLINE drflac_uint32 drflac_crc32_byte(drflac_uint32 crc32, drflac_uint8 data) -{ -#ifndef DR_FLAC_NO_CRC - return (crc32 << 8) ^ drflac__crc32_table[(drflac_uint8)((crc32 >> 24) & 0xFF) ^ data]; -#else - (void)data; - return crc32; -#endif -} -#if 0 -static DRFLAC_INLINE drflac_uint32 drflac_crc32_uint32(drflac_uint32 crc32, drflac_uint32 data) -{ - crc32 = drflac_crc32_byte(crc32, (drflac_uint8)((data >> 24) & 0xFF)); - crc32 = drflac_crc32_byte(crc32, (drflac_uint8)((data >> 16) & 0xFF)); - crc32 = drflac_crc32_byte(crc32, (drflac_uint8)((data >> 8) & 0xFF)); - crc32 = drflac_crc32_byte(crc32, (drflac_uint8)((data >> 0) & 0xFF)); - return crc32; -} -static DRFLAC_INLINE drflac_uint32 drflac_crc32_uint64(drflac_uint32 crc32, drflac_uint64 data) -{ - crc32 = drflac_crc32_uint32(crc32, (drflac_uint32)((data >> 32) & 0xFFFFFFFF)); - crc32 = drflac_crc32_uint32(crc32, (drflac_uint32)((data >> 0) & 0xFFFFFFFF)); - return crc32; -} -#endif -static DRFLAC_INLINE drflac_uint32 drflac_crc32_buffer(drflac_uint32 crc32, drflac_uint8* pData, drflac_uint32 dataSize) -{ - drflac_uint32 i; - for (i = 0; i < dataSize; ++i) { - crc32 = drflac_crc32_byte(crc32, pData[i]); - } - return crc32; -} -static DRFLAC_INLINE drflac_bool32 drflac_ogg__is_capture_pattern(drflac_uint8 pattern[4]) -{ - return pattern[0] == 'O' && pattern[1] == 'g' && pattern[2] == 'g' && pattern[3] == 'S'; -} -static DRFLAC_INLINE drflac_uint32 drflac_ogg__get_page_header_size(drflac_ogg_page_header* pHeader) -{ - return 27 + pHeader->segmentCount; -} -static DRFLAC_INLINE drflac_uint32 drflac_ogg__get_page_body_size(drflac_ogg_page_header* pHeader) -{ - drflac_uint32 pageBodySize = 0; - int i; - for (i = 0; i < pHeader->segmentCount; ++i) { - pageBodySize += pHeader->segmentTable[i]; - } - return pageBodySize; -} -static drflac_result drflac_ogg__read_page_header_after_capture_pattern(drflac_read_proc onRead, void* pUserData, drflac_ogg_page_header* pHeader, drflac_uint32* pBytesRead, drflac_uint32* pCRC32) -{ - drflac_uint8 data[23]; - drflac_uint32 i; - DRFLAC_ASSERT(*pCRC32 == DRFLAC_OGG_CAPTURE_PATTERN_CRC32); - if (onRead(pUserData, data, 23) != 23) { - return DRFLAC_AT_END; - } - *pBytesRead += 23; - pHeader->capturePattern[0] = 'O'; - pHeader->capturePattern[1] = 'g'; - pHeader->capturePattern[2] = 'g'; - pHeader->capturePattern[3] = 'S'; - pHeader->structureVersion = data[0]; - pHeader->headerType = data[1]; - DRFLAC_COPY_MEMORY(&pHeader->granulePosition, &data[ 2], 8); - DRFLAC_COPY_MEMORY(&pHeader->serialNumber, &data[10], 4); - DRFLAC_COPY_MEMORY(&pHeader->sequenceNumber, &data[14], 4); - DRFLAC_COPY_MEMORY(&pHeader->checksum, &data[18], 4); - pHeader->segmentCount = data[22]; - data[18] = 0; - data[19] = 0; - data[20] = 0; - data[21] = 0; - for (i = 0; i < 23; ++i) { - *pCRC32 = drflac_crc32_byte(*pCRC32, data[i]); - } - if (onRead(pUserData, pHeader->segmentTable, pHeader->segmentCount) != pHeader->segmentCount) { - return DRFLAC_AT_END; - } - *pBytesRead += pHeader->segmentCount; - for (i = 0; i < pHeader->segmentCount; ++i) { - *pCRC32 = drflac_crc32_byte(*pCRC32, pHeader->segmentTable[i]); - } - return DRFLAC_SUCCESS; -} -static drflac_result drflac_ogg__read_page_header(drflac_read_proc onRead, void* pUserData, drflac_ogg_page_header* pHeader, drflac_uint32* pBytesRead, drflac_uint32* pCRC32) -{ - drflac_uint8 id[4]; - *pBytesRead = 0; - if (onRead(pUserData, id, 4) != 4) { - return DRFLAC_AT_END; - } - *pBytesRead += 4; - for (;;) { - if (drflac_ogg__is_capture_pattern(id)) { - drflac_result result; - *pCRC32 = DRFLAC_OGG_CAPTURE_PATTERN_CRC32; - result = drflac_ogg__read_page_header_after_capture_pattern(onRead, pUserData, pHeader, pBytesRead, pCRC32); - if (result == DRFLAC_SUCCESS) { - return DRFLAC_SUCCESS; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - continue; - } else { - return result; - } - } - } else { - id[0] = id[1]; - id[1] = id[2]; - id[2] = id[3]; - if (onRead(pUserData, &id[3], 1) != 1) { - return DRFLAC_AT_END; - } - *pBytesRead += 1; - } - } -} -typedef struct -{ - drflac_read_proc onRead; - drflac_seek_proc onSeek; - void* pUserData; - drflac_uint64 currentBytePos; - drflac_uint64 firstBytePos; - drflac_uint32 serialNumber; - drflac_ogg_page_header bosPageHeader; - drflac_ogg_page_header currentPageHeader; - drflac_uint32 bytesRemainingInPage; - drflac_uint32 pageDataSize; - drflac_uint8 pageData[DRFLAC_OGG_MAX_PAGE_SIZE]; -} drflac_oggbs; -static size_t drflac_oggbs__read_physical(drflac_oggbs* oggbs, void* bufferOut, size_t bytesToRead) -{ - size_t bytesActuallyRead = oggbs->onRead(oggbs->pUserData, bufferOut, bytesToRead); - oggbs->currentBytePos += bytesActuallyRead; - return bytesActuallyRead; -} -static drflac_bool32 drflac_oggbs__seek_physical(drflac_oggbs* oggbs, drflac_uint64 offset, drflac_seek_origin origin) -{ - if (origin == drflac_seek_origin_start) { - if (offset <= 0x7FFFFFFF) { - if (!oggbs->onSeek(oggbs->pUserData, (int)offset, drflac_seek_origin_start)) { - return DRFLAC_FALSE; - } - oggbs->currentBytePos = offset; - return DRFLAC_TRUE; - } else { - if (!oggbs->onSeek(oggbs->pUserData, 0x7FFFFFFF, drflac_seek_origin_start)) { - return DRFLAC_FALSE; - } - oggbs->currentBytePos = offset; - return drflac_oggbs__seek_physical(oggbs, offset - 0x7FFFFFFF, drflac_seek_origin_current); - } - } else { - while (offset > 0x7FFFFFFF) { - if (!oggbs->onSeek(oggbs->pUserData, 0x7FFFFFFF, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - oggbs->currentBytePos += 0x7FFFFFFF; - offset -= 0x7FFFFFFF; - } - if (!oggbs->onSeek(oggbs->pUserData, (int)offset, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - oggbs->currentBytePos += offset; - return DRFLAC_TRUE; - } -} -static drflac_bool32 drflac_oggbs__goto_next_page(drflac_oggbs* oggbs, drflac_ogg_crc_mismatch_recovery recoveryMethod) -{ - drflac_ogg_page_header header; - for (;;) { - drflac_uint32 crc32 = 0; - drflac_uint32 bytesRead; - drflac_uint32 pageBodySize; -#ifndef DR_FLAC_NO_CRC - drflac_uint32 actualCRC32; -#endif - if (drflac_ogg__read_page_header(oggbs->onRead, oggbs->pUserData, &header, &bytesRead, &crc32) != DRFLAC_SUCCESS) { - return DRFLAC_FALSE; - } - oggbs->currentBytePos += bytesRead; - pageBodySize = drflac_ogg__get_page_body_size(&header); - if (pageBodySize > DRFLAC_OGG_MAX_PAGE_SIZE) { - continue; - } - if (header.serialNumber != oggbs->serialNumber) { - if (pageBodySize > 0 && !drflac_oggbs__seek_physical(oggbs, pageBodySize, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - continue; - } - if (drflac_oggbs__read_physical(oggbs, oggbs->pageData, pageBodySize) != pageBodySize) { - return DRFLAC_FALSE; - } - oggbs->pageDataSize = pageBodySize; -#ifndef DR_FLAC_NO_CRC - actualCRC32 = drflac_crc32_buffer(crc32, oggbs->pageData, oggbs->pageDataSize); - if (actualCRC32 != header.checksum) { - if (recoveryMethod == drflac_ogg_recover_on_crc_mismatch) { - continue; - } else { - drflac_oggbs__goto_next_page(oggbs, drflac_ogg_recover_on_crc_mismatch); - return DRFLAC_FALSE; - } - } -#else - (void)recoveryMethod; -#endif - oggbs->currentPageHeader = header; - oggbs->bytesRemainingInPage = pageBodySize; - return DRFLAC_TRUE; - } -} -#if 0 -static drflac_uint8 drflac_oggbs__get_current_segment_index(drflac_oggbs* oggbs, drflac_uint8* pBytesRemainingInSeg) -{ - drflac_uint32 bytesConsumedInPage = drflac_ogg__get_page_body_size(&oggbs->currentPageHeader) - oggbs->bytesRemainingInPage; - drflac_uint8 iSeg = 0; - drflac_uint32 iByte = 0; - while (iByte < bytesConsumedInPage) { - drflac_uint8 segmentSize = oggbs->currentPageHeader.segmentTable[iSeg]; - if (iByte + segmentSize > bytesConsumedInPage) { - break; - } else { - iSeg += 1; - iByte += segmentSize; - } - } - *pBytesRemainingInSeg = oggbs->currentPageHeader.segmentTable[iSeg] - (drflac_uint8)(bytesConsumedInPage - iByte); - return iSeg; -} -static drflac_bool32 drflac_oggbs__seek_to_next_packet(drflac_oggbs* oggbs) -{ - for (;;) { - drflac_bool32 atEndOfPage = DRFLAC_FALSE; - drflac_uint8 bytesRemainingInSeg; - drflac_uint8 iFirstSeg = drflac_oggbs__get_current_segment_index(oggbs, &bytesRemainingInSeg); - drflac_uint32 bytesToEndOfPacketOrPage = bytesRemainingInSeg; - for (drflac_uint8 iSeg = iFirstSeg; iSeg < oggbs->currentPageHeader.segmentCount; ++iSeg) { - drflac_uint8 segmentSize = oggbs->currentPageHeader.segmentTable[iSeg]; - if (segmentSize < 255) { - if (iSeg == oggbs->currentPageHeader.segmentCount-1) { - atEndOfPage = DRFLAC_TRUE; - } - break; - } - bytesToEndOfPacketOrPage += segmentSize; - } - drflac_oggbs__seek_physical(oggbs, bytesToEndOfPacketOrPage, drflac_seek_origin_current); - oggbs->bytesRemainingInPage -= bytesToEndOfPacketOrPage; - if (atEndOfPage) { - if (!drflac_oggbs__goto_next_page(oggbs)) { - return DRFLAC_FALSE; - } - if ((oggbs->currentPageHeader.headerType & 0x01) == 0) { - return DRFLAC_TRUE; - } - } else { - return DRFLAC_TRUE; - } - } -} -static drflac_bool32 drflac_oggbs__seek_to_next_frame(drflac_oggbs* oggbs) -{ - return drflac_oggbs__seek_to_next_packet(oggbs); -} -#endif -static size_t drflac__on_read_ogg(void* pUserData, void* bufferOut, size_t bytesToRead) -{ - drflac_oggbs* oggbs = (drflac_oggbs*)pUserData; - drflac_uint8* pRunningBufferOut = (drflac_uint8*)bufferOut; - size_t bytesRead = 0; - DRFLAC_ASSERT(oggbs != NULL); - DRFLAC_ASSERT(pRunningBufferOut != NULL); - while (bytesRead < bytesToRead) { - size_t bytesRemainingToRead = bytesToRead - bytesRead; - if (oggbs->bytesRemainingInPage >= bytesRemainingToRead) { - DRFLAC_COPY_MEMORY(pRunningBufferOut, oggbs->pageData + (oggbs->pageDataSize - oggbs->bytesRemainingInPage), bytesRemainingToRead); - bytesRead += bytesRemainingToRead; - oggbs->bytesRemainingInPage -= (drflac_uint32)bytesRemainingToRead; - break; - } - if (oggbs->bytesRemainingInPage > 0) { - DRFLAC_COPY_MEMORY(pRunningBufferOut, oggbs->pageData + (oggbs->pageDataSize - oggbs->bytesRemainingInPage), oggbs->bytesRemainingInPage); - bytesRead += oggbs->bytesRemainingInPage; - pRunningBufferOut += oggbs->bytesRemainingInPage; - oggbs->bytesRemainingInPage = 0; - } - DRFLAC_ASSERT(bytesRemainingToRead > 0); - if (!drflac_oggbs__goto_next_page(oggbs, drflac_ogg_recover_on_crc_mismatch)) { - break; - } - } - return bytesRead; -} -static drflac_bool32 drflac__on_seek_ogg(void* pUserData, int offset, drflac_seek_origin origin) -{ - drflac_oggbs* oggbs = (drflac_oggbs*)pUserData; - int bytesSeeked = 0; - DRFLAC_ASSERT(oggbs != NULL); - DRFLAC_ASSERT(offset >= 0); - if (origin == drflac_seek_origin_start) { - if (!drflac_oggbs__seek_physical(oggbs, (int)oggbs->firstBytePos, drflac_seek_origin_start)) { - return DRFLAC_FALSE; - } - if (!drflac_oggbs__goto_next_page(oggbs, drflac_ogg_fail_on_crc_mismatch)) { - return DRFLAC_FALSE; - } - return drflac__on_seek_ogg(pUserData, offset, drflac_seek_origin_current); - } - DRFLAC_ASSERT(origin == drflac_seek_origin_current); - while (bytesSeeked < offset) { - int bytesRemainingToSeek = offset - bytesSeeked; - DRFLAC_ASSERT(bytesRemainingToSeek >= 0); - if (oggbs->bytesRemainingInPage >= (size_t)bytesRemainingToSeek) { - bytesSeeked += bytesRemainingToSeek; - (void)bytesSeeked; - oggbs->bytesRemainingInPage -= bytesRemainingToSeek; - break; - } - if (oggbs->bytesRemainingInPage > 0) { - bytesSeeked += (int)oggbs->bytesRemainingInPage; - oggbs->bytesRemainingInPage = 0; - } - DRFLAC_ASSERT(bytesRemainingToSeek > 0); - if (!drflac_oggbs__goto_next_page(oggbs, drflac_ogg_fail_on_crc_mismatch)) { - return DRFLAC_FALSE; - } - } - return DRFLAC_TRUE; -} -static drflac_bool32 drflac_ogg__seek_to_pcm_frame(drflac* pFlac, drflac_uint64 pcmFrameIndex) -{ - drflac_oggbs* oggbs = (drflac_oggbs*)pFlac->_oggbs; - drflac_uint64 originalBytePos; - drflac_uint64 runningGranulePosition; - drflac_uint64 runningFrameBytePos; - drflac_uint64 runningPCMFrameCount; - DRFLAC_ASSERT(oggbs != NULL); - originalBytePos = oggbs->currentBytePos; - if (!drflac__seek_to_byte(&pFlac->bs, pFlac->firstFLACFramePosInBytes)) { - return DRFLAC_FALSE; - } - oggbs->bytesRemainingInPage = 0; - runningGranulePosition = 0; - for (;;) { - if (!drflac_oggbs__goto_next_page(oggbs, drflac_ogg_recover_on_crc_mismatch)) { - drflac_oggbs__seek_physical(oggbs, originalBytePos, drflac_seek_origin_start); - return DRFLAC_FALSE; - } - runningFrameBytePos = oggbs->currentBytePos - drflac_ogg__get_page_header_size(&oggbs->currentPageHeader) - oggbs->pageDataSize; - if (oggbs->currentPageHeader.granulePosition >= pcmFrameIndex) { - break; - } - if ((oggbs->currentPageHeader.headerType & 0x01) == 0) { - if (oggbs->currentPageHeader.segmentTable[0] >= 2) { - drflac_uint8 firstBytesInPage[2]; - firstBytesInPage[0] = oggbs->pageData[0]; - firstBytesInPage[1] = oggbs->pageData[1]; - if ((firstBytesInPage[0] == 0xFF) && (firstBytesInPage[1] & 0xFC) == 0xF8) { - runningGranulePosition = oggbs->currentPageHeader.granulePosition; - } - continue; - } - } - } - if (!drflac_oggbs__seek_physical(oggbs, runningFrameBytePos, drflac_seek_origin_start)) { - return DRFLAC_FALSE; - } - if (!drflac_oggbs__goto_next_page(oggbs, drflac_ogg_recover_on_crc_mismatch)) { - return DRFLAC_FALSE; - } - runningPCMFrameCount = runningGranulePosition; - for (;;) { - drflac_uint64 firstPCMFrameInFLACFrame = 0; - drflac_uint64 lastPCMFrameInFLACFrame = 0; - drflac_uint64 pcmFrameCountInThisFrame; - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - return DRFLAC_FALSE; - } - drflac__get_pcm_frame_range_of_current_flac_frame(pFlac, &firstPCMFrameInFLACFrame, &lastPCMFrameInFLACFrame); - pcmFrameCountInThisFrame = (lastPCMFrameInFLACFrame - firstPCMFrameInFLACFrame) + 1; - if (pcmFrameIndex == pFlac->totalPCMFrameCount && (runningPCMFrameCount + pcmFrameCountInThisFrame) == pFlac->totalPCMFrameCount) { - drflac_result result = drflac__decode_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - pFlac->currentPCMFrame = pcmFrameIndex; - pFlac->currentFLACFrame.pcmFramesRemaining = 0; - return DRFLAC_TRUE; - } else { - return DRFLAC_FALSE; - } - } - if (pcmFrameIndex < (runningPCMFrameCount + pcmFrameCountInThisFrame)) { - drflac_result result = drflac__decode_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - drflac_uint64 pcmFramesToDecode = (size_t)(pcmFrameIndex - runningPCMFrameCount); - if (pcmFramesToDecode == 0) { - return DRFLAC_TRUE; - } - pFlac->currentPCMFrame = runningPCMFrameCount; - return drflac__seek_forward_by_pcm_frames(pFlac, pcmFramesToDecode) == pcmFramesToDecode; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - continue; - } else { - return DRFLAC_FALSE; - } - } - } else { - drflac_result result = drflac__seek_to_next_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - runningPCMFrameCount += pcmFrameCountInThisFrame; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - continue; - } else { - return DRFLAC_FALSE; - } - } - } - } -} -static drflac_bool32 drflac__init_private__ogg(drflac_init_info* pInit, drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, void* pUserData, void* pUserDataMD, drflac_bool32 relaxed) -{ - drflac_ogg_page_header header; - drflac_uint32 crc32 = DRFLAC_OGG_CAPTURE_PATTERN_CRC32; - drflac_uint32 bytesRead = 0; - (void)relaxed; - pInit->container = drflac_container_ogg; - pInit->oggFirstBytePos = 0; - if (drflac_ogg__read_page_header_after_capture_pattern(onRead, pUserData, &header, &bytesRead, &crc32) != DRFLAC_SUCCESS) { - return DRFLAC_FALSE; - } - pInit->runningFilePos += bytesRead; - for (;;) { - int pageBodySize; - if ((header.headerType & 0x02) == 0) { - return DRFLAC_FALSE; - } - pageBodySize = drflac_ogg__get_page_body_size(&header); - if (pageBodySize == 51) { - drflac_uint32 bytesRemainingInPage = pageBodySize; - drflac_uint8 packetType; - if (onRead(pUserData, &packetType, 1) != 1) { - return DRFLAC_FALSE; - } - bytesRemainingInPage -= 1; - if (packetType == 0x7F) { - drflac_uint8 sig[4]; - if (onRead(pUserData, sig, 4) != 4) { - return DRFLAC_FALSE; - } - bytesRemainingInPage -= 4; - if (sig[0] == 'F' && sig[1] == 'L' && sig[2] == 'A' && sig[3] == 'C') { - drflac_uint8 mappingVersion[2]; - if (onRead(pUserData, mappingVersion, 2) != 2) { - return DRFLAC_FALSE; - } - if (mappingVersion[0] != 1) { - return DRFLAC_FALSE; - } - if (!onSeek(pUserData, 2, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - if (onRead(pUserData, sig, 4) != 4) { - return DRFLAC_FALSE; - } - if (sig[0] == 'f' && sig[1] == 'L' && sig[2] == 'a' && sig[3] == 'C') { - drflac_streaminfo streaminfo; - drflac_uint8 isLastBlock; - drflac_uint8 blockType; - drflac_uint32 blockSize; - if (!drflac__read_and_decode_block_header(onRead, pUserData, &isLastBlock, &blockType, &blockSize)) { - return DRFLAC_FALSE; - } - if (blockType != DRFLAC_METADATA_BLOCK_TYPE_STREAMINFO || blockSize != 34) { - return DRFLAC_FALSE; - } - if (drflac__read_streaminfo(onRead, pUserData, &streaminfo)) { - pInit->hasStreamInfoBlock = DRFLAC_TRUE; - pInit->sampleRate = streaminfo.sampleRate; - pInit->channels = streaminfo.channels; - pInit->bitsPerSample = streaminfo.bitsPerSample; - pInit->totalPCMFrameCount = streaminfo.totalPCMFrameCount; - pInit->maxBlockSizeInPCMFrames = streaminfo.maxBlockSizeInPCMFrames; - pInit->hasMetadataBlocks = !isLastBlock; - if (onMeta) { - drflac_metadata metadata; - metadata.type = DRFLAC_METADATA_BLOCK_TYPE_STREAMINFO; - metadata.pRawData = NULL; - metadata.rawDataSize = 0; - metadata.data.streaminfo = streaminfo; - onMeta(pUserDataMD, &metadata); - } - pInit->runningFilePos += pageBodySize; - pInit->oggFirstBytePos = pInit->runningFilePos - 79; - pInit->oggSerial = header.serialNumber; - pInit->oggBosHeader = header; - break; - } else { - return DRFLAC_FALSE; - } - } else { - return DRFLAC_FALSE; - } - } else { - if (!onSeek(pUserData, bytesRemainingInPage, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - } - } else { - if (!onSeek(pUserData, bytesRemainingInPage, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - } - } else { - if (!onSeek(pUserData, pageBodySize, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - } - pInit->runningFilePos += pageBodySize; - if (drflac_ogg__read_page_header(onRead, pUserData, &header, &bytesRead, &crc32) != DRFLAC_SUCCESS) { - return DRFLAC_FALSE; - } - pInit->runningFilePos += bytesRead; - } - pInit->hasMetadataBlocks = DRFLAC_TRUE; - return DRFLAC_TRUE; -} -#endif -static drflac_bool32 drflac__init_private(drflac_init_info* pInit, drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, drflac_container container, void* pUserData, void* pUserDataMD) -{ - drflac_bool32 relaxed; - drflac_uint8 id[4]; - if (pInit == NULL || onRead == NULL || onSeek == NULL) { - return DRFLAC_FALSE; - } - DRFLAC_ZERO_MEMORY(pInit, sizeof(*pInit)); - pInit->onRead = onRead; - pInit->onSeek = onSeek; - pInit->onMeta = onMeta; - pInit->container = container; - pInit->pUserData = pUserData; - pInit->pUserDataMD = pUserDataMD; - pInit->bs.onRead = onRead; - pInit->bs.onSeek = onSeek; - pInit->bs.pUserData = pUserData; - drflac__reset_cache(&pInit->bs); - relaxed = container != drflac_container_unknown; - for (;;) { - if (onRead(pUserData, id, 4) != 4) { - return DRFLAC_FALSE; - } - pInit->runningFilePos += 4; - if (id[0] == 'I' && id[1] == 'D' && id[2] == '3') { - drflac_uint8 header[6]; - drflac_uint8 flags; - drflac_uint32 headerSize; - if (onRead(pUserData, header, 6) != 6) { - return DRFLAC_FALSE; - } - pInit->runningFilePos += 6; - flags = header[1]; - DRFLAC_COPY_MEMORY(&headerSize, header+2, 4); - headerSize = drflac__unsynchsafe_32(drflac__be2host_32(headerSize)); - if (flags & 0x10) { - headerSize += 10; - } - if (!onSeek(pUserData, headerSize, drflac_seek_origin_current)) { - return DRFLAC_FALSE; - } - pInit->runningFilePos += headerSize; - } else { - break; - } - } - if (id[0] == 'f' && id[1] == 'L' && id[2] == 'a' && id[3] == 'C') { - return drflac__init_private__native(pInit, onRead, onSeek, onMeta, pUserData, pUserDataMD, relaxed); - } -#ifndef DR_FLAC_NO_OGG - if (id[0] == 'O' && id[1] == 'g' && id[2] == 'g' && id[3] == 'S') { - return drflac__init_private__ogg(pInit, onRead, onSeek, onMeta, pUserData, pUserDataMD, relaxed); - } -#endif - if (relaxed) { - if (container == drflac_container_native) { - return drflac__init_private__native(pInit, onRead, onSeek, onMeta, pUserData, pUserDataMD, relaxed); - } -#ifndef DR_FLAC_NO_OGG - if (container == drflac_container_ogg) { - return drflac__init_private__ogg(pInit, onRead, onSeek, onMeta, pUserData, pUserDataMD, relaxed); - } -#endif - } - return DRFLAC_FALSE; -} -static void drflac__init_from_info(drflac* pFlac, const drflac_init_info* pInit) -{ - DRFLAC_ASSERT(pFlac != NULL); - DRFLAC_ASSERT(pInit != NULL); - DRFLAC_ZERO_MEMORY(pFlac, sizeof(*pFlac)); - pFlac->bs = pInit->bs; - pFlac->onMeta = pInit->onMeta; - pFlac->pUserDataMD = pInit->pUserDataMD; - pFlac->maxBlockSizeInPCMFrames = pInit->maxBlockSizeInPCMFrames; - pFlac->sampleRate = pInit->sampleRate; - pFlac->channels = (drflac_uint8)pInit->channels; - pFlac->bitsPerSample = (drflac_uint8)pInit->bitsPerSample; - pFlac->totalPCMFrameCount = pInit->totalPCMFrameCount; - pFlac->container = pInit->container; -} -static drflac* drflac_open_with_metadata_private(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, drflac_container container, void* pUserData, void* pUserDataMD, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac_init_info init; - drflac_uint32 allocationSize; - drflac_uint32 wholeSIMDVectorCountPerChannel; - drflac_uint32 decodedSamplesAllocationSize; -#ifndef DR_FLAC_NO_OGG - drflac_oggbs* pOggbs = NULL; -#endif - drflac_uint64 firstFramePos; - drflac_uint64 seektablePos; - drflac_uint32 seekpointCount; - drflac_allocation_callbacks allocationCallbacks; - drflac* pFlac; - drflac__init_cpu_caps(); - if (!drflac__init_private(&init, onRead, onSeek, onMeta, container, pUserData, pUserDataMD)) { - return NULL; - } - if (pAllocationCallbacks != NULL) { - allocationCallbacks = *pAllocationCallbacks; - if (allocationCallbacks.onFree == NULL || (allocationCallbacks.onMalloc == NULL && allocationCallbacks.onRealloc == NULL)) { - return NULL; - } - } else { - allocationCallbacks.pUserData = NULL; - allocationCallbacks.onMalloc = drflac__malloc_default; - allocationCallbacks.onRealloc = drflac__realloc_default; - allocationCallbacks.onFree = drflac__free_default; - } - allocationSize = sizeof(drflac); - if ((init.maxBlockSizeInPCMFrames % (DRFLAC_MAX_SIMD_VECTOR_SIZE / sizeof(drflac_int32))) == 0) { - wholeSIMDVectorCountPerChannel = (init.maxBlockSizeInPCMFrames / (DRFLAC_MAX_SIMD_VECTOR_SIZE / sizeof(drflac_int32))); - } else { - wholeSIMDVectorCountPerChannel = (init.maxBlockSizeInPCMFrames / (DRFLAC_MAX_SIMD_VECTOR_SIZE / sizeof(drflac_int32))) + 1; - } - decodedSamplesAllocationSize = wholeSIMDVectorCountPerChannel * DRFLAC_MAX_SIMD_VECTOR_SIZE * init.channels; - allocationSize += decodedSamplesAllocationSize; - allocationSize += DRFLAC_MAX_SIMD_VECTOR_SIZE; -#ifndef DR_FLAC_NO_OGG - if (init.container == drflac_container_ogg) { - allocationSize += sizeof(drflac_oggbs); - pOggbs = (drflac_oggbs*)drflac__malloc_from_callbacks(sizeof(*pOggbs), &allocationCallbacks); - if (pOggbs == NULL) { - return NULL; - } - DRFLAC_ZERO_MEMORY(pOggbs, sizeof(*pOggbs)); - pOggbs->onRead = onRead; - pOggbs->onSeek = onSeek; - pOggbs->pUserData = pUserData; - pOggbs->currentBytePos = init.oggFirstBytePos; - pOggbs->firstBytePos = init.oggFirstBytePos; - pOggbs->serialNumber = init.oggSerial; - pOggbs->bosPageHeader = init.oggBosHeader; - pOggbs->bytesRemainingInPage = 0; - } -#endif - firstFramePos = 42; - seektablePos = 0; - seekpointCount = 0; - if (init.hasMetadataBlocks) { - drflac_read_proc onReadOverride = onRead; - drflac_seek_proc onSeekOverride = onSeek; - void* pUserDataOverride = pUserData; -#ifndef DR_FLAC_NO_OGG - if (init.container == drflac_container_ogg) { - onReadOverride = drflac__on_read_ogg; - onSeekOverride = drflac__on_seek_ogg; - pUserDataOverride = (void*)pOggbs; - } -#endif - if (!drflac__read_and_decode_metadata(onReadOverride, onSeekOverride, onMeta, pUserDataOverride, pUserDataMD, &firstFramePos, &seektablePos, &seekpointCount, &allocationCallbacks)) { - #ifndef DR_FLAC_NO_OGG - drflac__free_from_callbacks(pOggbs, &allocationCallbacks); - #endif - return NULL; - } - allocationSize += seekpointCount * sizeof(drflac_seekpoint); - } - pFlac = (drflac*)drflac__malloc_from_callbacks(allocationSize, &allocationCallbacks); - if (pFlac == NULL) { - #ifndef DR_FLAC_NO_OGG - drflac__free_from_callbacks(pOggbs, &allocationCallbacks); - #endif - return NULL; - } - drflac__init_from_info(pFlac, &init); - pFlac->allocationCallbacks = allocationCallbacks; - pFlac->pDecodedSamples = (drflac_int32*)drflac_align((size_t)pFlac->pExtraData, DRFLAC_MAX_SIMD_VECTOR_SIZE); -#ifndef DR_FLAC_NO_OGG - if (init.container == drflac_container_ogg) { - drflac_oggbs* pInternalOggbs = (drflac_oggbs*)((drflac_uint8*)pFlac->pDecodedSamples + decodedSamplesAllocationSize + (seekpointCount * sizeof(drflac_seekpoint))); - DRFLAC_COPY_MEMORY(pInternalOggbs, pOggbs, sizeof(*pOggbs)); - drflac__free_from_callbacks(pOggbs, &allocationCallbacks); - pOggbs = NULL; - pFlac->bs.onRead = drflac__on_read_ogg; - pFlac->bs.onSeek = drflac__on_seek_ogg; - pFlac->bs.pUserData = (void*)pInternalOggbs; - pFlac->_oggbs = (void*)pInternalOggbs; - } -#endif - pFlac->firstFLACFramePosInBytes = firstFramePos; -#ifndef DR_FLAC_NO_OGG - if (init.container == drflac_container_ogg) - { - pFlac->pSeekpoints = NULL; - pFlac->seekpointCount = 0; - } - else -#endif - { - if (seektablePos != 0) { - pFlac->seekpointCount = seekpointCount; - pFlac->pSeekpoints = (drflac_seekpoint*)((drflac_uint8*)pFlac->pDecodedSamples + decodedSamplesAllocationSize); - DRFLAC_ASSERT(pFlac->bs.onSeek != NULL); - DRFLAC_ASSERT(pFlac->bs.onRead != NULL); - if (pFlac->bs.onSeek(pFlac->bs.pUserData, (int)seektablePos, drflac_seek_origin_start)) { - drflac_uint32 iSeekpoint; - for (iSeekpoint = 0; iSeekpoint < seekpointCount; iSeekpoint += 1) { - if (pFlac->bs.onRead(pFlac->bs.pUserData, pFlac->pSeekpoints + iSeekpoint, DRFLAC_SEEKPOINT_SIZE_IN_BYTES) == DRFLAC_SEEKPOINT_SIZE_IN_BYTES) { - pFlac->pSeekpoints[iSeekpoint].firstPCMFrame = drflac__be2host_64(pFlac->pSeekpoints[iSeekpoint].firstPCMFrame); - pFlac->pSeekpoints[iSeekpoint].flacFrameOffset = drflac__be2host_64(pFlac->pSeekpoints[iSeekpoint].flacFrameOffset); - pFlac->pSeekpoints[iSeekpoint].pcmFrameCount = drflac__be2host_16(pFlac->pSeekpoints[iSeekpoint].pcmFrameCount); - } else { - pFlac->pSeekpoints = NULL; - pFlac->seekpointCount = 0; - break; - } - } - if (!pFlac->bs.onSeek(pFlac->bs.pUserData, (int)pFlac->firstFLACFramePosInBytes, drflac_seek_origin_start)) { - drflac__free_from_callbacks(pFlac, &allocationCallbacks); - return NULL; - } - } else { - pFlac->pSeekpoints = NULL; - pFlac->seekpointCount = 0; - } - } - } - if (!init.hasStreamInfoBlock) { - pFlac->currentFLACFrame.header = init.firstFrameHeader; - for (;;) { - drflac_result result = drflac__decode_flac_frame(pFlac); - if (result == DRFLAC_SUCCESS) { - break; - } else { - if (result == DRFLAC_CRC_MISMATCH) { - if (!drflac__read_next_flac_frame_header(&pFlac->bs, pFlac->bitsPerSample, &pFlac->currentFLACFrame.header)) { - drflac__free_from_callbacks(pFlac, &allocationCallbacks); - return NULL; - } - continue; - } else { - drflac__free_from_callbacks(pFlac, &allocationCallbacks); - return NULL; - } - } - } - } - return pFlac; -} -#ifndef DR_FLAC_NO_STDIO -#include -#ifndef DR_FLAC_NO_WCHAR -#include -#endif -#include -static drflac_result drflac_result_from_errno(int e) -{ - switch (e) - { - case 0: return DRFLAC_SUCCESS; - #ifdef EPERM - case EPERM: return DRFLAC_INVALID_OPERATION; - #endif - #ifdef ENOENT - case ENOENT: return DRFLAC_DOES_NOT_EXIST; - #endif - #ifdef ESRCH - case ESRCH: return DRFLAC_DOES_NOT_EXIST; - #endif - #ifdef EINTR - case EINTR: return DRFLAC_INTERRUPT; - #endif - #ifdef EIO - case EIO: return DRFLAC_IO_ERROR; - #endif - #ifdef ENXIO - case ENXIO: return DRFLAC_DOES_NOT_EXIST; - #endif - #ifdef E2BIG - case E2BIG: return DRFLAC_INVALID_ARGS; - #endif - #ifdef ENOEXEC - case ENOEXEC: return DRFLAC_INVALID_FILE; - #endif - #ifdef EBADF - case EBADF: return DRFLAC_INVALID_FILE; - #endif - #ifdef ECHILD - case ECHILD: return DRFLAC_ERROR; - #endif - #ifdef EAGAIN - case EAGAIN: return DRFLAC_UNAVAILABLE; - #endif - #ifdef ENOMEM - case ENOMEM: return DRFLAC_OUT_OF_MEMORY; - #endif - #ifdef EACCES - case EACCES: return DRFLAC_ACCESS_DENIED; - #endif - #ifdef EFAULT - case EFAULT: return DRFLAC_BAD_ADDRESS; - #endif - #ifdef ENOTBLK - case ENOTBLK: return DRFLAC_ERROR; - #endif - #ifdef EBUSY - case EBUSY: return DRFLAC_BUSY; - #endif - #ifdef EEXIST - case EEXIST: return DRFLAC_ALREADY_EXISTS; - #endif - #ifdef EXDEV - case EXDEV: return DRFLAC_ERROR; - #endif - #ifdef ENODEV - case ENODEV: return DRFLAC_DOES_NOT_EXIST; - #endif - #ifdef ENOTDIR - case ENOTDIR: return DRFLAC_NOT_DIRECTORY; - #endif - #ifdef EISDIR - case EISDIR: return DRFLAC_IS_DIRECTORY; - #endif - #ifdef EINVAL - case EINVAL: return DRFLAC_INVALID_ARGS; - #endif - #ifdef ENFILE - case ENFILE: return DRFLAC_TOO_MANY_OPEN_FILES; - #endif - #ifdef EMFILE - case EMFILE: return DRFLAC_TOO_MANY_OPEN_FILES; - #endif - #ifdef ENOTTY - case ENOTTY: return DRFLAC_INVALID_OPERATION; - #endif - #ifdef ETXTBSY - case ETXTBSY: return DRFLAC_BUSY; - #endif - #ifdef EFBIG - case EFBIG: return DRFLAC_TOO_BIG; - #endif - #ifdef ENOSPC - case ENOSPC: return DRFLAC_NO_SPACE; - #endif - #ifdef ESPIPE - case ESPIPE: return DRFLAC_BAD_SEEK; - #endif - #ifdef EROFS - case EROFS: return DRFLAC_ACCESS_DENIED; - #endif - #ifdef EMLINK - case EMLINK: return DRFLAC_TOO_MANY_LINKS; - #endif - #ifdef EPIPE - case EPIPE: return DRFLAC_BAD_PIPE; - #endif - #ifdef EDOM - case EDOM: return DRFLAC_OUT_OF_RANGE; - #endif - #ifdef ERANGE - case ERANGE: return DRFLAC_OUT_OF_RANGE; - #endif - #ifdef EDEADLK - case EDEADLK: return DRFLAC_DEADLOCK; - #endif - #ifdef ENAMETOOLONG - case ENAMETOOLONG: return DRFLAC_PATH_TOO_LONG; - #endif - #ifdef ENOLCK - case ENOLCK: return DRFLAC_ERROR; - #endif - #ifdef ENOSYS - case ENOSYS: return DRFLAC_NOT_IMPLEMENTED; - #endif - #ifdef ENOTEMPTY - case ENOTEMPTY: return DRFLAC_DIRECTORY_NOT_EMPTY; - #endif - #ifdef ELOOP - case ELOOP: return DRFLAC_TOO_MANY_LINKS; - #endif - #ifdef ENOMSG - case ENOMSG: return DRFLAC_NO_MESSAGE; - #endif - #ifdef EIDRM - case EIDRM: return DRFLAC_ERROR; - #endif - #ifdef ECHRNG - case ECHRNG: return DRFLAC_ERROR; - #endif - #ifdef EL2NSYNC - case EL2NSYNC: return DRFLAC_ERROR; - #endif - #ifdef EL3HLT - case EL3HLT: return DRFLAC_ERROR; - #endif - #ifdef EL3RST - case EL3RST: return DRFLAC_ERROR; - #endif - #ifdef ELNRNG - case ELNRNG: return DRFLAC_OUT_OF_RANGE; - #endif - #ifdef EUNATCH - case EUNATCH: return DRFLAC_ERROR; - #endif - #ifdef ENOCSI - case ENOCSI: return DRFLAC_ERROR; - #endif - #ifdef EL2HLT - case EL2HLT: return DRFLAC_ERROR; - #endif - #ifdef EBADE - case EBADE: return DRFLAC_ERROR; - #endif - #ifdef EBADR - case EBADR: return DRFLAC_ERROR; - #endif - #ifdef EXFULL - case EXFULL: return DRFLAC_ERROR; - #endif - #ifdef ENOANO - case ENOANO: return DRFLAC_ERROR; - #endif - #ifdef EBADRQC - case EBADRQC: return DRFLAC_ERROR; - #endif - #ifdef EBADSLT - case EBADSLT: return DRFLAC_ERROR; - #endif - #ifdef EBFONT - case EBFONT: return DRFLAC_INVALID_FILE; - #endif - #ifdef ENOSTR - case ENOSTR: return DRFLAC_ERROR; - #endif - #ifdef ENODATA - case ENODATA: return DRFLAC_NO_DATA_AVAILABLE; - #endif - #ifdef ETIME - case ETIME: return DRFLAC_TIMEOUT; - #endif - #ifdef ENOSR - case ENOSR: return DRFLAC_NO_DATA_AVAILABLE; - #endif - #ifdef ENONET - case ENONET: return DRFLAC_NO_NETWORK; - #endif - #ifdef ENOPKG - case ENOPKG: return DRFLAC_ERROR; - #endif - #ifdef EREMOTE - case EREMOTE: return DRFLAC_ERROR; - #endif - #ifdef ENOLINK - case ENOLINK: return DRFLAC_ERROR; - #endif - #ifdef EADV - case EADV: return DRFLAC_ERROR; - #endif - #ifdef ESRMNT - case ESRMNT: return DRFLAC_ERROR; - #endif - #ifdef ECOMM - case ECOMM: return DRFLAC_ERROR; - #endif - #ifdef EPROTO - case EPROTO: return DRFLAC_ERROR; - #endif - #ifdef EMULTIHOP - case EMULTIHOP: return DRFLAC_ERROR; - #endif - #ifdef EDOTDOT - case EDOTDOT: return DRFLAC_ERROR; - #endif - #ifdef EBADMSG - case EBADMSG: return DRFLAC_BAD_MESSAGE; - #endif - #ifdef EOVERFLOW - case EOVERFLOW: return DRFLAC_TOO_BIG; - #endif - #ifdef ENOTUNIQ - case ENOTUNIQ: return DRFLAC_NOT_UNIQUE; - #endif - #ifdef EBADFD - case EBADFD: return DRFLAC_ERROR; - #endif - #ifdef EREMCHG - case EREMCHG: return DRFLAC_ERROR; - #endif - #ifdef ELIBACC - case ELIBACC: return DRFLAC_ACCESS_DENIED; - #endif - #ifdef ELIBBAD - case ELIBBAD: return DRFLAC_INVALID_FILE; - #endif - #ifdef ELIBSCN - case ELIBSCN: return DRFLAC_INVALID_FILE; - #endif - #ifdef ELIBMAX - case ELIBMAX: return DRFLAC_ERROR; - #endif - #ifdef ELIBEXEC - case ELIBEXEC: return DRFLAC_ERROR; - #endif - #ifdef EILSEQ - case EILSEQ: return DRFLAC_INVALID_DATA; - #endif - #ifdef ERESTART - case ERESTART: return DRFLAC_ERROR; - #endif - #ifdef ESTRPIPE - case ESTRPIPE: return DRFLAC_ERROR; - #endif - #ifdef EUSERS - case EUSERS: return DRFLAC_ERROR; - #endif - #ifdef ENOTSOCK - case ENOTSOCK: return DRFLAC_NOT_SOCKET; - #endif - #ifdef EDESTADDRREQ - case EDESTADDRREQ: return DRFLAC_NO_ADDRESS; - #endif - #ifdef EMSGSIZE - case EMSGSIZE: return DRFLAC_TOO_BIG; - #endif - #ifdef EPROTOTYPE - case EPROTOTYPE: return DRFLAC_BAD_PROTOCOL; - #endif - #ifdef ENOPROTOOPT - case ENOPROTOOPT: return DRFLAC_PROTOCOL_UNAVAILABLE; - #endif - #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return DRFLAC_PROTOCOL_NOT_SUPPORTED; - #endif - #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return DRFLAC_SOCKET_NOT_SUPPORTED; - #endif - #ifdef EOPNOTSUPP - case EOPNOTSUPP: return DRFLAC_INVALID_OPERATION; - #endif - #ifdef EPFNOSUPPORT - case EPFNOSUPPORT: return DRFLAC_PROTOCOL_FAMILY_NOT_SUPPORTED; - #endif - #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return DRFLAC_ADDRESS_FAMILY_NOT_SUPPORTED; - #endif - #ifdef EADDRINUSE - case EADDRINUSE: return DRFLAC_ALREADY_IN_USE; - #endif - #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return DRFLAC_ERROR; - #endif - #ifdef ENETDOWN - case ENETDOWN: return DRFLAC_NO_NETWORK; - #endif - #ifdef ENETUNREACH - case ENETUNREACH: return DRFLAC_NO_NETWORK; - #endif - #ifdef ENETRESET - case ENETRESET: return DRFLAC_NO_NETWORK; - #endif - #ifdef ECONNABORTED - case ECONNABORTED: return DRFLAC_NO_NETWORK; - #endif - #ifdef ECONNRESET - case ECONNRESET: return DRFLAC_CONNECTION_RESET; - #endif - #ifdef ENOBUFS - case ENOBUFS: return DRFLAC_NO_SPACE; - #endif - #ifdef EISCONN - case EISCONN: return DRFLAC_ALREADY_CONNECTED; - #endif - #ifdef ENOTCONN - case ENOTCONN: return DRFLAC_NOT_CONNECTED; - #endif - #ifdef ESHUTDOWN - case ESHUTDOWN: return DRFLAC_ERROR; - #endif - #ifdef ETOOMANYREFS - case ETOOMANYREFS: return DRFLAC_ERROR; - #endif - #ifdef ETIMEDOUT - case ETIMEDOUT: return DRFLAC_TIMEOUT; - #endif - #ifdef ECONNREFUSED - case ECONNREFUSED: return DRFLAC_CONNECTION_REFUSED; - #endif - #ifdef EHOSTDOWN - case EHOSTDOWN: return DRFLAC_NO_HOST; - #endif - #ifdef EHOSTUNREACH - case EHOSTUNREACH: return DRFLAC_NO_HOST; - #endif - #ifdef EALREADY - case EALREADY: return DRFLAC_IN_PROGRESS; - #endif - #ifdef EINPROGRESS - case EINPROGRESS: return DRFLAC_IN_PROGRESS; - #endif - #ifdef ESTALE - case ESTALE: return DRFLAC_INVALID_FILE; - #endif - #ifdef EUCLEAN - case EUCLEAN: return DRFLAC_ERROR; - #endif - #ifdef ENOTNAM - case ENOTNAM: return DRFLAC_ERROR; - #endif - #ifdef ENAVAIL - case ENAVAIL: return DRFLAC_ERROR; - #endif - #ifdef EISNAM - case EISNAM: return DRFLAC_ERROR; - #endif - #ifdef EREMOTEIO - case EREMOTEIO: return DRFLAC_IO_ERROR; - #endif - #ifdef EDQUOT - case EDQUOT: return DRFLAC_NO_SPACE; - #endif - #ifdef ENOMEDIUM - case ENOMEDIUM: return DRFLAC_DOES_NOT_EXIST; - #endif - #ifdef EMEDIUMTYPE - case EMEDIUMTYPE: return DRFLAC_ERROR; - #endif - #ifdef ECANCELED - case ECANCELED: return DRFLAC_CANCELLED; - #endif - #ifdef ENOKEY - case ENOKEY: return DRFLAC_ERROR; - #endif - #ifdef EKEYEXPIRED - case EKEYEXPIRED: return DRFLAC_ERROR; - #endif - #ifdef EKEYREVOKED - case EKEYREVOKED: return DRFLAC_ERROR; - #endif - #ifdef EKEYREJECTED - case EKEYREJECTED: return DRFLAC_ERROR; - #endif - #ifdef EOWNERDEAD - case EOWNERDEAD: return DRFLAC_ERROR; - #endif - #ifdef ENOTRECOVERABLE - case ENOTRECOVERABLE: return DRFLAC_ERROR; - #endif - #ifdef ERFKILL - case ERFKILL: return DRFLAC_ERROR; - #endif - #ifdef EHWPOISON - case EHWPOISON: return DRFLAC_ERROR; - #endif - default: return DRFLAC_ERROR; - } -} -static drflac_result drflac_fopen(FILE** ppFile, const char* pFilePath, const char* pOpenMode) -{ -#if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err; -#endif - if (ppFile != NULL) { - *ppFile = NULL; - } - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return DRFLAC_INVALID_ARGS; - } -#if defined(_MSC_VER) && _MSC_VER >= 1400 - err = fopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return drflac_result_from_errno(err); - } -#else -#if defined(_WIN32) || defined(__APPLE__) - *ppFile = fopen(pFilePath, pOpenMode); -#else - #if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64 && defined(_LARGEFILE64_SOURCE) - *ppFile = fopen64(pFilePath, pOpenMode); - #else - *ppFile = fopen(pFilePath, pOpenMode); - #endif -#endif - if (*ppFile == NULL) { - drflac_result result = drflac_result_from_errno(errno); - if (result == DRFLAC_SUCCESS) { - result = DRFLAC_ERROR; - } - return result; - } -#endif - return DRFLAC_SUCCESS; -} -#if defined(_WIN32) - #if defined(_MSC_VER) || defined(__MINGW64__) || (!defined(__STRICT_ANSI__) && !defined(_NO_EXT_KEYS)) - #define DRFLAC_HAS_WFOPEN - #endif -#endif -#ifndef DR_FLAC_NO_WCHAR -static drflac_result drflac_wfopen(FILE** ppFile, const wchar_t* pFilePath, const wchar_t* pOpenMode, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - if (ppFile != NULL) { - *ppFile = NULL; - } - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return DRFLAC_INVALID_ARGS; - } -#if defined(DRFLAC_HAS_WFOPEN) - { - #if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err = _wfopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return drflac_result_from_errno(err); - } - #else - *ppFile = _wfopen(pFilePath, pOpenMode); - if (*ppFile == NULL) { - return drflac_result_from_errno(errno); - } - #endif - (void)pAllocationCallbacks; - } -#else - #if defined(__DJGPP__) - { - } - #else - { - mbstate_t mbs; - size_t lenMB; - const wchar_t* pFilePathTemp = pFilePath; - char* pFilePathMB = NULL; - char pOpenModeMB[32] = {0}; - DRFLAC_ZERO_OBJECT(&mbs); - lenMB = wcsrtombs(NULL, &pFilePathTemp, 0, &mbs); - if (lenMB == (size_t)-1) { - return drflac_result_from_errno(errno); - } - pFilePathMB = (char*)drflac__malloc_from_callbacks(lenMB + 1, pAllocationCallbacks); - if (pFilePathMB == NULL) { - return DRFLAC_OUT_OF_MEMORY; - } - pFilePathTemp = pFilePath; - DRFLAC_ZERO_OBJECT(&mbs); - wcsrtombs(pFilePathMB, &pFilePathTemp, lenMB + 1, &mbs); - { - size_t i = 0; - for (;;) { - if (pOpenMode[i] == 0) { - pOpenModeMB[i] = '\0'; - break; - } - pOpenModeMB[i] = (char)pOpenMode[i]; - i += 1; - } - } - *ppFile = fopen(pFilePathMB, pOpenModeMB); - drflac__free_from_callbacks(pFilePathMB, pAllocationCallbacks); - } - #endif - if (*ppFile == NULL) { - return DRFLAC_ERROR; - } -#endif - return DRFLAC_SUCCESS; -} -#endif -static size_t drflac__on_read_stdio(void* pUserData, void* bufferOut, size_t bytesToRead) -{ - return fread(bufferOut, 1, bytesToRead, (FILE*)pUserData); -} -static drflac_bool32 drflac__on_seek_stdio(void* pUserData, int offset, drflac_seek_origin origin) -{ - DRFLAC_ASSERT(offset >= 0); - return fseek((FILE*)pUserData, offset, (origin == drflac_seek_origin_current) ? SEEK_CUR : SEEK_SET) == 0; -} -DRFLAC_API drflac* drflac_open_file(const char* pFileName, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - FILE* pFile; - if (drflac_fopen(&pFile, pFileName, "rb") != DRFLAC_SUCCESS) { - return NULL; - } - pFlac = drflac_open(drflac__on_read_stdio, drflac__on_seek_stdio, (void*)pFile, pAllocationCallbacks); - if (pFlac == NULL) { - fclose(pFile); - return NULL; - } - return pFlac; -} -#ifndef DR_FLAC_NO_WCHAR -DRFLAC_API drflac* drflac_open_file_w(const wchar_t* pFileName, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - FILE* pFile; - if (drflac_wfopen(&pFile, pFileName, L"rb", pAllocationCallbacks) != DRFLAC_SUCCESS) { - return NULL; - } - pFlac = drflac_open(drflac__on_read_stdio, drflac__on_seek_stdio, (void*)pFile, pAllocationCallbacks); - if (pFlac == NULL) { - fclose(pFile); - return NULL; - } - return pFlac; -} -#endif -DRFLAC_API drflac* drflac_open_file_with_metadata(const char* pFileName, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - FILE* pFile; - if (drflac_fopen(&pFile, pFileName, "rb") != DRFLAC_SUCCESS) { - return NULL; - } - pFlac = drflac_open_with_metadata_private(drflac__on_read_stdio, drflac__on_seek_stdio, onMeta, drflac_container_unknown, (void*)pFile, pUserData, pAllocationCallbacks); - if (pFlac == NULL) { - fclose(pFile); - return pFlac; - } - return pFlac; -} -#ifndef DR_FLAC_NO_WCHAR -DRFLAC_API drflac* drflac_open_file_with_metadata_w(const wchar_t* pFileName, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - FILE* pFile; - if (drflac_wfopen(&pFile, pFileName, L"rb", pAllocationCallbacks) != DRFLAC_SUCCESS) { - return NULL; - } - pFlac = drflac_open_with_metadata_private(drflac__on_read_stdio, drflac__on_seek_stdio, onMeta, drflac_container_unknown, (void*)pFile, pUserData, pAllocationCallbacks); - if (pFlac == NULL) { - fclose(pFile); - return pFlac; - } - return pFlac; -} -#endif -#endif -static size_t drflac__on_read_memory(void* pUserData, void* bufferOut, size_t bytesToRead) -{ - drflac__memory_stream* memoryStream = (drflac__memory_stream*)pUserData; - size_t bytesRemaining; - DRFLAC_ASSERT(memoryStream != NULL); - DRFLAC_ASSERT(memoryStream->dataSize >= memoryStream->currentReadPos); - bytesRemaining = memoryStream->dataSize - memoryStream->currentReadPos; - if (bytesToRead > bytesRemaining) { - bytesToRead = bytesRemaining; - } - if (bytesToRead > 0) { - DRFLAC_COPY_MEMORY(bufferOut, memoryStream->data + memoryStream->currentReadPos, bytesToRead); - memoryStream->currentReadPos += bytesToRead; - } - return bytesToRead; -} -static drflac_bool32 drflac__on_seek_memory(void* pUserData, int offset, drflac_seek_origin origin) -{ - drflac__memory_stream* memoryStream = (drflac__memory_stream*)pUserData; - DRFLAC_ASSERT(memoryStream != NULL); - DRFLAC_ASSERT(offset >= 0); - if (offset > (drflac_int64)memoryStream->dataSize) { - return DRFLAC_FALSE; - } - if (origin == drflac_seek_origin_current) { - if (memoryStream->currentReadPos + offset <= memoryStream->dataSize) { - memoryStream->currentReadPos += offset; - } else { - return DRFLAC_FALSE; - } - } else { - if ((drflac_uint32)offset <= memoryStream->dataSize) { - memoryStream->currentReadPos = offset; - } else { - return DRFLAC_FALSE; - } - } - return DRFLAC_TRUE; -} -DRFLAC_API drflac* drflac_open_memory(const void* pData, size_t dataSize, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac__memory_stream memoryStream; - drflac* pFlac; - memoryStream.data = (const drflac_uint8*)pData; - memoryStream.dataSize = dataSize; - memoryStream.currentReadPos = 0; - pFlac = drflac_open(drflac__on_read_memory, drflac__on_seek_memory, &memoryStream, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - pFlac->memoryStream = memoryStream; -#ifndef DR_FLAC_NO_OGG - if (pFlac->container == drflac_container_ogg) - { - drflac_oggbs* oggbs = (drflac_oggbs*)pFlac->_oggbs; - oggbs->pUserData = &pFlac->memoryStream; - } - else -#endif - { - pFlac->bs.pUserData = &pFlac->memoryStream; - } - return pFlac; -} -DRFLAC_API drflac* drflac_open_memory_with_metadata(const void* pData, size_t dataSize, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac__memory_stream memoryStream; - drflac* pFlac; - memoryStream.data = (const drflac_uint8*)pData; - memoryStream.dataSize = dataSize; - memoryStream.currentReadPos = 0; - pFlac = drflac_open_with_metadata_private(drflac__on_read_memory, drflac__on_seek_memory, onMeta, drflac_container_unknown, &memoryStream, pUserData, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - pFlac->memoryStream = memoryStream; -#ifndef DR_FLAC_NO_OGG - if (pFlac->container == drflac_container_ogg) - { - drflac_oggbs* oggbs = (drflac_oggbs*)pFlac->_oggbs; - oggbs->pUserData = &pFlac->memoryStream; - } - else -#endif - { - pFlac->bs.pUserData = &pFlac->memoryStream; - } - return pFlac; -} -DRFLAC_API drflac* drflac_open(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - return drflac_open_with_metadata_private(onRead, onSeek, NULL, drflac_container_unknown, pUserData, pUserData, pAllocationCallbacks); -} -DRFLAC_API drflac* drflac_open_relaxed(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_container container, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - return drflac_open_with_metadata_private(onRead, onSeek, NULL, container, pUserData, pUserData, pAllocationCallbacks); -} -DRFLAC_API drflac* drflac_open_with_metadata(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - return drflac_open_with_metadata_private(onRead, onSeek, onMeta, drflac_container_unknown, pUserData, pUserData, pAllocationCallbacks); -} -DRFLAC_API drflac* drflac_open_with_metadata_relaxed(drflac_read_proc onRead, drflac_seek_proc onSeek, drflac_meta_proc onMeta, drflac_container container, void* pUserData, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - return drflac_open_with_metadata_private(onRead, onSeek, onMeta, container, pUserData, pUserData, pAllocationCallbacks); -} -DRFLAC_API void drflac_close(drflac* pFlac) -{ - if (pFlac == NULL) { - return; - } -#ifndef DR_FLAC_NO_STDIO - if (pFlac->bs.onRead == drflac__on_read_stdio) { - fclose((FILE*)pFlac->bs.pUserData); - } -#ifndef DR_FLAC_NO_OGG - if (pFlac->container == drflac_container_ogg) { - drflac_oggbs* oggbs = (drflac_oggbs*)pFlac->_oggbs; - DRFLAC_ASSERT(pFlac->bs.onRead == drflac__on_read_ogg); - if (oggbs->onRead == drflac__on_read_stdio) { - fclose((FILE*)oggbs->pUserData); - } - } -#endif -#endif - drflac__free_from_callbacks(pFlac, &pFlac->allocationCallbacks); -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_left_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - for (i = 0; i < frameCount; ++i) { - drflac_uint32 left = (drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - drflac_uint32 side = (drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_left_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 left0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 left1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 left2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 left3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << shift1; - drflac_uint32 right0 = left0 - side0; - drflac_uint32 right1 = left1 - side1; - drflac_uint32 right2 = left2 - side2; - drflac_uint32 right3 = left3 - side3; - pOutputSamples[i*8+0] = (drflac_int32)left0; - pOutputSamples[i*8+1] = (drflac_int32)right0; - pOutputSamples[i*8+2] = (drflac_int32)left1; - pOutputSamples[i*8+3] = (drflac_int32)right1; - pOutputSamples[i*8+4] = (drflac_int32)left2; - pOutputSamples[i*8+5] = (drflac_int32)right2; - pOutputSamples[i*8+6] = (drflac_int32)left3; - pOutputSamples[i*8+7] = (drflac_int32)right3; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_left_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - for (i = 0; i < frameCount4; ++i) { - __m128i left = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - __m128i right = _mm_sub_epi32(left, side); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 0), _mm_unpacklo_epi32(left, right)); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 4), _mm_unpackhi_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_left_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - int32x4_t shift0_4; - int32x4_t shift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - shift0_4 = vdupq_n_s32(shift0); - shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t left; - uint32x4_t side; - uint32x4_t right; - left = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4); - right = vsubq_u32(left, side); - drflac__vst2q_u32((drflac_uint32*)pOutputSamples + i*8, vzipq_u32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_left_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_left_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_left_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s32__decode_left_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s32__decode_left_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_right_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - for (i = 0; i < frameCount; ++i) { - drflac_uint32 side = (drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - drflac_uint32 right = (drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_right_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 side0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 side1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 side2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 side3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 right0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 right1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 right2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 right3 = pInputSamples1U32[i*4+3] << shift1; - drflac_uint32 left0 = right0 + side0; - drflac_uint32 left1 = right1 + side1; - drflac_uint32 left2 = right2 + side2; - drflac_uint32 left3 = right3 + side3; - pOutputSamples[i*8+0] = (drflac_int32)left0; - pOutputSamples[i*8+1] = (drflac_int32)right0; - pOutputSamples[i*8+2] = (drflac_int32)left1; - pOutputSamples[i*8+3] = (drflac_int32)right1; - pOutputSamples[i*8+4] = (drflac_int32)left2; - pOutputSamples[i*8+5] = (drflac_int32)right2; - pOutputSamples[i*8+6] = (drflac_int32)left3; - pOutputSamples[i*8+7] = (drflac_int32)right3; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_right_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - for (i = 0; i < frameCount4; ++i) { - __m128i side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i right = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - __m128i left = _mm_add_epi32(right, side); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 0), _mm_unpacklo_epi32(left, right)); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 4), _mm_unpackhi_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_right_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - int32x4_t shift0_4; - int32x4_t shift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - shift0_4 = vdupq_n_s32(shift0); - shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t side; - uint32x4_t right; - uint32x4_t left; - side = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4); - right = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4); - left = vaddq_u32(right, side); - drflac__vst2q_u32((drflac_uint32*)pOutputSamples + i*8, vzipq_u32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left; - pOutputSamples[i*2+1] = (drflac_int32)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_right_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_right_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_right_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s32__decode_right_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s32__decode_right_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_mid_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - for (drflac_uint64 i = 0; i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((drflac_uint32)((drflac_int32)(mid + side) >> 1) << unusedBitsPerSample); - pOutputSamples[i*2+1] = (drflac_int32)((drflac_uint32)((drflac_int32)(mid - side) >> 1) << unusedBitsPerSample); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_mid_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_int32 shift = unusedBitsPerSample; - if (shift > 0) { - shift -= 1; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 temp0L; - drflac_uint32 temp1L; - drflac_uint32 temp2L; - drflac_uint32 temp3L; - drflac_uint32 temp0R; - drflac_uint32 temp1R; - drflac_uint32 temp2R; - drflac_uint32 temp3R; - drflac_uint32 mid0 = pInputSamples0U32[i*4+0] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid1 = pInputSamples0U32[i*4+1] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid2 = pInputSamples0U32[i*4+2] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid3 = pInputSamples0U32[i*4+3] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid0 = (mid0 << 1) | (side0 & 0x01); - mid1 = (mid1 << 1) | (side1 & 0x01); - mid2 = (mid2 << 1) | (side2 & 0x01); - mid3 = (mid3 << 1) | (side3 & 0x01); - temp0L = (mid0 + side0) << shift; - temp1L = (mid1 + side1) << shift; - temp2L = (mid2 + side2) << shift; - temp3L = (mid3 + side3) << shift; - temp0R = (mid0 - side0) << shift; - temp1R = (mid1 - side1) << shift; - temp2R = (mid2 - side2) << shift; - temp3R = (mid3 - side3) << shift; - pOutputSamples[i*8+0] = (drflac_int32)temp0L; - pOutputSamples[i*8+1] = (drflac_int32)temp0R; - pOutputSamples[i*8+2] = (drflac_int32)temp1L; - pOutputSamples[i*8+3] = (drflac_int32)temp1R; - pOutputSamples[i*8+4] = (drflac_int32)temp2L; - pOutputSamples[i*8+5] = (drflac_int32)temp2R; - pOutputSamples[i*8+6] = (drflac_int32)temp3L; - pOutputSamples[i*8+7] = (drflac_int32)temp3R; - } - } else { - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 temp0L; - drflac_uint32 temp1L; - drflac_uint32 temp2L; - drflac_uint32 temp3L; - drflac_uint32 temp0R; - drflac_uint32 temp1R; - drflac_uint32 temp2R; - drflac_uint32 temp3R; - drflac_uint32 mid0 = pInputSamples0U32[i*4+0] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid1 = pInputSamples0U32[i*4+1] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid2 = pInputSamples0U32[i*4+2] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid3 = pInputSamples0U32[i*4+3] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid0 = (mid0 << 1) | (side0 & 0x01); - mid1 = (mid1 << 1) | (side1 & 0x01); - mid2 = (mid2 << 1) | (side2 & 0x01); - mid3 = (mid3 << 1) | (side3 & 0x01); - temp0L = (drflac_uint32)((drflac_int32)(mid0 + side0) >> 1); - temp1L = (drflac_uint32)((drflac_int32)(mid1 + side1) >> 1); - temp2L = (drflac_uint32)((drflac_int32)(mid2 + side2) >> 1); - temp3L = (drflac_uint32)((drflac_int32)(mid3 + side3) >> 1); - temp0R = (drflac_uint32)((drflac_int32)(mid0 - side0) >> 1); - temp1R = (drflac_uint32)((drflac_int32)(mid1 - side1) >> 1); - temp2R = (drflac_uint32)((drflac_int32)(mid2 - side2) >> 1); - temp3R = (drflac_uint32)((drflac_int32)(mid3 - side3) >> 1); - pOutputSamples[i*8+0] = (drflac_int32)temp0L; - pOutputSamples[i*8+1] = (drflac_int32)temp0R; - pOutputSamples[i*8+2] = (drflac_int32)temp1L; - pOutputSamples[i*8+3] = (drflac_int32)temp1R; - pOutputSamples[i*8+4] = (drflac_int32)temp2L; - pOutputSamples[i*8+5] = (drflac_int32)temp2R; - pOutputSamples[i*8+6] = (drflac_int32)temp3L; - pOutputSamples[i*8+7] = (drflac_int32)temp3R; - } - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((drflac_uint32)((drflac_int32)(mid + side) >> 1) << unusedBitsPerSample); - pOutputSamples[i*2+1] = (drflac_int32)((drflac_uint32)((drflac_int32)(mid - side) >> 1) << unusedBitsPerSample); - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_mid_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_int32 shift = unusedBitsPerSample; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - if (shift == 0) { - for (i = 0; i < frameCount4; ++i) { - __m128i mid; - __m128i side; - __m128i left; - __m128i right; - mid = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - mid = _mm_or_si128(_mm_slli_epi32(mid, 1), _mm_and_si128(side, _mm_set1_epi32(0x01))); - left = _mm_srai_epi32(_mm_add_epi32(mid, side), 1); - right = _mm_srai_epi32(_mm_sub_epi32(mid, side), 1); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 0), _mm_unpacklo_epi32(left, right)); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 4), _mm_unpackhi_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)(mid + side) >> 1; - pOutputSamples[i*2+1] = (drflac_int32)(mid - side) >> 1; - } - } else { - shift -= 1; - for (i = 0; i < frameCount4; ++i) { - __m128i mid; - __m128i side; - __m128i left; - __m128i right; - mid = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - mid = _mm_or_si128(_mm_slli_epi32(mid, 1), _mm_and_si128(side, _mm_set1_epi32(0x01))); - left = _mm_slli_epi32(_mm_add_epi32(mid, side), shift); - right = _mm_slli_epi32(_mm_sub_epi32(mid, side), shift); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 0), _mm_unpacklo_epi32(left, right)); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 4), _mm_unpackhi_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((mid + side) << shift); - pOutputSamples[i*2+1] = (drflac_int32)((mid - side) << shift); - } - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_mid_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_int32 shift = unusedBitsPerSample; - int32x4_t wbpsShift0_4; - int32x4_t wbpsShift1_4; - uint32x4_t one4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - wbpsShift0_4 = vdupq_n_s32(pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - wbpsShift1_4 = vdupq_n_s32(pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - one4 = vdupq_n_u32(1); - if (shift == 0) { - for (i = 0; i < frameCount4; ++i) { - uint32x4_t mid; - uint32x4_t side; - int32x4_t left; - int32x4_t right; - mid = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), wbpsShift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), wbpsShift1_4); - mid = vorrq_u32(vshlq_n_u32(mid, 1), vandq_u32(side, one4)); - left = vshrq_n_s32(vreinterpretq_s32_u32(vaddq_u32(mid, side)), 1); - right = vshrq_n_s32(vreinterpretq_s32_u32(vsubq_u32(mid, side)), 1); - drflac__vst2q_s32(pOutputSamples + i*8, vzipq_s32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)(mid + side) >> 1; - pOutputSamples[i*2+1] = (drflac_int32)(mid - side) >> 1; - } - } else { - int32x4_t shift4; - shift -= 1; - shift4 = vdupq_n_s32(shift); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t mid; - uint32x4_t side; - int32x4_t left; - int32x4_t right; - mid = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), wbpsShift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), wbpsShift1_4); - mid = vorrq_u32(vshlq_n_u32(mid, 1), vandq_u32(side, one4)); - left = vreinterpretq_s32_u32(vshlq_u32(vaddq_u32(mid, side), shift4)); - right = vreinterpretq_s32_u32(vshlq_u32(vsubq_u32(mid, side), shift4)); - drflac__vst2q_s32(pOutputSamples + i*8, vzipq_s32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((mid + side) << shift); - pOutputSamples[i*2+1] = (drflac_int32)((mid - side) << shift); - } - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_mid_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_mid_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_mid_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s32__decode_mid_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s32__decode_mid_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_independent_stereo__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - for (drflac_uint64 i = 0; i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)((drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample)); - pOutputSamples[i*2+1] = (drflac_int32)((drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample)); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_independent_stereo__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 tempL0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 tempL1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 tempL2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 tempL3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 tempR0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 tempR1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 tempR2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 tempR3 = pInputSamples1U32[i*4+3] << shift1; - pOutputSamples[i*8+0] = (drflac_int32)tempL0; - pOutputSamples[i*8+1] = (drflac_int32)tempR0; - pOutputSamples[i*8+2] = (drflac_int32)tempL1; - pOutputSamples[i*8+3] = (drflac_int32)tempR1; - pOutputSamples[i*8+4] = (drflac_int32)tempL2; - pOutputSamples[i*8+5] = (drflac_int32)tempR2; - pOutputSamples[i*8+6] = (drflac_int32)tempL3; - pOutputSamples[i*8+7] = (drflac_int32)tempR3; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)(pInputSamples0U32[i] << shift0); - pOutputSamples[i*2+1] = (drflac_int32)(pInputSamples1U32[i] << shift1); - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_independent_stereo__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - __m128i left = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i right = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 0), _mm_unpacklo_epi32(left, right)); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8 + 4), _mm_unpackhi_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)(pInputSamples0U32[i] << shift0); - pOutputSamples[i*2+1] = (drflac_int32)(pInputSamples1U32[i] << shift1); - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_independent_stereo__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - int32x4_t shift4_0 = vdupq_n_s32(shift0); - int32x4_t shift4_1 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - int32x4_t left; - int32x4_t right; - left = vreinterpretq_s32_u32(vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift4_0)); - right = vreinterpretq_s32_u32(vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift4_1)); - drflac__vst2q_s32(pOutputSamples + i*8, vzipq_s32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)(pInputSamples0U32[i] << shift0); - pOutputSamples[i*2+1] = (drflac_int32)(pInputSamples1U32[i] << shift1); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s32__decode_independent_stereo(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int32* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_independent_stereo__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s32__decode_independent_stereo__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s32__decode_independent_stereo__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s32__decode_independent_stereo__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -DRFLAC_API drflac_uint64 drflac_read_pcm_frames_s32(drflac* pFlac, drflac_uint64 framesToRead, drflac_int32* pBufferOut) -{ - drflac_uint64 framesRead; - drflac_uint32 unusedBitsPerSample; - if (pFlac == NULL || framesToRead == 0) { - return 0; - } - if (pBufferOut == NULL) { - return drflac__seek_forward_by_pcm_frames(pFlac, framesToRead); - } - DRFLAC_ASSERT(pFlac->bitsPerSample <= 32); - unusedBitsPerSample = 32 - pFlac->bitsPerSample; - framesRead = 0; - while (framesToRead > 0) { - if (pFlac->currentFLACFrame.pcmFramesRemaining == 0) { - if (!drflac__read_and_decode_next_flac_frame(pFlac)) { - break; - } - } else { - unsigned int channelCount = drflac__get_channel_count_from_channel_assignment(pFlac->currentFLACFrame.header.channelAssignment); - drflac_uint64 iFirstPCMFrame = pFlac->currentFLACFrame.header.blockSizeInPCMFrames - pFlac->currentFLACFrame.pcmFramesRemaining; - drflac_uint64 frameCountThisIteration = framesToRead; - if (frameCountThisIteration > pFlac->currentFLACFrame.pcmFramesRemaining) { - frameCountThisIteration = pFlac->currentFLACFrame.pcmFramesRemaining; - } - if (channelCount == 2) { - const drflac_int32* pDecodedSamples0 = pFlac->currentFLACFrame.subframes[0].pSamplesS32 + iFirstPCMFrame; - const drflac_int32* pDecodedSamples1 = pFlac->currentFLACFrame.subframes[1].pSamplesS32 + iFirstPCMFrame; - switch (pFlac->currentFLACFrame.header.channelAssignment) - { - case DRFLAC_CHANNEL_ASSIGNMENT_LEFT_SIDE: - { - drflac_read_pcm_frames_s32__decode_left_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_RIGHT_SIDE: - { - drflac_read_pcm_frames_s32__decode_right_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_MID_SIDE: - { - drflac_read_pcm_frames_s32__decode_mid_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_INDEPENDENT: - default: - { - drflac_read_pcm_frames_s32__decode_independent_stereo(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - } - } else { - drflac_uint64 i; - for (i = 0; i < frameCountThisIteration; ++i) { - unsigned int j; - for (j = 0; j < channelCount; ++j) { - pBufferOut[(i*channelCount)+j] = (drflac_int32)((drflac_uint32)(pFlac->currentFLACFrame.subframes[j].pSamplesS32[iFirstPCMFrame + i]) << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[j].wastedBitsPerSample)); - } - } - } - framesRead += frameCountThisIteration; - pBufferOut += frameCountThisIteration * channelCount; - framesToRead -= frameCountThisIteration; - pFlac->currentPCMFrame += frameCountThisIteration; - pFlac->currentFLACFrame.pcmFramesRemaining -= (drflac_uint32)frameCountThisIteration; - } - } - return framesRead; -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_left_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - for (i = 0; i < frameCount; ++i) { - drflac_uint32 left = (drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - drflac_uint32 side = (drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - drflac_uint32 right = left - side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_left_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 left0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 left1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 left2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 left3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << shift1; - drflac_uint32 right0 = left0 - side0; - drflac_uint32 right1 = left1 - side1; - drflac_uint32 right2 = left2 - side2; - drflac_uint32 right3 = left3 - side3; - left0 >>= 16; - left1 >>= 16; - left2 >>= 16; - left3 >>= 16; - right0 >>= 16; - right1 >>= 16; - right2 >>= 16; - right3 >>= 16; - pOutputSamples[i*8+0] = (drflac_int16)left0; - pOutputSamples[i*8+1] = (drflac_int16)right0; - pOutputSamples[i*8+2] = (drflac_int16)left1; - pOutputSamples[i*8+3] = (drflac_int16)right1; - pOutputSamples[i*8+4] = (drflac_int16)left2; - pOutputSamples[i*8+5] = (drflac_int16)right2; - pOutputSamples[i*8+6] = (drflac_int16)left3; - pOutputSamples[i*8+7] = (drflac_int16)right3; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_left_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - for (i = 0; i < frameCount4; ++i) { - __m128i left = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - __m128i right = _mm_sub_epi32(left, side); - left = _mm_srai_epi32(left, 16); - right = _mm_srai_epi32(right, 16); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8), drflac__mm_packs_interleaved_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_left_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - int32x4_t shift0_4; - int32x4_t shift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - shift0_4 = vdupq_n_s32(shift0); - shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t left; - uint32x4_t side; - uint32x4_t right; - left = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4); - right = vsubq_u32(left, side); - left = vshrq_n_u32(left, 16); - right = vshrq_n_u32(right, 16); - drflac__vst2q_u16((drflac_uint16*)pOutputSamples + i*8, vzip_u16(vmovn_u32(left), vmovn_u32(right))); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_left_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_left_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_left_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s16__decode_left_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s16__decode_left_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_right_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - for (i = 0; i < frameCount; ++i) { - drflac_uint32 side = (drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - drflac_uint32 right = (drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - drflac_uint32 left = right + side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_right_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 side0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 side1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 side2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 side3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 right0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 right1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 right2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 right3 = pInputSamples1U32[i*4+3] << shift1; - drflac_uint32 left0 = right0 + side0; - drflac_uint32 left1 = right1 + side1; - drflac_uint32 left2 = right2 + side2; - drflac_uint32 left3 = right3 + side3; - left0 >>= 16; - left1 >>= 16; - left2 >>= 16; - left3 >>= 16; - right0 >>= 16; - right1 >>= 16; - right2 >>= 16; - right3 >>= 16; - pOutputSamples[i*8+0] = (drflac_int16)left0; - pOutputSamples[i*8+1] = (drflac_int16)right0; - pOutputSamples[i*8+2] = (drflac_int16)left1; - pOutputSamples[i*8+3] = (drflac_int16)right1; - pOutputSamples[i*8+4] = (drflac_int16)left2; - pOutputSamples[i*8+5] = (drflac_int16)right2; - pOutputSamples[i*8+6] = (drflac_int16)left3; - pOutputSamples[i*8+7] = (drflac_int16)right3; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_right_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - for (i = 0; i < frameCount4; ++i) { - __m128i side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i right = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - __m128i left = _mm_add_epi32(right, side); - left = _mm_srai_epi32(left, 16); - right = _mm_srai_epi32(right, 16); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8), drflac__mm_packs_interleaved_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_right_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - int32x4_t shift0_4; - int32x4_t shift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - shift0_4 = vdupq_n_s32(shift0); - shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t side; - uint32x4_t right; - uint32x4_t left; - side = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4); - right = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4); - left = vaddq_u32(right, side); - left = vshrq_n_u32(left, 16); - right = vshrq_n_u32(right, 16); - drflac__vst2q_u16((drflac_uint16*)pOutputSamples + i*8, vzip_u16(vmovn_u32(left), vmovn_u32(right))); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - left >>= 16; - right >>= 16; - pOutputSamples[i*2+0] = (drflac_int16)left; - pOutputSamples[i*2+1] = (drflac_int16)right; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_right_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_right_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_right_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s16__decode_right_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s16__decode_right_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_mid_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - for (drflac_uint64 i = 0; i < frameCount; ++i) { - drflac_uint32 mid = (drflac_uint32)pInputSamples0[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = (drflac_uint32)pInputSamples1[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int16)(((drflac_uint32)((drflac_int32)(mid + side) >> 1) << unusedBitsPerSample) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)(((drflac_uint32)((drflac_int32)(mid - side) >> 1) << unusedBitsPerSample) >> 16); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_mid_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift = unusedBitsPerSample; - if (shift > 0) { - shift -= 1; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 temp0L; - drflac_uint32 temp1L; - drflac_uint32 temp2L; - drflac_uint32 temp3L; - drflac_uint32 temp0R; - drflac_uint32 temp1R; - drflac_uint32 temp2R; - drflac_uint32 temp3R; - drflac_uint32 mid0 = pInputSamples0U32[i*4+0] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid1 = pInputSamples0U32[i*4+1] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid2 = pInputSamples0U32[i*4+2] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid3 = pInputSamples0U32[i*4+3] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid0 = (mid0 << 1) | (side0 & 0x01); - mid1 = (mid1 << 1) | (side1 & 0x01); - mid2 = (mid2 << 1) | (side2 & 0x01); - mid3 = (mid3 << 1) | (side3 & 0x01); - temp0L = (mid0 + side0) << shift; - temp1L = (mid1 + side1) << shift; - temp2L = (mid2 + side2) << shift; - temp3L = (mid3 + side3) << shift; - temp0R = (mid0 - side0) << shift; - temp1R = (mid1 - side1) << shift; - temp2R = (mid2 - side2) << shift; - temp3R = (mid3 - side3) << shift; - temp0L >>= 16; - temp1L >>= 16; - temp2L >>= 16; - temp3L >>= 16; - temp0R >>= 16; - temp1R >>= 16; - temp2R >>= 16; - temp3R >>= 16; - pOutputSamples[i*8+0] = (drflac_int16)temp0L; - pOutputSamples[i*8+1] = (drflac_int16)temp0R; - pOutputSamples[i*8+2] = (drflac_int16)temp1L; - pOutputSamples[i*8+3] = (drflac_int16)temp1R; - pOutputSamples[i*8+4] = (drflac_int16)temp2L; - pOutputSamples[i*8+5] = (drflac_int16)temp2R; - pOutputSamples[i*8+6] = (drflac_int16)temp3L; - pOutputSamples[i*8+7] = (drflac_int16)temp3R; - } - } else { - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 temp0L; - drflac_uint32 temp1L; - drflac_uint32 temp2L; - drflac_uint32 temp3L; - drflac_uint32 temp0R; - drflac_uint32 temp1R; - drflac_uint32 temp2R; - drflac_uint32 temp3R; - drflac_uint32 mid0 = pInputSamples0U32[i*4+0] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid1 = pInputSamples0U32[i*4+1] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid2 = pInputSamples0U32[i*4+2] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid3 = pInputSamples0U32[i*4+3] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid0 = (mid0 << 1) | (side0 & 0x01); - mid1 = (mid1 << 1) | (side1 & 0x01); - mid2 = (mid2 << 1) | (side2 & 0x01); - mid3 = (mid3 << 1) | (side3 & 0x01); - temp0L = ((drflac_int32)(mid0 + side0) >> 1); - temp1L = ((drflac_int32)(mid1 + side1) >> 1); - temp2L = ((drflac_int32)(mid2 + side2) >> 1); - temp3L = ((drflac_int32)(mid3 + side3) >> 1); - temp0R = ((drflac_int32)(mid0 - side0) >> 1); - temp1R = ((drflac_int32)(mid1 - side1) >> 1); - temp2R = ((drflac_int32)(mid2 - side2) >> 1); - temp3R = ((drflac_int32)(mid3 - side3) >> 1); - temp0L >>= 16; - temp1L >>= 16; - temp2L >>= 16; - temp3L >>= 16; - temp0R >>= 16; - temp1R >>= 16; - temp2R >>= 16; - temp3R >>= 16; - pOutputSamples[i*8+0] = (drflac_int16)temp0L; - pOutputSamples[i*8+1] = (drflac_int16)temp0R; - pOutputSamples[i*8+2] = (drflac_int16)temp1L; - pOutputSamples[i*8+3] = (drflac_int16)temp1R; - pOutputSamples[i*8+4] = (drflac_int16)temp2L; - pOutputSamples[i*8+5] = (drflac_int16)temp2R; - pOutputSamples[i*8+6] = (drflac_int16)temp3L; - pOutputSamples[i*8+7] = (drflac_int16)temp3R; - } - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int16)(((drflac_uint32)((drflac_int32)(mid + side) >> 1) << unusedBitsPerSample) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)(((drflac_uint32)((drflac_int32)(mid - side) >> 1) << unusedBitsPerSample) >> 16); - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_mid_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift = unusedBitsPerSample; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - if (shift == 0) { - for (i = 0; i < frameCount4; ++i) { - __m128i mid; - __m128i side; - __m128i left; - __m128i right; - mid = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - mid = _mm_or_si128(_mm_slli_epi32(mid, 1), _mm_and_si128(side, _mm_set1_epi32(0x01))); - left = _mm_srai_epi32(_mm_add_epi32(mid, side), 1); - right = _mm_srai_epi32(_mm_sub_epi32(mid, side), 1); - left = _mm_srai_epi32(left, 16); - right = _mm_srai_epi32(right, 16); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8), drflac__mm_packs_interleaved_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int16)(((drflac_int32)(mid + side) >> 1) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)(((drflac_int32)(mid - side) >> 1) >> 16); - } - } else { - shift -= 1; - for (i = 0; i < frameCount4; ++i) { - __m128i mid; - __m128i side; - __m128i left; - __m128i right; - mid = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - mid = _mm_or_si128(_mm_slli_epi32(mid, 1), _mm_and_si128(side, _mm_set1_epi32(0x01))); - left = _mm_slli_epi32(_mm_add_epi32(mid, side), shift); - right = _mm_slli_epi32(_mm_sub_epi32(mid, side), shift); - left = _mm_srai_epi32(left, 16); - right = _mm_srai_epi32(right, 16); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8), drflac__mm_packs_interleaved_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int16)(((mid + side) << shift) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)(((mid - side) << shift) >> 16); - } - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_mid_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift = unusedBitsPerSample; - int32x4_t wbpsShift0_4; - int32x4_t wbpsShift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - wbpsShift0_4 = vdupq_n_s32(pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - wbpsShift1_4 = vdupq_n_s32(pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - if (shift == 0) { - for (i = 0; i < frameCount4; ++i) { - uint32x4_t mid; - uint32x4_t side; - int32x4_t left; - int32x4_t right; - mid = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), wbpsShift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), wbpsShift1_4); - mid = vorrq_u32(vshlq_n_u32(mid, 1), vandq_u32(side, vdupq_n_u32(1))); - left = vshrq_n_s32(vreinterpretq_s32_u32(vaddq_u32(mid, side)), 1); - right = vshrq_n_s32(vreinterpretq_s32_u32(vsubq_u32(mid, side)), 1); - left = vshrq_n_s32(left, 16); - right = vshrq_n_s32(right, 16); - drflac__vst2q_s16(pOutputSamples + i*8, vzip_s16(vmovn_s32(left), vmovn_s32(right))); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int16)(((drflac_int32)(mid + side) >> 1) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)(((drflac_int32)(mid - side) >> 1) >> 16); - } - } else { - int32x4_t shift4; - shift -= 1; - shift4 = vdupq_n_s32(shift); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t mid; - uint32x4_t side; - int32x4_t left; - int32x4_t right; - mid = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), wbpsShift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), wbpsShift1_4); - mid = vorrq_u32(vshlq_n_u32(mid, 1), vandq_u32(side, vdupq_n_u32(1))); - left = vreinterpretq_s32_u32(vshlq_u32(vaddq_u32(mid, side), shift4)); - right = vreinterpretq_s32_u32(vshlq_u32(vsubq_u32(mid, side), shift4)); - left = vshrq_n_s32(left, 16); - right = vshrq_n_s32(right, 16); - drflac__vst2q_s16(pOutputSamples + i*8, vzip_s16(vmovn_s32(left), vmovn_s32(right))); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int16)(((mid + side) << shift) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)(((mid - side) << shift) >> 16); - } - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_mid_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_mid_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_mid_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s16__decode_mid_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s16__decode_mid_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_independent_stereo__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - for (drflac_uint64 i = 0; i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int16)((drflac_int32)((drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample)) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)((drflac_int32)((drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample)) >> 16); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_independent_stereo__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 tempL0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 tempL1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 tempL2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 tempL3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 tempR0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 tempR1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 tempR2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 tempR3 = pInputSamples1U32[i*4+3] << shift1; - tempL0 >>= 16; - tempL1 >>= 16; - tempL2 >>= 16; - tempL3 >>= 16; - tempR0 >>= 16; - tempR1 >>= 16; - tempR2 >>= 16; - tempR3 >>= 16; - pOutputSamples[i*8+0] = (drflac_int16)tempL0; - pOutputSamples[i*8+1] = (drflac_int16)tempR0; - pOutputSamples[i*8+2] = (drflac_int16)tempL1; - pOutputSamples[i*8+3] = (drflac_int16)tempR1; - pOutputSamples[i*8+4] = (drflac_int16)tempL2; - pOutputSamples[i*8+5] = (drflac_int16)tempR2; - pOutputSamples[i*8+6] = (drflac_int16)tempL3; - pOutputSamples[i*8+7] = (drflac_int16)tempR3; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int16)((pInputSamples0U32[i] << shift0) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)((pInputSamples1U32[i] << shift1) >> 16); - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_independent_stereo__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - for (i = 0; i < frameCount4; ++i) { - __m128i left = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i right = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - left = _mm_srai_epi32(left, 16); - right = _mm_srai_epi32(right, 16); - _mm_storeu_si128((__m128i*)(pOutputSamples + i*8), drflac__mm_packs_interleaved_epi32(left, right)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int16)((pInputSamples0U32[i] << shift0) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)((pInputSamples1U32[i] << shift1) >> 16); - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_independent_stereo__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - int32x4_t shift0_4 = vdupq_n_s32(shift0); - int32x4_t shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - int32x4_t left; - int32x4_t right; - left = vreinterpretq_s32_u32(vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4)); - right = vreinterpretq_s32_u32(vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4)); - left = vshrq_n_s32(left, 16); - right = vshrq_n_s32(right, 16); - drflac__vst2q_s16(pOutputSamples + i*8, vzip_s16(vmovn_s32(left), vmovn_s32(right))); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int16)((pInputSamples0U32[i] << shift0) >> 16); - pOutputSamples[i*2+1] = (drflac_int16)((pInputSamples1U32[i] << shift1) >> 16); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_s16__decode_independent_stereo(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, drflac_int16* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_independent_stereo__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_s16__decode_independent_stereo__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_s16__decode_independent_stereo__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_s16__decode_independent_stereo__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -DRFLAC_API drflac_uint64 drflac_read_pcm_frames_s16(drflac* pFlac, drflac_uint64 framesToRead, drflac_int16* pBufferOut) -{ - drflac_uint64 framesRead; - drflac_uint32 unusedBitsPerSample; - if (pFlac == NULL || framesToRead == 0) { - return 0; - } - if (pBufferOut == NULL) { - return drflac__seek_forward_by_pcm_frames(pFlac, framesToRead); - } - DRFLAC_ASSERT(pFlac->bitsPerSample <= 32); - unusedBitsPerSample = 32 - pFlac->bitsPerSample; - framesRead = 0; - while (framesToRead > 0) { - if (pFlac->currentFLACFrame.pcmFramesRemaining == 0) { - if (!drflac__read_and_decode_next_flac_frame(pFlac)) { - break; - } - } else { - unsigned int channelCount = drflac__get_channel_count_from_channel_assignment(pFlac->currentFLACFrame.header.channelAssignment); - drflac_uint64 iFirstPCMFrame = pFlac->currentFLACFrame.header.blockSizeInPCMFrames - pFlac->currentFLACFrame.pcmFramesRemaining; - drflac_uint64 frameCountThisIteration = framesToRead; - if (frameCountThisIteration > pFlac->currentFLACFrame.pcmFramesRemaining) { - frameCountThisIteration = pFlac->currentFLACFrame.pcmFramesRemaining; - } - if (channelCount == 2) { - const drflac_int32* pDecodedSamples0 = pFlac->currentFLACFrame.subframes[0].pSamplesS32 + iFirstPCMFrame; - const drflac_int32* pDecodedSamples1 = pFlac->currentFLACFrame.subframes[1].pSamplesS32 + iFirstPCMFrame; - switch (pFlac->currentFLACFrame.header.channelAssignment) - { - case DRFLAC_CHANNEL_ASSIGNMENT_LEFT_SIDE: - { - drflac_read_pcm_frames_s16__decode_left_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_RIGHT_SIDE: - { - drflac_read_pcm_frames_s16__decode_right_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_MID_SIDE: - { - drflac_read_pcm_frames_s16__decode_mid_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_INDEPENDENT: - default: - { - drflac_read_pcm_frames_s16__decode_independent_stereo(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - } - } else { - drflac_uint64 i; - for (i = 0; i < frameCountThisIteration; ++i) { - unsigned int j; - for (j = 0; j < channelCount; ++j) { - drflac_int32 sampleS32 = (drflac_int32)((drflac_uint32)(pFlac->currentFLACFrame.subframes[j].pSamplesS32[iFirstPCMFrame + i]) << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[j].wastedBitsPerSample)); - pBufferOut[(i*channelCount)+j] = (drflac_int16)(sampleS32 >> 16); - } - } - } - framesRead += frameCountThisIteration; - pBufferOut += frameCountThisIteration * channelCount; - framesToRead -= frameCountThisIteration; - pFlac->currentPCMFrame += frameCountThisIteration; - pFlac->currentFLACFrame.pcmFramesRemaining -= (drflac_uint32)frameCountThisIteration; - } - } - return framesRead; -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_left_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - for (i = 0; i < frameCount; ++i) { - drflac_uint32 left = (drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - drflac_uint32 side = (drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (float)((drflac_int32)left / 2147483648.0); - pOutputSamples[i*2+1] = (float)((drflac_int32)right / 2147483648.0); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_left_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - float factor = 1 / 2147483648.0; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 left0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 left1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 left2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 left3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << shift1; - drflac_uint32 right0 = left0 - side0; - drflac_uint32 right1 = left1 - side1; - drflac_uint32 right2 = left2 - side2; - drflac_uint32 right3 = left3 - side3; - pOutputSamples[i*8+0] = (drflac_int32)left0 * factor; - pOutputSamples[i*8+1] = (drflac_int32)right0 * factor; - pOutputSamples[i*8+2] = (drflac_int32)left1 * factor; - pOutputSamples[i*8+3] = (drflac_int32)right1 * factor; - pOutputSamples[i*8+4] = (drflac_int32)left2 * factor; - pOutputSamples[i*8+5] = (drflac_int32)right2 * factor; - pOutputSamples[i*8+6] = (drflac_int32)left3 * factor; - pOutputSamples[i*8+7] = (drflac_int32)right3 * factor; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left * factor; - pOutputSamples[i*2+1] = (drflac_int32)right * factor; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_left_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample) - 8; - drflac_uint32 shift1 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample) - 8; - __m128 factor; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - factor = _mm_set1_ps(1.0f / 8388608.0f); - for (i = 0; i < frameCount4; ++i) { - __m128i left = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - __m128i right = _mm_sub_epi32(left, side); - __m128 leftf = _mm_mul_ps(_mm_cvtepi32_ps(left), factor); - __m128 rightf = _mm_mul_ps(_mm_cvtepi32_ps(right), factor); - _mm_storeu_ps(pOutputSamples + i*8 + 0, _mm_unpacklo_ps(leftf, rightf)); - _mm_storeu_ps(pOutputSamples + i*8 + 4, _mm_unpackhi_ps(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left / 8388608.0f; - pOutputSamples[i*2+1] = (drflac_int32)right / 8388608.0f; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_left_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample) - 8; - drflac_uint32 shift1 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample) - 8; - float32x4_t factor4; - int32x4_t shift0_4; - int32x4_t shift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - factor4 = vdupq_n_f32(1.0f / 8388608.0f); - shift0_4 = vdupq_n_s32(shift0); - shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t left; - uint32x4_t side; - uint32x4_t right; - float32x4_t leftf; - float32x4_t rightf; - left = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4); - right = vsubq_u32(left, side); - leftf = vmulq_f32(vcvtq_f32_s32(vreinterpretq_s32_u32(left)), factor4); - rightf = vmulq_f32(vcvtq_f32_s32(vreinterpretq_s32_u32(right)), factor4); - drflac__vst2q_f32(pOutputSamples + i*8, vzipq_f32(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 left = pInputSamples0U32[i] << shift0; - drflac_uint32 side = pInputSamples1U32[i] << shift1; - drflac_uint32 right = left - side; - pOutputSamples[i*2+0] = (drflac_int32)left / 8388608.0f; - pOutputSamples[i*2+1] = (drflac_int32)right / 8388608.0f; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_left_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_left_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_left_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_f32__decode_left_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_f32__decode_left_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_right_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - for (i = 0; i < frameCount; ++i) { - drflac_uint32 side = (drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - drflac_uint32 right = (drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (float)((drflac_int32)left / 2147483648.0); - pOutputSamples[i*2+1] = (float)((drflac_int32)right / 2147483648.0); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_right_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - float factor = 1 / 2147483648.0; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 side0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 side1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 side2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 side3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 right0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 right1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 right2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 right3 = pInputSamples1U32[i*4+3] << shift1; - drflac_uint32 left0 = right0 + side0; - drflac_uint32 left1 = right1 + side1; - drflac_uint32 left2 = right2 + side2; - drflac_uint32 left3 = right3 + side3; - pOutputSamples[i*8+0] = (drflac_int32)left0 * factor; - pOutputSamples[i*8+1] = (drflac_int32)right0 * factor; - pOutputSamples[i*8+2] = (drflac_int32)left1 * factor; - pOutputSamples[i*8+3] = (drflac_int32)right1 * factor; - pOutputSamples[i*8+4] = (drflac_int32)left2 * factor; - pOutputSamples[i*8+5] = (drflac_int32)right2 * factor; - pOutputSamples[i*8+6] = (drflac_int32)left3 * factor; - pOutputSamples[i*8+7] = (drflac_int32)right3 * factor; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left * factor; - pOutputSamples[i*2+1] = (drflac_int32)right * factor; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_right_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample) - 8; - drflac_uint32 shift1 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample) - 8; - __m128 factor; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - factor = _mm_set1_ps(1.0f / 8388608.0f); - for (i = 0; i < frameCount4; ++i) { - __m128i side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - __m128i right = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - __m128i left = _mm_add_epi32(right, side); - __m128 leftf = _mm_mul_ps(_mm_cvtepi32_ps(left), factor); - __m128 rightf = _mm_mul_ps(_mm_cvtepi32_ps(right), factor); - _mm_storeu_ps(pOutputSamples + i*8 + 0, _mm_unpacklo_ps(leftf, rightf)); - _mm_storeu_ps(pOutputSamples + i*8 + 4, _mm_unpackhi_ps(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left / 8388608.0f; - pOutputSamples[i*2+1] = (drflac_int32)right / 8388608.0f; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_right_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample) - 8; - drflac_uint32 shift1 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample) - 8; - float32x4_t factor4; - int32x4_t shift0_4; - int32x4_t shift1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - factor4 = vdupq_n_f32(1.0f / 8388608.0f); - shift0_4 = vdupq_n_s32(shift0); - shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t side; - uint32x4_t right; - uint32x4_t left; - float32x4_t leftf; - float32x4_t rightf; - side = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4); - right = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4); - left = vaddq_u32(right, side); - leftf = vmulq_f32(vcvtq_f32_s32(vreinterpretq_s32_u32(left)), factor4); - rightf = vmulq_f32(vcvtq_f32_s32(vreinterpretq_s32_u32(right)), factor4); - drflac__vst2q_f32(pOutputSamples + i*8, vzipq_f32(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 side = pInputSamples0U32[i] << shift0; - drflac_uint32 right = pInputSamples1U32[i] << shift1; - drflac_uint32 left = right + side; - pOutputSamples[i*2+0] = (drflac_int32)left / 8388608.0f; - pOutputSamples[i*2+1] = (drflac_int32)right / 8388608.0f; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_right_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_right_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_right_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_f32__decode_right_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_f32__decode_right_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_mid_side__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - for (drflac_uint64 i = 0; i < frameCount; ++i) { - drflac_uint32 mid = (drflac_uint32)pInputSamples0[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = (drflac_uint32)pInputSamples1[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (float)((((drflac_int32)(mid + side) >> 1) << (unusedBitsPerSample)) / 2147483648.0); - pOutputSamples[i*2+1] = (float)((((drflac_int32)(mid - side) >> 1) << (unusedBitsPerSample)) / 2147483648.0); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_mid_side__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift = unusedBitsPerSample; - float factor = 1 / 2147483648.0; - if (shift > 0) { - shift -= 1; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 temp0L; - drflac_uint32 temp1L; - drflac_uint32 temp2L; - drflac_uint32 temp3L; - drflac_uint32 temp0R; - drflac_uint32 temp1R; - drflac_uint32 temp2R; - drflac_uint32 temp3R; - drflac_uint32 mid0 = pInputSamples0U32[i*4+0] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid1 = pInputSamples0U32[i*4+1] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid2 = pInputSamples0U32[i*4+2] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid3 = pInputSamples0U32[i*4+3] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid0 = (mid0 << 1) | (side0 & 0x01); - mid1 = (mid1 << 1) | (side1 & 0x01); - mid2 = (mid2 << 1) | (side2 & 0x01); - mid3 = (mid3 << 1) | (side3 & 0x01); - temp0L = (mid0 + side0) << shift; - temp1L = (mid1 + side1) << shift; - temp2L = (mid2 + side2) << shift; - temp3L = (mid3 + side3) << shift; - temp0R = (mid0 - side0) << shift; - temp1R = (mid1 - side1) << shift; - temp2R = (mid2 - side2) << shift; - temp3R = (mid3 - side3) << shift; - pOutputSamples[i*8+0] = (drflac_int32)temp0L * factor; - pOutputSamples[i*8+1] = (drflac_int32)temp0R * factor; - pOutputSamples[i*8+2] = (drflac_int32)temp1L * factor; - pOutputSamples[i*8+3] = (drflac_int32)temp1R * factor; - pOutputSamples[i*8+4] = (drflac_int32)temp2L * factor; - pOutputSamples[i*8+5] = (drflac_int32)temp2R * factor; - pOutputSamples[i*8+6] = (drflac_int32)temp3L * factor; - pOutputSamples[i*8+7] = (drflac_int32)temp3R * factor; - } - } else { - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 temp0L; - drflac_uint32 temp1L; - drflac_uint32 temp2L; - drflac_uint32 temp3L; - drflac_uint32 temp0R; - drflac_uint32 temp1R; - drflac_uint32 temp2R; - drflac_uint32 temp3R; - drflac_uint32 mid0 = pInputSamples0U32[i*4+0] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid1 = pInputSamples0U32[i*4+1] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid2 = pInputSamples0U32[i*4+2] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 mid3 = pInputSamples0U32[i*4+3] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side0 = pInputSamples1U32[i*4+0] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side1 = pInputSamples1U32[i*4+1] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side2 = pInputSamples1U32[i*4+2] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - drflac_uint32 side3 = pInputSamples1U32[i*4+3] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid0 = (mid0 << 1) | (side0 & 0x01); - mid1 = (mid1 << 1) | (side1 & 0x01); - mid2 = (mid2 << 1) | (side2 & 0x01); - mid3 = (mid3 << 1) | (side3 & 0x01); - temp0L = (drflac_uint32)((drflac_int32)(mid0 + side0) >> 1); - temp1L = (drflac_uint32)((drflac_int32)(mid1 + side1) >> 1); - temp2L = (drflac_uint32)((drflac_int32)(mid2 + side2) >> 1); - temp3L = (drflac_uint32)((drflac_int32)(mid3 + side3) >> 1); - temp0R = (drflac_uint32)((drflac_int32)(mid0 - side0) >> 1); - temp1R = (drflac_uint32)((drflac_int32)(mid1 - side1) >> 1); - temp2R = (drflac_uint32)((drflac_int32)(mid2 - side2) >> 1); - temp3R = (drflac_uint32)((drflac_int32)(mid3 - side3) >> 1); - pOutputSamples[i*8+0] = (drflac_int32)temp0L * factor; - pOutputSamples[i*8+1] = (drflac_int32)temp0R * factor; - pOutputSamples[i*8+2] = (drflac_int32)temp1L * factor; - pOutputSamples[i*8+3] = (drflac_int32)temp1R * factor; - pOutputSamples[i*8+4] = (drflac_int32)temp2L * factor; - pOutputSamples[i*8+5] = (drflac_int32)temp2R * factor; - pOutputSamples[i*8+6] = (drflac_int32)temp3L * factor; - pOutputSamples[i*8+7] = (drflac_int32)temp3R * factor; - } - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((drflac_uint32)((drflac_int32)(mid + side) >> 1) << unusedBitsPerSample) * factor; - pOutputSamples[i*2+1] = (drflac_int32)((drflac_uint32)((drflac_int32)(mid - side) >> 1) << unusedBitsPerSample) * factor; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_mid_side__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift = unusedBitsPerSample - 8; - float factor; - __m128 factor128; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - factor = 1.0f / 8388608.0f; - factor128 = _mm_set1_ps(factor); - if (shift == 0) { - for (i = 0; i < frameCount4; ++i) { - __m128i mid; - __m128i side; - __m128i tempL; - __m128i tempR; - __m128 leftf; - __m128 rightf; - mid = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - mid = _mm_or_si128(_mm_slli_epi32(mid, 1), _mm_and_si128(side, _mm_set1_epi32(0x01))); - tempL = _mm_srai_epi32(_mm_add_epi32(mid, side), 1); - tempR = _mm_srai_epi32(_mm_sub_epi32(mid, side), 1); - leftf = _mm_mul_ps(_mm_cvtepi32_ps(tempL), factor128); - rightf = _mm_mul_ps(_mm_cvtepi32_ps(tempR), factor128); - _mm_storeu_ps(pOutputSamples + i*8 + 0, _mm_unpacklo_ps(leftf, rightf)); - _mm_storeu_ps(pOutputSamples + i*8 + 4, _mm_unpackhi_ps(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = ((drflac_int32)(mid + side) >> 1) * factor; - pOutputSamples[i*2+1] = ((drflac_int32)(mid - side) >> 1) * factor; - } - } else { - shift -= 1; - for (i = 0; i < frameCount4; ++i) { - __m128i mid; - __m128i side; - __m128i tempL; - __m128i tempR; - __m128 leftf; - __m128 rightf; - mid = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - side = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - mid = _mm_or_si128(_mm_slli_epi32(mid, 1), _mm_and_si128(side, _mm_set1_epi32(0x01))); - tempL = _mm_slli_epi32(_mm_add_epi32(mid, side), shift); - tempR = _mm_slli_epi32(_mm_sub_epi32(mid, side), shift); - leftf = _mm_mul_ps(_mm_cvtepi32_ps(tempL), factor128); - rightf = _mm_mul_ps(_mm_cvtepi32_ps(tempR), factor128); - _mm_storeu_ps(pOutputSamples + i*8 + 0, _mm_unpacklo_ps(leftf, rightf)); - _mm_storeu_ps(pOutputSamples + i*8 + 4, _mm_unpackhi_ps(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((mid + side) << shift) * factor; - pOutputSamples[i*2+1] = (drflac_int32)((mid - side) << shift) * factor; - } - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_mid_side__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift = unusedBitsPerSample - 8; - float factor; - float32x4_t factor4; - int32x4_t shift4; - int32x4_t wbps0_4; - int32x4_t wbps1_4; - DRFLAC_ASSERT(pFlac->bitsPerSample <= 24); - factor = 1.0f / 8388608.0f; - factor4 = vdupq_n_f32(factor); - wbps0_4 = vdupq_n_s32(pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample); - wbps1_4 = vdupq_n_s32(pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample); - if (shift == 0) { - for (i = 0; i < frameCount4; ++i) { - int32x4_t lefti; - int32x4_t righti; - float32x4_t leftf; - float32x4_t rightf; - uint32x4_t mid = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), wbps0_4); - uint32x4_t side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), wbps1_4); - mid = vorrq_u32(vshlq_n_u32(mid, 1), vandq_u32(side, vdupq_n_u32(1))); - lefti = vshrq_n_s32(vreinterpretq_s32_u32(vaddq_u32(mid, side)), 1); - righti = vshrq_n_s32(vreinterpretq_s32_u32(vsubq_u32(mid, side)), 1); - leftf = vmulq_f32(vcvtq_f32_s32(lefti), factor4); - rightf = vmulq_f32(vcvtq_f32_s32(righti), factor4); - drflac__vst2q_f32(pOutputSamples + i*8, vzipq_f32(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = ((drflac_int32)(mid + side) >> 1) * factor; - pOutputSamples[i*2+1] = ((drflac_int32)(mid - side) >> 1) * factor; - } - } else { - shift -= 1; - shift4 = vdupq_n_s32(shift); - for (i = 0; i < frameCount4; ++i) { - uint32x4_t mid; - uint32x4_t side; - int32x4_t lefti; - int32x4_t righti; - float32x4_t leftf; - float32x4_t rightf; - mid = vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), wbps0_4); - side = vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), wbps1_4); - mid = vorrq_u32(vshlq_n_u32(mid, 1), vandq_u32(side, vdupq_n_u32(1))); - lefti = vreinterpretq_s32_u32(vshlq_u32(vaddq_u32(mid, side), shift4)); - righti = vreinterpretq_s32_u32(vshlq_u32(vsubq_u32(mid, side), shift4)); - leftf = vmulq_f32(vcvtq_f32_s32(lefti), factor4); - rightf = vmulq_f32(vcvtq_f32_s32(righti), factor4); - drflac__vst2q_f32(pOutputSamples + i*8, vzipq_f32(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - drflac_uint32 mid = pInputSamples0U32[i] << pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 side = pInputSamples1U32[i] << pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - mid = (mid << 1) | (side & 0x01); - pOutputSamples[i*2+0] = (drflac_int32)((mid + side) << shift) * factor; - pOutputSamples[i*2+1] = (drflac_int32)((mid - side) << shift) * factor; - } - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_mid_side(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_mid_side__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_mid_side__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_f32__decode_mid_side__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_f32__decode_mid_side__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -#if 0 -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_independent_stereo__reference(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - for (drflac_uint64 i = 0; i < frameCount; ++i) { - pOutputSamples[i*2+0] = (float)((drflac_int32)((drflac_uint32)pInputSamples0[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample)) / 2147483648.0); - pOutputSamples[i*2+1] = (float)((drflac_int32)((drflac_uint32)pInputSamples1[i] << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample)) / 2147483648.0); - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_independent_stereo__scalar(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample; - drflac_uint32 shift1 = unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample; - float factor = 1 / 2147483648.0; - for (i = 0; i < frameCount4; ++i) { - drflac_uint32 tempL0 = pInputSamples0U32[i*4+0] << shift0; - drflac_uint32 tempL1 = pInputSamples0U32[i*4+1] << shift0; - drflac_uint32 tempL2 = pInputSamples0U32[i*4+2] << shift0; - drflac_uint32 tempL3 = pInputSamples0U32[i*4+3] << shift0; - drflac_uint32 tempR0 = pInputSamples1U32[i*4+0] << shift1; - drflac_uint32 tempR1 = pInputSamples1U32[i*4+1] << shift1; - drflac_uint32 tempR2 = pInputSamples1U32[i*4+2] << shift1; - drflac_uint32 tempR3 = pInputSamples1U32[i*4+3] << shift1; - pOutputSamples[i*8+0] = (drflac_int32)tempL0 * factor; - pOutputSamples[i*8+1] = (drflac_int32)tempR0 * factor; - pOutputSamples[i*8+2] = (drflac_int32)tempL1 * factor; - pOutputSamples[i*8+3] = (drflac_int32)tempR1 * factor; - pOutputSamples[i*8+4] = (drflac_int32)tempL2 * factor; - pOutputSamples[i*8+5] = (drflac_int32)tempR2 * factor; - pOutputSamples[i*8+6] = (drflac_int32)tempL3 * factor; - pOutputSamples[i*8+7] = (drflac_int32)tempR3 * factor; - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)(pInputSamples0U32[i] << shift0) * factor; - pOutputSamples[i*2+1] = (drflac_int32)(pInputSamples1U32[i] << shift1) * factor; - } -} -#if defined(DRFLAC_SUPPORT_SSE2) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_independent_stereo__sse2(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample) - 8; - drflac_uint32 shift1 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample) - 8; - float factor = 1.0f / 8388608.0f; - __m128 factor128 = _mm_set1_ps(factor); - for (i = 0; i < frameCount4; ++i) { - __m128i lefti; - __m128i righti; - __m128 leftf; - __m128 rightf; - lefti = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples0 + i), shift0); - righti = _mm_slli_epi32(_mm_loadu_si128((const __m128i*)pInputSamples1 + i), shift1); - leftf = _mm_mul_ps(_mm_cvtepi32_ps(lefti), factor128); - rightf = _mm_mul_ps(_mm_cvtepi32_ps(righti), factor128); - _mm_storeu_ps(pOutputSamples + i*8 + 0, _mm_unpacklo_ps(leftf, rightf)); - _mm_storeu_ps(pOutputSamples + i*8 + 4, _mm_unpackhi_ps(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)(pInputSamples0U32[i] << shift0) * factor; - pOutputSamples[i*2+1] = (drflac_int32)(pInputSamples1U32[i] << shift1) * factor; - } -} -#endif -#if defined(DRFLAC_SUPPORT_NEON) -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_independent_stereo__neon(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ - drflac_uint64 i; - drflac_uint64 frameCount4 = frameCount >> 2; - const drflac_uint32* pInputSamples0U32 = (const drflac_uint32*)pInputSamples0; - const drflac_uint32* pInputSamples1U32 = (const drflac_uint32*)pInputSamples1; - drflac_uint32 shift0 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[0].wastedBitsPerSample) - 8; - drflac_uint32 shift1 = (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[1].wastedBitsPerSample) - 8; - float factor = 1.0f / 8388608.0f; - float32x4_t factor4 = vdupq_n_f32(factor); - int32x4_t shift0_4 = vdupq_n_s32(shift0); - int32x4_t shift1_4 = vdupq_n_s32(shift1); - for (i = 0; i < frameCount4; ++i) { - int32x4_t lefti; - int32x4_t righti; - float32x4_t leftf; - float32x4_t rightf; - lefti = vreinterpretq_s32_u32(vshlq_u32(vld1q_u32(pInputSamples0U32 + i*4), shift0_4)); - righti = vreinterpretq_s32_u32(vshlq_u32(vld1q_u32(pInputSamples1U32 + i*4), shift1_4)); - leftf = vmulq_f32(vcvtq_f32_s32(lefti), factor4); - rightf = vmulq_f32(vcvtq_f32_s32(righti), factor4); - drflac__vst2q_f32(pOutputSamples + i*8, vzipq_f32(leftf, rightf)); - } - for (i = (frameCount4 << 2); i < frameCount; ++i) { - pOutputSamples[i*2+0] = (drflac_int32)(pInputSamples0U32[i] << shift0) * factor; - pOutputSamples[i*2+1] = (drflac_int32)(pInputSamples1U32[i] << shift1) * factor; - } -} -#endif -static DRFLAC_INLINE void drflac_read_pcm_frames_f32__decode_independent_stereo(drflac* pFlac, drflac_uint64 frameCount, drflac_uint32 unusedBitsPerSample, const drflac_int32* pInputSamples0, const drflac_int32* pInputSamples1, float* pOutputSamples) -{ -#if defined(DRFLAC_SUPPORT_SSE2) - if (drflac__gIsSSE2Supported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_independent_stereo__sse2(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#elif defined(DRFLAC_SUPPORT_NEON) - if (drflac__gIsNEONSupported && pFlac->bitsPerSample <= 24) { - drflac_read_pcm_frames_f32__decode_independent_stereo__neon(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); - } else -#endif - { -#if 0 - drflac_read_pcm_frames_f32__decode_independent_stereo__reference(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#else - drflac_read_pcm_frames_f32__decode_independent_stereo__scalar(pFlac, frameCount, unusedBitsPerSample, pInputSamples0, pInputSamples1, pOutputSamples); -#endif - } -} -DRFLAC_API drflac_uint64 drflac_read_pcm_frames_f32(drflac* pFlac, drflac_uint64 framesToRead, float* pBufferOut) -{ - drflac_uint64 framesRead; - drflac_uint32 unusedBitsPerSample; - if (pFlac == NULL || framesToRead == 0) { - return 0; - } - if (pBufferOut == NULL) { - return drflac__seek_forward_by_pcm_frames(pFlac, framesToRead); - } - DRFLAC_ASSERT(pFlac->bitsPerSample <= 32); - unusedBitsPerSample = 32 - pFlac->bitsPerSample; - framesRead = 0; - while (framesToRead > 0) { - if (pFlac->currentFLACFrame.pcmFramesRemaining == 0) { - if (!drflac__read_and_decode_next_flac_frame(pFlac)) { - break; - } - } else { - unsigned int channelCount = drflac__get_channel_count_from_channel_assignment(pFlac->currentFLACFrame.header.channelAssignment); - drflac_uint64 iFirstPCMFrame = pFlac->currentFLACFrame.header.blockSizeInPCMFrames - pFlac->currentFLACFrame.pcmFramesRemaining; - drflac_uint64 frameCountThisIteration = framesToRead; - if (frameCountThisIteration > pFlac->currentFLACFrame.pcmFramesRemaining) { - frameCountThisIteration = pFlac->currentFLACFrame.pcmFramesRemaining; - } - if (channelCount == 2) { - const drflac_int32* pDecodedSamples0 = pFlac->currentFLACFrame.subframes[0].pSamplesS32 + iFirstPCMFrame; - const drflac_int32* pDecodedSamples1 = pFlac->currentFLACFrame.subframes[1].pSamplesS32 + iFirstPCMFrame; - switch (pFlac->currentFLACFrame.header.channelAssignment) - { - case DRFLAC_CHANNEL_ASSIGNMENT_LEFT_SIDE: - { - drflac_read_pcm_frames_f32__decode_left_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_RIGHT_SIDE: - { - drflac_read_pcm_frames_f32__decode_right_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_MID_SIDE: - { - drflac_read_pcm_frames_f32__decode_mid_side(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - case DRFLAC_CHANNEL_ASSIGNMENT_INDEPENDENT: - default: - { - drflac_read_pcm_frames_f32__decode_independent_stereo(pFlac, frameCountThisIteration, unusedBitsPerSample, pDecodedSamples0, pDecodedSamples1, pBufferOut); - } break; - } - } else { - drflac_uint64 i; - for (i = 0; i < frameCountThisIteration; ++i) { - unsigned int j; - for (j = 0; j < channelCount; ++j) { - drflac_int32 sampleS32 = (drflac_int32)((drflac_uint32)(pFlac->currentFLACFrame.subframes[j].pSamplesS32[iFirstPCMFrame + i]) << (unusedBitsPerSample + pFlac->currentFLACFrame.subframes[j].wastedBitsPerSample)); - pBufferOut[(i*channelCount)+j] = (float)(sampleS32 / 2147483648.0); - } - } - } - framesRead += frameCountThisIteration; - pBufferOut += frameCountThisIteration * channelCount; - framesToRead -= frameCountThisIteration; - pFlac->currentPCMFrame += frameCountThisIteration; - pFlac->currentFLACFrame.pcmFramesRemaining -= (unsigned int)frameCountThisIteration; - } - } - return framesRead; -} -DRFLAC_API drflac_bool32 drflac_seek_to_pcm_frame(drflac* pFlac, drflac_uint64 pcmFrameIndex) -{ - if (pFlac == NULL) { - return DRFLAC_FALSE; - } - if (pFlac->currentPCMFrame == pcmFrameIndex) { - return DRFLAC_TRUE; - } - if (pFlac->firstFLACFramePosInBytes == 0) { - return DRFLAC_FALSE; - } - if (pcmFrameIndex == 0) { - pFlac->currentPCMFrame = 0; - return drflac__seek_to_first_frame(pFlac); - } else { - drflac_bool32 wasSuccessful = DRFLAC_FALSE; - drflac_uint64 originalPCMFrame = pFlac->currentPCMFrame; - if (pcmFrameIndex > pFlac->totalPCMFrameCount) { - pcmFrameIndex = pFlac->totalPCMFrameCount; - } - if (pcmFrameIndex > pFlac->currentPCMFrame) { - drflac_uint32 offset = (drflac_uint32)(pcmFrameIndex - pFlac->currentPCMFrame); - if (pFlac->currentFLACFrame.pcmFramesRemaining > offset) { - pFlac->currentFLACFrame.pcmFramesRemaining -= offset; - pFlac->currentPCMFrame = pcmFrameIndex; - return DRFLAC_TRUE; - } - } else { - drflac_uint32 offsetAbs = (drflac_uint32)(pFlac->currentPCMFrame - pcmFrameIndex); - drflac_uint32 currentFLACFramePCMFrameCount = pFlac->currentFLACFrame.header.blockSizeInPCMFrames; - drflac_uint32 currentFLACFramePCMFramesConsumed = currentFLACFramePCMFrameCount - pFlac->currentFLACFrame.pcmFramesRemaining; - if (currentFLACFramePCMFramesConsumed > offsetAbs) { - pFlac->currentFLACFrame.pcmFramesRemaining += offsetAbs; - pFlac->currentPCMFrame = pcmFrameIndex; - return DRFLAC_TRUE; - } - } -#ifndef DR_FLAC_NO_OGG - if (pFlac->container == drflac_container_ogg) - { - wasSuccessful = drflac_ogg__seek_to_pcm_frame(pFlac, pcmFrameIndex); - } - else -#endif - { - if (!pFlac->_noSeekTableSeek) { - wasSuccessful = drflac__seek_to_pcm_frame__seek_table(pFlac, pcmFrameIndex); - } -#if !defined(DR_FLAC_NO_CRC) - if (!wasSuccessful && !pFlac->_noBinarySearchSeek && pFlac->totalPCMFrameCount > 0) { - wasSuccessful = drflac__seek_to_pcm_frame__binary_search(pFlac, pcmFrameIndex); - } -#endif - if (!wasSuccessful && !pFlac->_noBruteForceSeek) { - wasSuccessful = drflac__seek_to_pcm_frame__brute_force(pFlac, pcmFrameIndex); - } - } - if (wasSuccessful) { - pFlac->currentPCMFrame = pcmFrameIndex; - } else { - if (drflac_seek_to_pcm_frame(pFlac, originalPCMFrame) == DRFLAC_FALSE) { - drflac_seek_to_pcm_frame(pFlac, 0); - } - } - return wasSuccessful; - } -} -#if defined(SIZE_MAX) - #define DRFLAC_SIZE_MAX SIZE_MAX -#else - #if defined(DRFLAC_64BIT) - #define DRFLAC_SIZE_MAX ((drflac_uint64)0xFFFFFFFFFFFFFFFF) - #else - #define DRFLAC_SIZE_MAX 0xFFFFFFFF - #endif -#endif -#define DRFLAC_DEFINE_FULL_READ_AND_CLOSE(extension, type) \ -static type* drflac__full_read_and_close_ ## extension (drflac* pFlac, unsigned int* channelsOut, unsigned int* sampleRateOut, drflac_uint64* totalPCMFrameCountOut)\ -{ \ - type* pSampleData = NULL; \ - drflac_uint64 totalPCMFrameCount; \ - \ - DRFLAC_ASSERT(pFlac != NULL); \ - \ - totalPCMFrameCount = pFlac->totalPCMFrameCount; \ - \ - if (totalPCMFrameCount == 0) { \ - type buffer[4096]; \ - drflac_uint64 pcmFramesRead; \ - size_t sampleDataBufferSize = sizeof(buffer); \ - \ - pSampleData = (type*)drflac__malloc_from_callbacks(sampleDataBufferSize, &pFlac->allocationCallbacks); \ - if (pSampleData == NULL) { \ - goto on_error; \ - } \ - \ - while ((pcmFramesRead = (drflac_uint64)drflac_read_pcm_frames_##extension(pFlac, sizeof(buffer)/sizeof(buffer[0])/pFlac->channels, buffer)) > 0) { \ - if (((totalPCMFrameCount + pcmFramesRead) * pFlac->channels * sizeof(type)) > sampleDataBufferSize) { \ - type* pNewSampleData; \ - size_t newSampleDataBufferSize; \ - \ - newSampleDataBufferSize = sampleDataBufferSize * 2; \ - pNewSampleData = (type*)drflac__realloc_from_callbacks(pSampleData, newSampleDataBufferSize, sampleDataBufferSize, &pFlac->allocationCallbacks); \ - if (pNewSampleData == NULL) { \ - drflac__free_from_callbacks(pSampleData, &pFlac->allocationCallbacks); \ - goto on_error; \ - } \ - \ - sampleDataBufferSize = newSampleDataBufferSize; \ - pSampleData = pNewSampleData; \ - } \ - \ - DRFLAC_COPY_MEMORY(pSampleData + (totalPCMFrameCount*pFlac->channels), buffer, (size_t)(pcmFramesRead*pFlac->channels*sizeof(type))); \ - totalPCMFrameCount += pcmFramesRead; \ - } \ - \ - \ - DRFLAC_ZERO_MEMORY(pSampleData + (totalPCMFrameCount*pFlac->channels), (size_t)(sampleDataBufferSize - totalPCMFrameCount*pFlac->channels*sizeof(type))); \ - } else { \ - drflac_uint64 dataSize = totalPCMFrameCount*pFlac->channels*sizeof(type); \ - if (dataSize > (drflac_uint64)DRFLAC_SIZE_MAX) { \ - goto on_error; \ - } \ - \ - pSampleData = (type*)drflac__malloc_from_callbacks((size_t)dataSize, &pFlac->allocationCallbacks); \ - if (pSampleData == NULL) { \ - goto on_error; \ - } \ - \ - totalPCMFrameCount = drflac_read_pcm_frames_##extension(pFlac, pFlac->totalPCMFrameCount, pSampleData); \ - } \ - \ - if (sampleRateOut) *sampleRateOut = pFlac->sampleRate; \ - if (channelsOut) *channelsOut = pFlac->channels; \ - if (totalPCMFrameCountOut) *totalPCMFrameCountOut = totalPCMFrameCount; \ - \ - drflac_close(pFlac); \ - return pSampleData; \ - \ -on_error: \ - drflac_close(pFlac); \ - return NULL; \ -} -DRFLAC_DEFINE_FULL_READ_AND_CLOSE(s32, drflac_int32) -DRFLAC_DEFINE_FULL_READ_AND_CLOSE(s16, drflac_int16) -DRFLAC_DEFINE_FULL_READ_AND_CLOSE(f32, float) -DRFLAC_API drflac_int32* drflac_open_and_read_pcm_frames_s32(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drflac_uint64* totalPCMFrameCountOut, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalPCMFrameCountOut) { - *totalPCMFrameCountOut = 0; - } - pFlac = drflac_open(onRead, onSeek, pUserData, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_s32(pFlac, channelsOut, sampleRateOut, totalPCMFrameCountOut); -} -DRFLAC_API drflac_int16* drflac_open_and_read_pcm_frames_s16(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drflac_uint64* totalPCMFrameCountOut, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalPCMFrameCountOut) { - *totalPCMFrameCountOut = 0; - } - pFlac = drflac_open(onRead, onSeek, pUserData, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_s16(pFlac, channelsOut, sampleRateOut, totalPCMFrameCountOut); -} -DRFLAC_API float* drflac_open_and_read_pcm_frames_f32(drflac_read_proc onRead, drflac_seek_proc onSeek, void* pUserData, unsigned int* channelsOut, unsigned int* sampleRateOut, drflac_uint64* totalPCMFrameCountOut, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (channelsOut) { - *channelsOut = 0; - } - if (sampleRateOut) { - *sampleRateOut = 0; - } - if (totalPCMFrameCountOut) { - *totalPCMFrameCountOut = 0; - } - pFlac = drflac_open(onRead, onSeek, pUserData, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_f32(pFlac, channelsOut, sampleRateOut, totalPCMFrameCountOut); -} -#ifndef DR_FLAC_NO_STDIO -DRFLAC_API drflac_int32* drflac_open_file_and_read_pcm_frames_s32(const char* filename, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (sampleRate) { - *sampleRate = 0; - } - if (channels) { - *channels = 0; - } - if (totalPCMFrameCount) { - *totalPCMFrameCount = 0; - } - pFlac = drflac_open_file(filename, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_s32(pFlac, channels, sampleRate, totalPCMFrameCount); -} -DRFLAC_API drflac_int16* drflac_open_file_and_read_pcm_frames_s16(const char* filename, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (sampleRate) { - *sampleRate = 0; - } - if (channels) { - *channels = 0; - } - if (totalPCMFrameCount) { - *totalPCMFrameCount = 0; - } - pFlac = drflac_open_file(filename, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_s16(pFlac, channels, sampleRate, totalPCMFrameCount); -} -DRFLAC_API float* drflac_open_file_and_read_pcm_frames_f32(const char* filename, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (sampleRate) { - *sampleRate = 0; - } - if (channels) { - *channels = 0; - } - if (totalPCMFrameCount) { - *totalPCMFrameCount = 0; - } - pFlac = drflac_open_file(filename, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_f32(pFlac, channels, sampleRate, totalPCMFrameCount); -} -#endif -DRFLAC_API drflac_int32* drflac_open_memory_and_read_pcm_frames_s32(const void* data, size_t dataSize, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (sampleRate) { - *sampleRate = 0; - } - if (channels) { - *channels = 0; - } - if (totalPCMFrameCount) { - *totalPCMFrameCount = 0; - } - pFlac = drflac_open_memory(data, dataSize, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_s32(pFlac, channels, sampleRate, totalPCMFrameCount); -} -DRFLAC_API drflac_int16* drflac_open_memory_and_read_pcm_frames_s16(const void* data, size_t dataSize, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (sampleRate) { - *sampleRate = 0; - } - if (channels) { - *channels = 0; - } - if (totalPCMFrameCount) { - *totalPCMFrameCount = 0; - } - pFlac = drflac_open_memory(data, dataSize, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_s16(pFlac, channels, sampleRate, totalPCMFrameCount); -} -DRFLAC_API float* drflac_open_memory_and_read_pcm_frames_f32(const void* data, size_t dataSize, unsigned int* channels, unsigned int* sampleRate, drflac_uint64* totalPCMFrameCount, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - drflac* pFlac; - if (sampleRate) { - *sampleRate = 0; - } - if (channels) { - *channels = 0; - } - if (totalPCMFrameCount) { - *totalPCMFrameCount = 0; - } - pFlac = drflac_open_memory(data, dataSize, pAllocationCallbacks); - if (pFlac == NULL) { - return NULL; - } - return drflac__full_read_and_close_f32(pFlac, channels, sampleRate, totalPCMFrameCount); -} -DRFLAC_API void drflac_free(void* p, const drflac_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - drflac__free_from_callbacks(p, pAllocationCallbacks); - } else { - drflac__free_default(p, NULL); - } -} -DRFLAC_API void drflac_init_vorbis_comment_iterator(drflac_vorbis_comment_iterator* pIter, drflac_uint32 commentCount, const void* pComments) -{ - if (pIter == NULL) { - return; - } - pIter->countRemaining = commentCount; - pIter->pRunningData = (const char*)pComments; -} -DRFLAC_API const char* drflac_next_vorbis_comment(drflac_vorbis_comment_iterator* pIter, drflac_uint32* pCommentLengthOut) -{ - drflac_int32 length; - const char* pComment; - if (pCommentLengthOut) { - *pCommentLengthOut = 0; - } - if (pIter == NULL || pIter->countRemaining == 0 || pIter->pRunningData == NULL) { - return NULL; - } - length = drflac__le2host_32_ptr_unaligned(pIter->pRunningData); - pIter->pRunningData += 4; - pComment = pIter->pRunningData; - pIter->pRunningData += length; - pIter->countRemaining -= 1; - if (pCommentLengthOut) { - *pCommentLengthOut = length; - } - return pComment; -} -DRFLAC_API void drflac_init_cuesheet_track_iterator(drflac_cuesheet_track_iterator* pIter, drflac_uint32 trackCount, const void* pTrackData) -{ - if (pIter == NULL) { - return; - } - pIter->countRemaining = trackCount; - pIter->pRunningData = (const char*)pTrackData; -} -DRFLAC_API drflac_bool32 drflac_next_cuesheet_track(drflac_cuesheet_track_iterator* pIter, drflac_cuesheet_track* pCuesheetTrack) -{ - drflac_cuesheet_track cuesheetTrack; - const char* pRunningData; - drflac_uint64 offsetHi; - drflac_uint64 offsetLo; - if (pIter == NULL || pIter->countRemaining == 0 || pIter->pRunningData == NULL) { - return DRFLAC_FALSE; - } - pRunningData = pIter->pRunningData; - offsetHi = drflac__be2host_32(*(const drflac_uint32*)pRunningData); pRunningData += 4; - offsetLo = drflac__be2host_32(*(const drflac_uint32*)pRunningData); pRunningData += 4; - cuesheetTrack.offset = offsetLo | (offsetHi << 32); - cuesheetTrack.trackNumber = pRunningData[0]; pRunningData += 1; - DRFLAC_COPY_MEMORY(cuesheetTrack.ISRC, pRunningData, sizeof(cuesheetTrack.ISRC)); pRunningData += 12; - cuesheetTrack.isAudio = (pRunningData[0] & 0x80) != 0; - cuesheetTrack.preEmphasis = (pRunningData[0] & 0x40) != 0; pRunningData += 14; - cuesheetTrack.indexCount = pRunningData[0]; pRunningData += 1; - cuesheetTrack.pIndexPoints = (const drflac_cuesheet_track_index*)pRunningData; pRunningData += cuesheetTrack.indexCount * sizeof(drflac_cuesheet_track_index); - pIter->pRunningData = pRunningData; - pIter->countRemaining -= 1; - if (pCuesheetTrack) { - *pCuesheetTrack = cuesheetTrack; - } - return DRFLAC_TRUE; -} -#if defined(__clang__) || (defined(__GNUC__) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 6))) - #pragma GCC diagnostic pop -#endif -#endif -/* dr_flac_c end */ -#endif /* DRFLAC_IMPLEMENTATION */ -#endif /* MA_NO_FLAC */ - -#if !defined(MA_NO_MP3) && !defined(MA_NO_DECODING) -#if !defined(DR_MP3_IMPLEMENTATION) && !defined(DRMP3_IMPLEMENTATION) /* For backwards compatibility. Will be removed in version 0.11 for cleanliness. */ -/* dr_mp3_c begin */ -#ifndef dr_mp3_c -#define dr_mp3_c -#include -#include -#include -DRMP3_API void drmp3_version(drmp3_uint32* pMajor, drmp3_uint32* pMinor, drmp3_uint32* pRevision) -{ - if (pMajor) { - *pMajor = DRMP3_VERSION_MAJOR; - } - if (pMinor) { - *pMinor = DRMP3_VERSION_MINOR; - } - if (pRevision) { - *pRevision = DRMP3_VERSION_REVISION; - } -} -DRMP3_API const char* drmp3_version_string(void) -{ - return DRMP3_VERSION_STRING; -} -#if defined(__TINYC__) -#define DR_MP3_NO_SIMD -#endif -#define DRMP3_OFFSET_PTR(p, offset) ((void*)((drmp3_uint8*)(p) + (offset))) -#define DRMP3_MAX_FREE_FORMAT_FRAME_SIZE 2304 -#ifndef DRMP3_MAX_FRAME_SYNC_MATCHES -#define DRMP3_MAX_FRAME_SYNC_MATCHES 10 -#endif -#define DRMP3_MAX_L3_FRAME_PAYLOAD_BYTES DRMP3_MAX_FREE_FORMAT_FRAME_SIZE -#define DRMP3_MAX_BITRESERVOIR_BYTES 511 -#define DRMP3_SHORT_BLOCK_TYPE 2 -#define DRMP3_STOP_BLOCK_TYPE 3 -#define DRMP3_MODE_MONO 3 -#define DRMP3_MODE_JOINT_STEREO 1 -#define DRMP3_HDR_SIZE 4 -#define DRMP3_HDR_IS_MONO(h) (((h[3]) & 0xC0) == 0xC0) -#define DRMP3_HDR_IS_MS_STEREO(h) (((h[3]) & 0xE0) == 0x60) -#define DRMP3_HDR_IS_FREE_FORMAT(h) (((h[2]) & 0xF0) == 0) -#define DRMP3_HDR_IS_CRC(h) (!((h[1]) & 1)) -#define DRMP3_HDR_TEST_PADDING(h) ((h[2]) & 0x2) -#define DRMP3_HDR_TEST_MPEG1(h) ((h[1]) & 0x8) -#define DRMP3_HDR_TEST_NOT_MPEG25(h) ((h[1]) & 0x10) -#define DRMP3_HDR_TEST_I_STEREO(h) ((h[3]) & 0x10) -#define DRMP3_HDR_TEST_MS_STEREO(h) ((h[3]) & 0x20) -#define DRMP3_HDR_GET_STEREO_MODE(h) (((h[3]) >> 6) & 3) -#define DRMP3_HDR_GET_STEREO_MODE_EXT(h) (((h[3]) >> 4) & 3) -#define DRMP3_HDR_GET_LAYER(h) (((h[1]) >> 1) & 3) -#define DRMP3_HDR_GET_BITRATE(h) ((h[2]) >> 4) -#define DRMP3_HDR_GET_SAMPLE_RATE(h) (((h[2]) >> 2) & 3) -#define DRMP3_HDR_GET_MY_SAMPLE_RATE(h) (DRMP3_HDR_GET_SAMPLE_RATE(h) + (((h[1] >> 3) & 1) + ((h[1] >> 4) & 1))*3) -#define DRMP3_HDR_IS_FRAME_576(h) ((h[1] & 14) == 2) -#define DRMP3_HDR_IS_LAYER_1(h) ((h[1] & 6) == 6) -#define DRMP3_BITS_DEQUANTIZER_OUT -1 -#define DRMP3_MAX_SCF (255 + DRMP3_BITS_DEQUANTIZER_OUT*4 - 210) -#define DRMP3_MAX_SCFI ((DRMP3_MAX_SCF + 3) & ~3) -#define DRMP3_MIN(a, b) ((a) > (b) ? (b) : (a)) -#define DRMP3_MAX(a, b) ((a) < (b) ? (b) : (a)) -#if !defined(DR_MP3_NO_SIMD) -#if !defined(DR_MP3_ONLY_SIMD) && (defined(_M_X64) || defined(__x86_64__) || defined(__aarch64__) || defined(_M_ARM64)) -#define DR_MP3_ONLY_SIMD -#endif -#if ((defined(_MSC_VER) && _MSC_VER >= 1400) && defined(_M_X64)) || ((defined(__i386) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__)) && ((defined(_M_IX86_FP) && _M_IX86_FP == 2) || defined(__SSE2__))) -#if defined(_MSC_VER) -#include -#endif -#include -#define DRMP3_HAVE_SSE 1 -#define DRMP3_HAVE_SIMD 1 -#define DRMP3_VSTORE _mm_storeu_ps -#define DRMP3_VLD _mm_loadu_ps -#define DRMP3_VSET _mm_set1_ps -#define DRMP3_VADD _mm_add_ps -#define DRMP3_VSUB _mm_sub_ps -#define DRMP3_VMUL _mm_mul_ps -#define DRMP3_VMAC(a, x, y) _mm_add_ps(a, _mm_mul_ps(x, y)) -#define DRMP3_VMSB(a, x, y) _mm_sub_ps(a, _mm_mul_ps(x, y)) -#define DRMP3_VMUL_S(x, s) _mm_mul_ps(x, _mm_set1_ps(s)) -#define DRMP3_VREV(x) _mm_shuffle_ps(x, x, _MM_SHUFFLE(0, 1, 2, 3)) -typedef __m128 drmp3_f4; -#if defined(_MSC_VER) || defined(DR_MP3_ONLY_SIMD) -#define drmp3_cpuid __cpuid -#else -static __inline__ __attribute__((always_inline)) void drmp3_cpuid(int CPUInfo[], const int InfoType) -{ -#if defined(__PIC__) - __asm__ __volatile__( -#if defined(__x86_64__) - "push %%rbx\n" - "cpuid\n" - "xchgl %%ebx, %1\n" - "pop %%rbx\n" -#else - "xchgl %%ebx, %1\n" - "cpuid\n" - "xchgl %%ebx, %1\n" -#endif - : "=a" (CPUInfo[0]), "=r" (CPUInfo[1]), "=c" (CPUInfo[2]), "=d" (CPUInfo[3]) - : "a" (InfoType)); -#else - __asm__ __volatile__( - "cpuid" - : "=a" (CPUInfo[0]), "=b" (CPUInfo[1]), "=c" (CPUInfo[2]), "=d" (CPUInfo[3]) - : "a" (InfoType)); -#endif -} -#endif -static int drmp3_have_simd(void) -{ -#ifdef DR_MP3_ONLY_SIMD - return 1; -#else - static int g_have_simd; - int CPUInfo[4]; -#ifdef MINIMP3_TEST - static int g_counter; - if (g_counter++ > 100) - return 0; -#endif - if (g_have_simd) - goto end; - drmp3_cpuid(CPUInfo, 0); - if (CPUInfo[0] > 0) - { - drmp3_cpuid(CPUInfo, 1); - g_have_simd = (CPUInfo[3] & (1 << 26)) + 1; - return g_have_simd - 1; - } -end: - return g_have_simd - 1; -#endif -} -#elif defined(__ARM_NEON) || defined(__aarch64__) || defined(_M_ARM64) -#include -#define DRMP3_HAVE_SSE 0 -#define DRMP3_HAVE_SIMD 1 -#define DRMP3_VSTORE vst1q_f32 -#define DRMP3_VLD vld1q_f32 -#define DRMP3_VSET vmovq_n_f32 -#define DRMP3_VADD vaddq_f32 -#define DRMP3_VSUB vsubq_f32 -#define DRMP3_VMUL vmulq_f32 -#define DRMP3_VMAC(a, x, y) vmlaq_f32(a, x, y) -#define DRMP3_VMSB(a, x, y) vmlsq_f32(a, x, y) -#define DRMP3_VMUL_S(x, s) vmulq_f32(x, vmovq_n_f32(s)) -#define DRMP3_VREV(x) vcombine_f32(vget_high_f32(vrev64q_f32(x)), vget_low_f32(vrev64q_f32(x))) -typedef float32x4_t drmp3_f4; -static int drmp3_have_simd(void) -{ - return 1; -} -#else -#define DRMP3_HAVE_SSE 0 -#define DRMP3_HAVE_SIMD 0 -#ifdef DR_MP3_ONLY_SIMD -#error DR_MP3_ONLY_SIMD used, but SSE/NEON not enabled -#endif -#endif -#else -#define DRMP3_HAVE_SIMD 0 -#endif -#if defined(__ARM_ARCH) && (__ARM_ARCH >= 6) && !defined(__aarch64__) && !defined(_M_ARM64) -#define DRMP3_HAVE_ARMV6 1 -static __inline__ __attribute__((always_inline)) drmp3_int32 drmp3_clip_int16_arm(drmp3_int32 a) -{ - drmp3_int32 x = 0; - __asm__ ("ssat %0, #16, %1" : "=r"(x) : "r"(a)); - return x; -} -#else -#define DRMP3_HAVE_ARMV6 0 -#endif -#ifndef DRMP3_ASSERT -#include -#define DRMP3_ASSERT(expression) assert(expression) -#endif -#ifndef DRMP3_COPY_MEMORY -#define DRMP3_COPY_MEMORY(dst, src, sz) memcpy((dst), (src), (sz)) -#endif -#ifndef DRMP3_MOVE_MEMORY -#define DRMP3_MOVE_MEMORY(dst, src, sz) memmove((dst), (src), (sz)) -#endif -#ifndef DRMP3_ZERO_MEMORY -#define DRMP3_ZERO_MEMORY(p, sz) memset((p), 0, (sz)) -#endif -#define DRMP3_ZERO_OBJECT(p) DRMP3_ZERO_MEMORY((p), sizeof(*(p))) -#ifndef DRMP3_MALLOC -#define DRMP3_MALLOC(sz) malloc((sz)) -#endif -#ifndef DRMP3_REALLOC -#define DRMP3_REALLOC(p, sz) realloc((p), (sz)) -#endif -#ifndef DRMP3_FREE -#define DRMP3_FREE(p) free((p)) -#endif -typedef struct -{ - const drmp3_uint8 *buf; - int pos, limit; -} drmp3_bs; -typedef struct -{ - float scf[3*64]; - drmp3_uint8 total_bands, stereo_bands, bitalloc[64], scfcod[64]; -} drmp3_L12_scale_info; -typedef struct -{ - drmp3_uint8 tab_offset, code_tab_width, band_count; -} drmp3_L12_subband_alloc; -typedef struct -{ - const drmp3_uint8 *sfbtab; - drmp3_uint16 part_23_length, big_values, scalefac_compress; - drmp3_uint8 global_gain, block_type, mixed_block_flag, n_long_sfb, n_short_sfb; - drmp3_uint8 table_select[3], region_count[3], subblock_gain[3]; - drmp3_uint8 preflag, scalefac_scale, count1_table, scfsi; -} drmp3_L3_gr_info; -typedef struct -{ - drmp3_bs bs; - drmp3_uint8 maindata[DRMP3_MAX_BITRESERVOIR_BYTES + DRMP3_MAX_L3_FRAME_PAYLOAD_BYTES]; - drmp3_L3_gr_info gr_info[4]; - float grbuf[2][576], scf[40], syn[18 + 15][2*32]; - drmp3_uint8 ist_pos[2][39]; -} drmp3dec_scratch; -static void drmp3_bs_init(drmp3_bs *bs, const drmp3_uint8 *data, int bytes) -{ - bs->buf = data; - bs->pos = 0; - bs->limit = bytes*8; -} -static drmp3_uint32 drmp3_bs_get_bits(drmp3_bs *bs, int n) -{ - drmp3_uint32 next, cache = 0, s = bs->pos & 7; - int shl = n + s; - const drmp3_uint8 *p = bs->buf + (bs->pos >> 3); - if ((bs->pos += n) > bs->limit) - return 0; - next = *p++ & (255 >> s); - while ((shl -= 8) > 0) - { - cache |= next << shl; - next = *p++; - } - return cache | (next >> -shl); -} -static int drmp3_hdr_valid(const drmp3_uint8 *h) -{ - return h[0] == 0xff && - ((h[1] & 0xF0) == 0xf0 || (h[1] & 0xFE) == 0xe2) && - (DRMP3_HDR_GET_LAYER(h) != 0) && - (DRMP3_HDR_GET_BITRATE(h) != 15) && - (DRMP3_HDR_GET_SAMPLE_RATE(h) != 3); -} -static int drmp3_hdr_compare(const drmp3_uint8 *h1, const drmp3_uint8 *h2) -{ - return drmp3_hdr_valid(h2) && - ((h1[1] ^ h2[1]) & 0xFE) == 0 && - ((h1[2] ^ h2[2]) & 0x0C) == 0 && - !(DRMP3_HDR_IS_FREE_FORMAT(h1) ^ DRMP3_HDR_IS_FREE_FORMAT(h2)); -} -static unsigned drmp3_hdr_bitrate_kbps(const drmp3_uint8 *h) -{ - static const drmp3_uint8 halfrate[2][3][15] = { - { { 0,4,8,12,16,20,24,28,32,40,48,56,64,72,80 }, { 0,4,8,12,16,20,24,28,32,40,48,56,64,72,80 }, { 0,16,24,28,32,40,48,56,64,72,80,88,96,112,128 } }, - { { 0,16,20,24,28,32,40,48,56,64,80,96,112,128,160 }, { 0,16,24,28,32,40,48,56,64,80,96,112,128,160,192 }, { 0,16,32,48,64,80,96,112,128,144,160,176,192,208,224 } }, - }; - return 2*halfrate[!!DRMP3_HDR_TEST_MPEG1(h)][DRMP3_HDR_GET_LAYER(h) - 1][DRMP3_HDR_GET_BITRATE(h)]; -} -static unsigned drmp3_hdr_sample_rate_hz(const drmp3_uint8 *h) -{ - static const unsigned g_hz[3] = { 44100, 48000, 32000 }; - return g_hz[DRMP3_HDR_GET_SAMPLE_RATE(h)] >> (int)!DRMP3_HDR_TEST_MPEG1(h) >> (int)!DRMP3_HDR_TEST_NOT_MPEG25(h); -} -static unsigned drmp3_hdr_frame_samples(const drmp3_uint8 *h) -{ - return DRMP3_HDR_IS_LAYER_1(h) ? 384 : (1152 >> (int)DRMP3_HDR_IS_FRAME_576(h)); -} -static int drmp3_hdr_frame_bytes(const drmp3_uint8 *h, int free_format_size) -{ - int frame_bytes = drmp3_hdr_frame_samples(h)*drmp3_hdr_bitrate_kbps(h)*125/drmp3_hdr_sample_rate_hz(h); - if (DRMP3_HDR_IS_LAYER_1(h)) - { - frame_bytes &= ~3; - } - return frame_bytes ? frame_bytes : free_format_size; -} -static int drmp3_hdr_padding(const drmp3_uint8 *h) -{ - return DRMP3_HDR_TEST_PADDING(h) ? (DRMP3_HDR_IS_LAYER_1(h) ? 4 : 1) : 0; -} -#ifndef DR_MP3_ONLY_MP3 -static const drmp3_L12_subband_alloc *drmp3_L12_subband_alloc_table(const drmp3_uint8 *hdr, drmp3_L12_scale_info *sci) -{ - const drmp3_L12_subband_alloc *alloc; - int mode = DRMP3_HDR_GET_STEREO_MODE(hdr); - int nbands, stereo_bands = (mode == DRMP3_MODE_MONO) ? 0 : (mode == DRMP3_MODE_JOINT_STEREO) ? (DRMP3_HDR_GET_STEREO_MODE_EXT(hdr) << 2) + 4 : 32; - if (DRMP3_HDR_IS_LAYER_1(hdr)) - { - static const drmp3_L12_subband_alloc g_alloc_L1[] = { { 76, 4, 32 } }; - alloc = g_alloc_L1; - nbands = 32; - } else if (!DRMP3_HDR_TEST_MPEG1(hdr)) - { - static const drmp3_L12_subband_alloc g_alloc_L2M2[] = { { 60, 4, 4 }, { 44, 3, 7 }, { 44, 2, 19 } }; - alloc = g_alloc_L2M2; - nbands = 30; - } else - { - static const drmp3_L12_subband_alloc g_alloc_L2M1[] = { { 0, 4, 3 }, { 16, 4, 8 }, { 32, 3, 12 }, { 40, 2, 7 } }; - int sample_rate_idx = DRMP3_HDR_GET_SAMPLE_RATE(hdr); - unsigned kbps = drmp3_hdr_bitrate_kbps(hdr) >> (int)(mode != DRMP3_MODE_MONO); - if (!kbps) - { - kbps = 192; - } - alloc = g_alloc_L2M1; - nbands = 27; - if (kbps < 56) - { - static const drmp3_L12_subband_alloc g_alloc_L2M1_lowrate[] = { { 44, 4, 2 }, { 44, 3, 10 } }; - alloc = g_alloc_L2M1_lowrate; - nbands = sample_rate_idx == 2 ? 12 : 8; - } else if (kbps >= 96 && sample_rate_idx != 1) - { - nbands = 30; - } - } - sci->total_bands = (drmp3_uint8)nbands; - sci->stereo_bands = (drmp3_uint8)DRMP3_MIN(stereo_bands, nbands); - return alloc; -} -static void drmp3_L12_read_scalefactors(drmp3_bs *bs, drmp3_uint8 *pba, drmp3_uint8 *scfcod, int bands, float *scf) -{ - static const float g_deq_L12[18*3] = { -#define DRMP3_DQ(x) 9.53674316e-07f/x, 7.56931807e-07f/x, 6.00777173e-07f/x - DRMP3_DQ(3),DRMP3_DQ(7),DRMP3_DQ(15),DRMP3_DQ(31),DRMP3_DQ(63),DRMP3_DQ(127),DRMP3_DQ(255),DRMP3_DQ(511),DRMP3_DQ(1023),DRMP3_DQ(2047),DRMP3_DQ(4095),DRMP3_DQ(8191),DRMP3_DQ(16383),DRMP3_DQ(32767),DRMP3_DQ(65535),DRMP3_DQ(3),DRMP3_DQ(5),DRMP3_DQ(9) - }; - int i, m; - for (i = 0; i < bands; i++) - { - float s = 0; - int ba = *pba++; - int mask = ba ? 4 + ((19 >> scfcod[i]) & 3) : 0; - for (m = 4; m; m >>= 1) - { - if (mask & m) - { - int b = drmp3_bs_get_bits(bs, 6); - s = g_deq_L12[ba*3 - 6 + b % 3]*(int)(1 << 21 >> b/3); - } - *scf++ = s; - } - } -} -static void drmp3_L12_read_scale_info(const drmp3_uint8 *hdr, drmp3_bs *bs, drmp3_L12_scale_info *sci) -{ - static const drmp3_uint8 g_bitalloc_code_tab[] = { - 0,17, 3, 4, 5,6,7, 8,9,10,11,12,13,14,15,16, - 0,17,18, 3,19,4,5, 6,7, 8, 9,10,11,12,13,16, - 0,17,18, 3,19,4,5,16, - 0,17,18,16, - 0,17,18,19, 4,5,6, 7,8, 9,10,11,12,13,14,15, - 0,17,18, 3,19,4,5, 6,7, 8, 9,10,11,12,13,14, - 0, 2, 3, 4, 5,6,7, 8,9,10,11,12,13,14,15,16 - }; - const drmp3_L12_subband_alloc *subband_alloc = drmp3_L12_subband_alloc_table(hdr, sci); - int i, k = 0, ba_bits = 0; - const drmp3_uint8 *ba_code_tab = g_bitalloc_code_tab; - for (i = 0; i < sci->total_bands; i++) - { - drmp3_uint8 ba; - if (i == k) - { - k += subband_alloc->band_count; - ba_bits = subband_alloc->code_tab_width; - ba_code_tab = g_bitalloc_code_tab + subband_alloc->tab_offset; - subband_alloc++; - } - ba = ba_code_tab[drmp3_bs_get_bits(bs, ba_bits)]; - sci->bitalloc[2*i] = ba; - if (i < sci->stereo_bands) - { - ba = ba_code_tab[drmp3_bs_get_bits(bs, ba_bits)]; - } - sci->bitalloc[2*i + 1] = sci->stereo_bands ? ba : 0; - } - for (i = 0; i < 2*sci->total_bands; i++) - { - sci->scfcod[i] = (drmp3_uint8)(sci->bitalloc[i] ? DRMP3_HDR_IS_LAYER_1(hdr) ? 2 : drmp3_bs_get_bits(bs, 2) : 6); - } - drmp3_L12_read_scalefactors(bs, sci->bitalloc, sci->scfcod, sci->total_bands*2, sci->scf); - for (i = sci->stereo_bands; i < sci->total_bands; i++) - { - sci->bitalloc[2*i + 1] = 0; - } -} -static int drmp3_L12_dequantize_granule(float *grbuf, drmp3_bs *bs, drmp3_L12_scale_info *sci, int group_size) -{ - int i, j, k, choff = 576; - for (j = 0; j < 4; j++) - { - float *dst = grbuf + group_size*j; - for (i = 0; i < 2*sci->total_bands; i++) - { - int ba = sci->bitalloc[i]; - if (ba != 0) - { - if (ba < 17) - { - int half = (1 << (ba - 1)) - 1; - for (k = 0; k < group_size; k++) - { - dst[k] = (float)((int)drmp3_bs_get_bits(bs, ba) - half); - } - } else - { - unsigned mod = (2 << (ba - 17)) + 1; - unsigned code = drmp3_bs_get_bits(bs, mod + 2 - (mod >> 3)); - for (k = 0; k < group_size; k++, code /= mod) - { - dst[k] = (float)((int)(code % mod - mod/2)); - } - } - } - dst += choff; - choff = 18 - choff; - } - } - return group_size*4; -} -static void drmp3_L12_apply_scf_384(drmp3_L12_scale_info *sci, const float *scf, float *dst) -{ - int i, k; - DRMP3_COPY_MEMORY(dst + 576 + sci->stereo_bands*18, dst + sci->stereo_bands*18, (sci->total_bands - sci->stereo_bands)*18*sizeof(float)); - for (i = 0; i < sci->total_bands; i++, dst += 18, scf += 6) - { - for (k = 0; k < 12; k++) - { - dst[k + 0] *= scf[0]; - dst[k + 576] *= scf[3]; - } - } -} -#endif -static int drmp3_L3_read_side_info(drmp3_bs *bs, drmp3_L3_gr_info *gr, const drmp3_uint8 *hdr) -{ - static const drmp3_uint8 g_scf_long[8][23] = { - { 6,6,6,6,6,6,8,10,12,14,16,20,24,28,32,38,46,52,60,68,58,54,0 }, - { 12,12,12,12,12,12,16,20,24,28,32,40,48,56,64,76,90,2,2,2,2,2,0 }, - { 6,6,6,6,6,6,8,10,12,14,16,20,24,28,32,38,46,52,60,68,58,54,0 }, - { 6,6,6,6,6,6,8,10,12,14,16,18,22,26,32,38,46,54,62,70,76,36,0 }, - { 6,6,6,6,6,6,8,10,12,14,16,20,24,28,32,38,46,52,60,68,58,54,0 }, - { 4,4,4,4,4,4,6,6,8,8,10,12,16,20,24,28,34,42,50,54,76,158,0 }, - { 4,4,4,4,4,4,6,6,6,8,10,12,16,18,22,28,34,40,46,54,54,192,0 }, - { 4,4,4,4,4,4,6,6,8,10,12,16,20,24,30,38,46,56,68,84,102,26,0 } - }; - static const drmp3_uint8 g_scf_short[8][40] = { - { 4,4,4,4,4,4,4,4,4,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,24,24,24,30,30,30,40,40,40,18,18,18,0 }, - { 8,8,8,8,8,8,8,8,8,12,12,12,16,16,16,20,20,20,24,24,24,28,28,28,36,36,36,2,2,2,2,2,2,2,2,2,26,26,26,0 }, - { 4,4,4,4,4,4,4,4,4,6,6,6,6,6,6,8,8,8,10,10,10,14,14,14,18,18,18,26,26,26,32,32,32,42,42,42,18,18,18,0 }, - { 4,4,4,4,4,4,4,4,4,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,24,24,24,32,32,32,44,44,44,12,12,12,0 }, - { 4,4,4,4,4,4,4,4,4,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,24,24,24,30,30,30,40,40,40,18,18,18,0 }, - { 4,4,4,4,4,4,4,4,4,4,4,4,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,22,22,22,30,30,30,56,56,56,0 }, - { 4,4,4,4,4,4,4,4,4,4,4,4,6,6,6,6,6,6,10,10,10,12,12,12,14,14,14,16,16,16,20,20,20,26,26,26,66,66,66,0 }, - { 4,4,4,4,4,4,4,4,4,4,4,4,6,6,6,8,8,8,12,12,12,16,16,16,20,20,20,26,26,26,34,34,34,42,42,42,12,12,12,0 } - }; - static const drmp3_uint8 g_scf_mixed[8][40] = { - { 6,6,6,6,6,6,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,24,24,24,30,30,30,40,40,40,18,18,18,0 }, - { 12,12,12,4,4,4,8,8,8,12,12,12,16,16,16,20,20,20,24,24,24,28,28,28,36,36,36,2,2,2,2,2,2,2,2,2,26,26,26,0 }, - { 6,6,6,6,6,6,6,6,6,6,6,6,8,8,8,10,10,10,14,14,14,18,18,18,26,26,26,32,32,32,42,42,42,18,18,18,0 }, - { 6,6,6,6,6,6,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,24,24,24,32,32,32,44,44,44,12,12,12,0 }, - { 6,6,6,6,6,6,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,24,24,24,30,30,30,40,40,40,18,18,18,0 }, - { 4,4,4,4,4,4,6,6,4,4,4,6,6,6,8,8,8,10,10,10,12,12,12,14,14,14,18,18,18,22,22,22,30,30,30,56,56,56,0 }, - { 4,4,4,4,4,4,6,6,4,4,4,6,6,6,6,6,6,10,10,10,12,12,12,14,14,14,16,16,16,20,20,20,26,26,26,66,66,66,0 }, - { 4,4,4,4,4,4,6,6,4,4,4,6,6,6,8,8,8,12,12,12,16,16,16,20,20,20,26,26,26,34,34,34,42,42,42,12,12,12,0 } - }; - unsigned tables, scfsi = 0; - int main_data_begin, part_23_sum = 0; - int gr_count = DRMP3_HDR_IS_MONO(hdr) ? 1 : 2; - int sr_idx = DRMP3_HDR_GET_MY_SAMPLE_RATE(hdr); sr_idx -= (sr_idx != 0); - if (DRMP3_HDR_TEST_MPEG1(hdr)) - { - gr_count *= 2; - main_data_begin = drmp3_bs_get_bits(bs, 9); - scfsi = drmp3_bs_get_bits(bs, 7 + gr_count); - } else - { - main_data_begin = drmp3_bs_get_bits(bs, 8 + gr_count) >> gr_count; - } - do - { - if (DRMP3_HDR_IS_MONO(hdr)) - { - scfsi <<= 4; - } - gr->part_23_length = (drmp3_uint16)drmp3_bs_get_bits(bs, 12); - part_23_sum += gr->part_23_length; - gr->big_values = (drmp3_uint16)drmp3_bs_get_bits(bs, 9); - if (gr->big_values > 288) - { - return -1; - } - gr->global_gain = (drmp3_uint8)drmp3_bs_get_bits(bs, 8); - gr->scalefac_compress = (drmp3_uint16)drmp3_bs_get_bits(bs, DRMP3_HDR_TEST_MPEG1(hdr) ? 4 : 9); - gr->sfbtab = g_scf_long[sr_idx]; - gr->n_long_sfb = 22; - gr->n_short_sfb = 0; - if (drmp3_bs_get_bits(bs, 1)) - { - gr->block_type = (drmp3_uint8)drmp3_bs_get_bits(bs, 2); - if (!gr->block_type) - { - return -1; - } - gr->mixed_block_flag = (drmp3_uint8)drmp3_bs_get_bits(bs, 1); - gr->region_count[0] = 7; - gr->region_count[1] = 255; - if (gr->block_type == DRMP3_SHORT_BLOCK_TYPE) - { - scfsi &= 0x0F0F; - if (!gr->mixed_block_flag) - { - gr->region_count[0] = 8; - gr->sfbtab = g_scf_short[sr_idx]; - gr->n_long_sfb = 0; - gr->n_short_sfb = 39; - } else - { - gr->sfbtab = g_scf_mixed[sr_idx]; - gr->n_long_sfb = DRMP3_HDR_TEST_MPEG1(hdr) ? 8 : 6; - gr->n_short_sfb = 30; - } - } - tables = drmp3_bs_get_bits(bs, 10); - tables <<= 5; - gr->subblock_gain[0] = (drmp3_uint8)drmp3_bs_get_bits(bs, 3); - gr->subblock_gain[1] = (drmp3_uint8)drmp3_bs_get_bits(bs, 3); - gr->subblock_gain[2] = (drmp3_uint8)drmp3_bs_get_bits(bs, 3); - } else - { - gr->block_type = 0; - gr->mixed_block_flag = 0; - tables = drmp3_bs_get_bits(bs, 15); - gr->region_count[0] = (drmp3_uint8)drmp3_bs_get_bits(bs, 4); - gr->region_count[1] = (drmp3_uint8)drmp3_bs_get_bits(bs, 3); - gr->region_count[2] = 255; - } - gr->table_select[0] = (drmp3_uint8)(tables >> 10); - gr->table_select[1] = (drmp3_uint8)((tables >> 5) & 31); - gr->table_select[2] = (drmp3_uint8)((tables) & 31); - gr->preflag = (drmp3_uint8)(DRMP3_HDR_TEST_MPEG1(hdr) ? drmp3_bs_get_bits(bs, 1) : (gr->scalefac_compress >= 500)); - gr->scalefac_scale = (drmp3_uint8)drmp3_bs_get_bits(bs, 1); - gr->count1_table = (drmp3_uint8)drmp3_bs_get_bits(bs, 1); - gr->scfsi = (drmp3_uint8)((scfsi >> 12) & 15); - scfsi <<= 4; - gr++; - } while(--gr_count); - if (part_23_sum + bs->pos > bs->limit + main_data_begin*8) - { - return -1; - } - return main_data_begin; -} -static void drmp3_L3_read_scalefactors(drmp3_uint8 *scf, drmp3_uint8 *ist_pos, const drmp3_uint8 *scf_size, const drmp3_uint8 *scf_count, drmp3_bs *bitbuf, int scfsi) -{ - int i, k; - for (i = 0; i < 4 && scf_count[i]; i++, scfsi *= 2) - { - int cnt = scf_count[i]; - if (scfsi & 8) - { - DRMP3_COPY_MEMORY(scf, ist_pos, cnt); - } else - { - int bits = scf_size[i]; - if (!bits) - { - DRMP3_ZERO_MEMORY(scf, cnt); - DRMP3_ZERO_MEMORY(ist_pos, cnt); - } else - { - int max_scf = (scfsi < 0) ? (1 << bits) - 1 : -1; - for (k = 0; k < cnt; k++) - { - int s = drmp3_bs_get_bits(bitbuf, bits); - ist_pos[k] = (drmp3_uint8)(s == max_scf ? -1 : s); - scf[k] = (drmp3_uint8)s; - } - } - } - ist_pos += cnt; - scf += cnt; - } - scf[0] = scf[1] = scf[2] = 0; -} -static float drmp3_L3_ldexp_q2(float y, int exp_q2) -{ - static const float g_expfrac[4] = { 9.31322575e-10f,7.83145814e-10f,6.58544508e-10f,5.53767716e-10f }; - int e; - do - { - e = DRMP3_MIN(30*4, exp_q2); - y *= g_expfrac[e & 3]*(1 << 30 >> (e >> 2)); - } while ((exp_q2 -= e) > 0); - return y; -} -static void drmp3_L3_decode_scalefactors(const drmp3_uint8 *hdr, drmp3_uint8 *ist_pos, drmp3_bs *bs, const drmp3_L3_gr_info *gr, float *scf, int ch) -{ - static const drmp3_uint8 g_scf_partitions[3][28] = { - { 6,5,5, 5,6,5,5,5,6,5, 7,3,11,10,0,0, 7, 7, 7,0, 6, 6,6,3, 8, 8,5,0 }, - { 8,9,6,12,6,9,9,9,6,9,12,6,15,18,0,0, 6,15,12,0, 6,12,9,6, 6,18,9,0 }, - { 9,9,6,12,9,9,9,9,9,9,12,6,18,18,0,0,12,12,12,0,12, 9,9,6,15,12,9,0 } - }; - const drmp3_uint8 *scf_partition = g_scf_partitions[!!gr->n_short_sfb + !gr->n_long_sfb]; - drmp3_uint8 scf_size[4], iscf[40]; - int i, scf_shift = gr->scalefac_scale + 1, gain_exp, scfsi = gr->scfsi; - float gain; - if (DRMP3_HDR_TEST_MPEG1(hdr)) - { - static const drmp3_uint8 g_scfc_decode[16] = { 0,1,2,3, 12,5,6,7, 9,10,11,13, 14,15,18,19 }; - int part = g_scfc_decode[gr->scalefac_compress]; - scf_size[1] = scf_size[0] = (drmp3_uint8)(part >> 2); - scf_size[3] = scf_size[2] = (drmp3_uint8)(part & 3); - } else - { - static const drmp3_uint8 g_mod[6*4] = { 5,5,4,4,5,5,4,1,4,3,1,1,5,6,6,1,4,4,4,1,4,3,1,1 }; - int k, modprod, sfc, ist = DRMP3_HDR_TEST_I_STEREO(hdr) && ch; - sfc = gr->scalefac_compress >> ist; - for (k = ist*3*4; sfc >= 0; sfc -= modprod, k += 4) - { - for (modprod = 1, i = 3; i >= 0; i--) - { - scf_size[i] = (drmp3_uint8)(sfc / modprod % g_mod[k + i]); - modprod *= g_mod[k + i]; - } - } - scf_partition += k; - scfsi = -16; - } - drmp3_L3_read_scalefactors(iscf, ist_pos, scf_size, scf_partition, bs, scfsi); - if (gr->n_short_sfb) - { - int sh = 3 - scf_shift; - for (i = 0; i < gr->n_short_sfb; i += 3) - { - iscf[gr->n_long_sfb + i + 0] = (drmp3_uint8)(iscf[gr->n_long_sfb + i + 0] + (gr->subblock_gain[0] << sh)); - iscf[gr->n_long_sfb + i + 1] = (drmp3_uint8)(iscf[gr->n_long_sfb + i + 1] + (gr->subblock_gain[1] << sh)); - iscf[gr->n_long_sfb + i + 2] = (drmp3_uint8)(iscf[gr->n_long_sfb + i + 2] + (gr->subblock_gain[2] << sh)); - } - } else if (gr->preflag) - { - static const drmp3_uint8 g_preamp[10] = { 1,1,1,1,2,2,3,3,3,2 }; - for (i = 0; i < 10; i++) - { - iscf[11 + i] = (drmp3_uint8)(iscf[11 + i] + g_preamp[i]); - } - } - gain_exp = gr->global_gain + DRMP3_BITS_DEQUANTIZER_OUT*4 - 210 - (DRMP3_HDR_IS_MS_STEREO(hdr) ? 2 : 0); - gain = drmp3_L3_ldexp_q2(1 << (DRMP3_MAX_SCFI/4), DRMP3_MAX_SCFI - gain_exp); - for (i = 0; i < (int)(gr->n_long_sfb + gr->n_short_sfb); i++) - { - scf[i] = drmp3_L3_ldexp_q2(gain, iscf[i] << scf_shift); - } -} -static const float g_drmp3_pow43[129 + 16] = { - 0,-1,-2.519842f,-4.326749f,-6.349604f,-8.549880f,-10.902724f,-13.390518f,-16.000000f,-18.720754f,-21.544347f,-24.463781f,-27.473142f,-30.567351f,-33.741992f,-36.993181f, - 0,1,2.519842f,4.326749f,6.349604f,8.549880f,10.902724f,13.390518f,16.000000f,18.720754f,21.544347f,24.463781f,27.473142f,30.567351f,33.741992f,36.993181f,40.317474f,43.711787f,47.173345f,50.699631f,54.288352f,57.937408f,61.644865f,65.408941f,69.227979f,73.100443f,77.024898f,81.000000f,85.024491f,89.097188f,93.216975f,97.382800f,101.593667f,105.848633f,110.146801f,114.487321f,118.869381f,123.292209f,127.755065f,132.257246f,136.798076f,141.376907f,145.993119f,150.646117f,155.335327f,160.060199f,164.820202f,169.614826f,174.443577f,179.305980f,184.201575f,189.129918f,194.090580f,199.083145f,204.107210f,209.162385f,214.248292f,219.364564f,224.510845f,229.686789f,234.892058f,240.126328f,245.389280f,250.680604f,256.000000f,261.347174f,266.721841f,272.123723f,277.552547f,283.008049f,288.489971f,293.998060f,299.532071f,305.091761f,310.676898f,316.287249f,321.922592f,327.582707f,333.267377f,338.976394f,344.709550f,350.466646f,356.247482f,362.051866f,367.879608f,373.730522f,379.604427f,385.501143f,391.420496f,397.362314f,403.326427f,409.312672f,415.320884f,421.350905f,427.402579f,433.475750f,439.570269f,445.685987f,451.822757f,457.980436f,464.158883f,470.357960f,476.577530f,482.817459f,489.077615f,495.357868f,501.658090f,507.978156f,514.317941f,520.677324f,527.056184f,533.454404f,539.871867f,546.308458f,552.764065f,559.238575f,565.731879f,572.243870f,578.774440f,585.323483f,591.890898f,598.476581f,605.080431f,611.702349f,618.342238f,625.000000f,631.675540f,638.368763f,645.079578f -}; -static float drmp3_L3_pow_43(int x) -{ - float frac; - int sign, mult = 256; - if (x < 129) - { - return g_drmp3_pow43[16 + x]; - } - if (x < 1024) - { - mult = 16; - x <<= 3; - } - sign = 2*x & 64; - frac = (float)((x & 63) - sign) / ((x & ~63) + sign); - return g_drmp3_pow43[16 + ((x + sign) >> 6)]*(1.f + frac*((4.f/3) + frac*(2.f/9)))*mult; -} -static void drmp3_L3_huffman(float *dst, drmp3_bs *bs, const drmp3_L3_gr_info *gr_info, const float *scf, int layer3gr_limit) -{ - static const drmp3_int16 tabs[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 785,785,785,785,784,784,784,784,513,513,513,513,513,513,513,513,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256, - -255,1313,1298,1282,785,785,785,785,784,784,784,784,769,769,769,769,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,290,288, - -255,1313,1298,1282,769,769,769,769,529,529,529,529,529,529,529,529,528,528,528,528,528,528,528,528,512,512,512,512,512,512,512,512,290,288, - -253,-318,-351,-367,785,785,785,785,784,784,784,784,769,769,769,769,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,819,818,547,547,275,275,275,275,561,560,515,546,289,274,288,258, - -254,-287,1329,1299,1314,1312,1057,1057,1042,1042,1026,1026,784,784,784,784,529,529,529,529,529,529,529,529,769,769,769,769,768,768,768,768,563,560,306,306,291,259, - -252,-413,-477,-542,1298,-575,1041,1041,784,784,784,784,769,769,769,769,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,-383,-399,1107,1092,1106,1061,849,849,789,789,1104,1091,773,773,1076,1075,341,340,325,309,834,804,577,577,532,532,516,516,832,818,803,816,561,561,531,531,515,546,289,289,288,258, - -252,-429,-493,-559,1057,1057,1042,1042,529,529,529,529,529,529,529,529,784,784,784,784,769,769,769,769,512,512,512,512,512,512,512,512,-382,1077,-415,1106,1061,1104,849,849,789,789,1091,1076,1029,1075,834,834,597,581,340,340,339,324,804,833,532,532,832,772,818,803,817,787,816,771,290,290,290,290,288,258, - -253,-349,-414,-447,-463,1329,1299,-479,1314,1312,1057,1057,1042,1042,1026,1026,785,785,785,785,784,784,784,784,769,769,769,769,768,768,768,768,-319,851,821,-335,836,850,805,849,341,340,325,336,533,533,579,579,564,564,773,832,578,548,563,516,321,276,306,291,304,259, - -251,-572,-733,-830,-863,-879,1041,1041,784,784,784,784,769,769,769,769,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,-511,-527,-543,1396,1351,1381,1366,1395,1335,1380,-559,1334,1138,1138,1063,1063,1350,1392,1031,1031,1062,1062,1364,1363,1120,1120,1333,1348,881,881,881,881,375,374,359,373,343,358,341,325,791,791,1123,1122,-703,1105,1045,-719,865,865,790,790,774,774,1104,1029,338,293,323,308,-799,-815,833,788,772,818,803,816,322,292,307,320,561,531,515,546,289,274,288,258, - -251,-525,-605,-685,-765,-831,-846,1298,1057,1057,1312,1282,785,785,785,785,784,784,784,784,769,769,769,769,512,512,512,512,512,512,512,512,1399,1398,1383,1367,1382,1396,1351,-511,1381,1366,1139,1139,1079,1079,1124,1124,1364,1349,1363,1333,882,882,882,882,807,807,807,807,1094,1094,1136,1136,373,341,535,535,881,775,867,822,774,-591,324,338,-671,849,550,550,866,864,609,609,293,336,534,534,789,835,773,-751,834,804,308,307,833,788,832,772,562,562,547,547,305,275,560,515,290,290, - -252,-397,-477,-557,-622,-653,-719,-735,-750,1329,1299,1314,1057,1057,1042,1042,1312,1282,1024,1024,785,785,785,785,784,784,784,784,769,769,769,769,-383,1127,1141,1111,1126,1140,1095,1110,869,869,883,883,1079,1109,882,882,375,374,807,868,838,881,791,-463,867,822,368,263,852,837,836,-543,610,610,550,550,352,336,534,534,865,774,851,821,850,805,593,533,579,564,773,832,578,578,548,548,577,577,307,276,306,291,516,560,259,259, - -250,-2107,-2507,-2764,-2909,-2974,-3007,-3023,1041,1041,1040,1040,769,769,769,769,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,-767,-1052,-1213,-1277,-1358,-1405,-1469,-1535,-1550,-1582,-1614,-1647,-1662,-1694,-1726,-1759,-1774,-1807,-1822,-1854,-1886,1565,-1919,-1935,-1951,-1967,1731,1730,1580,1717,-1983,1729,1564,-1999,1548,-2015,-2031,1715,1595,-2047,1714,-2063,1610,-2079,1609,-2095,1323,1323,1457,1457,1307,1307,1712,1547,1641,1700,1699,1594,1685,1625,1442,1442,1322,1322,-780,-973,-910,1279,1278,1277,1262,1276,1261,1275,1215,1260,1229,-959,974,974,989,989,-943,735,478,478,495,463,506,414,-1039,1003,958,1017,927,942,987,957,431,476,1272,1167,1228,-1183,1256,-1199,895,895,941,941,1242,1227,1212,1135,1014,1014,490,489,503,487,910,1013,985,925,863,894,970,955,1012,847,-1343,831,755,755,984,909,428,366,754,559,-1391,752,486,457,924,997,698,698,983,893,740,740,908,877,739,739,667,667,953,938,497,287,271,271,683,606,590,712,726,574,302,302,738,736,481,286,526,725,605,711,636,724,696,651,589,681,666,710,364,467,573,695,466,466,301,465,379,379,709,604,665,679,316,316,634,633,436,436,464,269,424,394,452,332,438,363,347,408,393,448,331,422,362,407,392,421,346,406,391,376,375,359,1441,1306,-2367,1290,-2383,1337,-2399,-2415,1426,1321,-2431,1411,1336,-2447,-2463,-2479,1169,1169,1049,1049,1424,1289,1412,1352,1319,-2495,1154,1154,1064,1064,1153,1153,416,390,360,404,403,389,344,374,373,343,358,372,327,357,342,311,356,326,1395,1394,1137,1137,1047,1047,1365,1392,1287,1379,1334,1364,1349,1378,1318,1363,792,792,792,792,1152,1152,1032,1032,1121,1121,1046,1046,1120,1120,1030,1030,-2895,1106,1061,1104,849,849,789,789,1091,1076,1029,1090,1060,1075,833,833,309,324,532,532,832,772,818,803,561,561,531,560,515,546,289,274,288,258, - -250,-1179,-1579,-1836,-1996,-2124,-2253,-2333,-2413,-2477,-2542,-2574,-2607,-2622,-2655,1314,1313,1298,1312,1282,785,785,785,785,1040,1040,1025,1025,768,768,768,768,-766,-798,-830,-862,-895,-911,-927,-943,-959,-975,-991,-1007,-1023,-1039,-1055,-1070,1724,1647,-1103,-1119,1631,1767,1662,1738,1708,1723,-1135,1780,1615,1779,1599,1677,1646,1778,1583,-1151,1777,1567,1737,1692,1765,1722,1707,1630,1751,1661,1764,1614,1736,1676,1763,1750,1645,1598,1721,1691,1762,1706,1582,1761,1566,-1167,1749,1629,767,766,751,765,494,494,735,764,719,749,734,763,447,447,748,718,477,506,431,491,446,476,461,505,415,430,475,445,504,399,460,489,414,503,383,474,429,459,502,502,746,752,488,398,501,473,413,472,486,271,480,270,-1439,-1455,1357,-1471,-1487,-1503,1341,1325,-1519,1489,1463,1403,1309,-1535,1372,1448,1418,1476,1356,1462,1387,-1551,1475,1340,1447,1402,1386,-1567,1068,1068,1474,1461,455,380,468,440,395,425,410,454,364,467,466,464,453,269,409,448,268,432,1371,1473,1432,1417,1308,1460,1355,1446,1459,1431,1083,1083,1401,1416,1458,1445,1067,1067,1370,1457,1051,1051,1291,1430,1385,1444,1354,1415,1400,1443,1082,1082,1173,1113,1186,1066,1185,1050,-1967,1158,1128,1172,1097,1171,1081,-1983,1157,1112,416,266,375,400,1170,1142,1127,1065,793,793,1169,1033,1156,1096,1141,1111,1155,1080,1126,1140,898,898,808,808,897,897,792,792,1095,1152,1032,1125,1110,1139,1079,1124,882,807,838,881,853,791,-2319,867,368,263,822,852,837,866,806,865,-2399,851,352,262,534,534,821,836,594,594,549,549,593,593,533,533,848,773,579,579,564,578,548,563,276,276,577,576,306,291,516,560,305,305,275,259, - -251,-892,-2058,-2620,-2828,-2957,-3023,-3039,1041,1041,1040,1040,769,769,769,769,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,256,-511,-527,-543,-559,1530,-575,-591,1528,1527,1407,1526,1391,1023,1023,1023,1023,1525,1375,1268,1268,1103,1103,1087,1087,1039,1039,1523,-604,815,815,815,815,510,495,509,479,508,463,507,447,431,505,415,399,-734,-782,1262,-815,1259,1244,-831,1258,1228,-847,-863,1196,-879,1253,987,987,748,-767,493,493,462,477,414,414,686,669,478,446,461,445,474,429,487,458,412,471,1266,1264,1009,1009,799,799,-1019,-1276,-1452,-1581,-1677,-1757,-1821,-1886,-1933,-1997,1257,1257,1483,1468,1512,1422,1497,1406,1467,1496,1421,1510,1134,1134,1225,1225,1466,1451,1374,1405,1252,1252,1358,1480,1164,1164,1251,1251,1238,1238,1389,1465,-1407,1054,1101,-1423,1207,-1439,830,830,1248,1038,1237,1117,1223,1148,1236,1208,411,426,395,410,379,269,1193,1222,1132,1235,1221,1116,976,976,1192,1162,1177,1220,1131,1191,963,963,-1647,961,780,-1663,558,558,994,993,437,408,393,407,829,978,813,797,947,-1743,721,721,377,392,844,950,828,890,706,706,812,859,796,960,948,843,934,874,571,571,-1919,690,555,689,421,346,539,539,944,779,918,873,932,842,903,888,570,570,931,917,674,674,-2575,1562,-2591,1609,-2607,1654,1322,1322,1441,1441,1696,1546,1683,1593,1669,1624,1426,1426,1321,1321,1639,1680,1425,1425,1305,1305,1545,1668,1608,1623,1667,1592,1638,1666,1320,1320,1652,1607,1409,1409,1304,1304,1288,1288,1664,1637,1395,1395,1335,1335,1622,1636,1394,1394,1319,1319,1606,1621,1392,1392,1137,1137,1137,1137,345,390,360,375,404,373,1047,-2751,-2767,-2783,1062,1121,1046,-2799,1077,-2815,1106,1061,789,789,1105,1104,263,355,310,340,325,354,352,262,339,324,1091,1076,1029,1090,1060,1075,833,833,788,788,1088,1028,818,818,803,803,561,561,531,531,816,771,546,546,289,274,288,258, - -253,-317,-381,-446,-478,-509,1279,1279,-811,-1179,-1451,-1756,-1900,-2028,-2189,-2253,-2333,-2414,-2445,-2511,-2526,1313,1298,-2559,1041,1041,1040,1040,1025,1025,1024,1024,1022,1007,1021,991,1020,975,1019,959,687,687,1018,1017,671,671,655,655,1016,1015,639,639,758,758,623,623,757,607,756,591,755,575,754,559,543,543,1009,783,-575,-621,-685,-749,496,-590,750,749,734,748,974,989,1003,958,988,973,1002,942,987,957,972,1001,926,986,941,971,956,1000,910,985,925,999,894,970,-1071,-1087,-1102,1390,-1135,1436,1509,1451,1374,-1151,1405,1358,1480,1420,-1167,1507,1494,1389,1342,1465,1435,1450,1326,1505,1310,1493,1373,1479,1404,1492,1464,1419,428,443,472,397,736,526,464,464,486,457,442,471,484,482,1357,1449,1434,1478,1388,1491,1341,1490,1325,1489,1463,1403,1309,1477,1372,1448,1418,1433,1476,1356,1462,1387,-1439,1475,1340,1447,1402,1474,1324,1461,1371,1473,269,448,1432,1417,1308,1460,-1711,1459,-1727,1441,1099,1099,1446,1386,1431,1401,-1743,1289,1083,1083,1160,1160,1458,1445,1067,1067,1370,1457,1307,1430,1129,1129,1098,1098,268,432,267,416,266,400,-1887,1144,1187,1082,1173,1113,1186,1066,1050,1158,1128,1143,1172,1097,1171,1081,420,391,1157,1112,1170,1142,1127,1065,1169,1049,1156,1096,1141,1111,1155,1080,1126,1154,1064,1153,1140,1095,1048,-2159,1125,1110,1137,-2175,823,823,1139,1138,807,807,384,264,368,263,868,838,853,791,867,822,852,837,866,806,865,790,-2319,851,821,836,352,262,850,805,849,-2399,533,533,835,820,336,261,578,548,563,577,532,532,832,772,562,562,547,547,305,275,560,515,290,290,288,258 }; - static const drmp3_uint8 tab32[] = { 130,162,193,209,44,28,76,140,9,9,9,9,9,9,9,9,190,254,222,238,126,94,157,157,109,61,173,205}; - static const drmp3_uint8 tab33[] = { 252,236,220,204,188,172,156,140,124,108,92,76,60,44,28,12 }; - static const drmp3_int16 tabindex[2*16] = { 0,32,64,98,0,132,180,218,292,364,426,538,648,746,0,1126,1460,1460,1460,1460,1460,1460,1460,1460,1842,1842,1842,1842,1842,1842,1842,1842 }; - static const drmp3_uint8 g_linbits[] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,3,4,6,8,10,13,4,5,6,7,8,9,11,13 }; -#define DRMP3_PEEK_BITS(n) (bs_cache >> (32 - (n))) -#define DRMP3_FLUSH_BITS(n) { bs_cache <<= (n); bs_sh += (n); } -#define DRMP3_CHECK_BITS while (bs_sh >= 0) { bs_cache |= (drmp3_uint32)*bs_next_ptr++ << bs_sh; bs_sh -= 8; } -#define DRMP3_BSPOS ((bs_next_ptr - bs->buf)*8 - 24 + bs_sh) - float one = 0.0f; - int ireg = 0, big_val_cnt = gr_info->big_values; - const drmp3_uint8 *sfb = gr_info->sfbtab; - const drmp3_uint8 *bs_next_ptr = bs->buf + bs->pos/8; - drmp3_uint32 bs_cache = (((bs_next_ptr[0]*256u + bs_next_ptr[1])*256u + bs_next_ptr[2])*256u + bs_next_ptr[3]) << (bs->pos & 7); - int pairs_to_decode, np, bs_sh = (bs->pos & 7) - 8; - bs_next_ptr += 4; - while (big_val_cnt > 0) - { - int tab_num = gr_info->table_select[ireg]; - int sfb_cnt = gr_info->region_count[ireg++]; - const drmp3_int16 *codebook = tabs + tabindex[tab_num]; - int linbits = g_linbits[tab_num]; - if (linbits) - { - do - { - np = *sfb++ / 2; - pairs_to_decode = DRMP3_MIN(big_val_cnt, np); - one = *scf++; - do - { - int j, w = 5; - int leaf = codebook[DRMP3_PEEK_BITS(w)]; - while (leaf < 0) - { - DRMP3_FLUSH_BITS(w); - w = leaf & 7; - leaf = codebook[DRMP3_PEEK_BITS(w) - (leaf >> 3)]; - } - DRMP3_FLUSH_BITS(leaf >> 8); - for (j = 0; j < 2; j++, dst++, leaf >>= 4) - { - int lsb = leaf & 0x0F; - if (lsb == 15) - { - lsb += DRMP3_PEEK_BITS(linbits); - DRMP3_FLUSH_BITS(linbits); - DRMP3_CHECK_BITS; - *dst = one*drmp3_L3_pow_43(lsb)*((drmp3_int32)bs_cache < 0 ? -1: 1); - } else - { - *dst = g_drmp3_pow43[16 + lsb - 16*(bs_cache >> 31)]*one; - } - DRMP3_FLUSH_BITS(lsb ? 1 : 0); - } - DRMP3_CHECK_BITS; - } while (--pairs_to_decode); - } while ((big_val_cnt -= np) > 0 && --sfb_cnt >= 0); - } else - { - do - { - np = *sfb++ / 2; - pairs_to_decode = DRMP3_MIN(big_val_cnt, np); - one = *scf++; - do - { - int j, w = 5; - int leaf = codebook[DRMP3_PEEK_BITS(w)]; - while (leaf < 0) - { - DRMP3_FLUSH_BITS(w); - w = leaf & 7; - leaf = codebook[DRMP3_PEEK_BITS(w) - (leaf >> 3)]; - } - DRMP3_FLUSH_BITS(leaf >> 8); - for (j = 0; j < 2; j++, dst++, leaf >>= 4) - { - int lsb = leaf & 0x0F; - *dst = g_drmp3_pow43[16 + lsb - 16*(bs_cache >> 31)]*one; - DRMP3_FLUSH_BITS(lsb ? 1 : 0); - } - DRMP3_CHECK_BITS; - } while (--pairs_to_decode); - } while ((big_val_cnt -= np) > 0 && --sfb_cnt >= 0); - } - } - for (np = 1 - big_val_cnt;; dst += 4) - { - const drmp3_uint8 *codebook_count1 = (gr_info->count1_table) ? tab33 : tab32; - int leaf = codebook_count1[DRMP3_PEEK_BITS(4)]; - if (!(leaf & 8)) - { - leaf = codebook_count1[(leaf >> 3) + (bs_cache << 4 >> (32 - (leaf & 3)))]; - } - DRMP3_FLUSH_BITS(leaf & 7); - if (DRMP3_BSPOS > layer3gr_limit) - { - break; - } -#define DRMP3_RELOAD_SCALEFACTOR if (!--np) { np = *sfb++/2; if (!np) break; one = *scf++; } -#define DRMP3_DEQ_COUNT1(s) if (leaf & (128 >> s)) { dst[s] = ((drmp3_int32)bs_cache < 0) ? -one : one; DRMP3_FLUSH_BITS(1) } - DRMP3_RELOAD_SCALEFACTOR; - DRMP3_DEQ_COUNT1(0); - DRMP3_DEQ_COUNT1(1); - DRMP3_RELOAD_SCALEFACTOR; - DRMP3_DEQ_COUNT1(2); - DRMP3_DEQ_COUNT1(3); - DRMP3_CHECK_BITS; - } - bs->pos = layer3gr_limit; -} -static void drmp3_L3_midside_stereo(float *left, int n) -{ - int i = 0; - float *right = left + 576; -#if DRMP3_HAVE_SIMD - if (drmp3_have_simd()) - { - for (; i < n - 3; i += 4) - { - drmp3_f4 vl = DRMP3_VLD(left + i); - drmp3_f4 vr = DRMP3_VLD(right + i); - DRMP3_VSTORE(left + i, DRMP3_VADD(vl, vr)); - DRMP3_VSTORE(right + i, DRMP3_VSUB(vl, vr)); - } -#ifdef __GNUC__ - if (__builtin_constant_p(n % 4 == 0) && n % 4 == 0) - return; -#endif - } -#endif - for (; i < n; i++) - { - float a = left[i]; - float b = right[i]; - left[i] = a + b; - right[i] = a - b; - } -} -static void drmp3_L3_intensity_stereo_band(float *left, int n, float kl, float kr) -{ - int i; - for (i = 0; i < n; i++) - { - left[i + 576] = left[i]*kr; - left[i] = left[i]*kl; - } -} -static void drmp3_L3_stereo_top_band(const float *right, const drmp3_uint8 *sfb, int nbands, int max_band[3]) -{ - int i, k; - max_band[0] = max_band[1] = max_band[2] = -1; - for (i = 0; i < nbands; i++) - { - for (k = 0; k < sfb[i]; k += 2) - { - if (right[k] != 0 || right[k + 1] != 0) - { - max_band[i % 3] = i; - break; - } - } - right += sfb[i]; - } -} -static void drmp3_L3_stereo_process(float *left, const drmp3_uint8 *ist_pos, const drmp3_uint8 *sfb, const drmp3_uint8 *hdr, int max_band[3], int mpeg2_sh) -{ - static const float g_pan[7*2] = { 0,1,0.21132487f,0.78867513f,0.36602540f,0.63397460f,0.5f,0.5f,0.63397460f,0.36602540f,0.78867513f,0.21132487f,1,0 }; - unsigned i, max_pos = DRMP3_HDR_TEST_MPEG1(hdr) ? 7 : 64; - for (i = 0; sfb[i]; i++) - { - unsigned ipos = ist_pos[i]; - if ((int)i > max_band[i % 3] && ipos < max_pos) - { - float kl, kr, s = DRMP3_HDR_TEST_MS_STEREO(hdr) ? 1.41421356f : 1; - if (DRMP3_HDR_TEST_MPEG1(hdr)) - { - kl = g_pan[2*ipos]; - kr = g_pan[2*ipos + 1]; - } else - { - kl = 1; - kr = drmp3_L3_ldexp_q2(1, (ipos + 1) >> 1 << mpeg2_sh); - if (ipos & 1) - { - kl = kr; - kr = 1; - } - } - drmp3_L3_intensity_stereo_band(left, sfb[i], kl*s, kr*s); - } else if (DRMP3_HDR_TEST_MS_STEREO(hdr)) - { - drmp3_L3_midside_stereo(left, sfb[i]); - } - left += sfb[i]; - } -} -static void drmp3_L3_intensity_stereo(float *left, drmp3_uint8 *ist_pos, const drmp3_L3_gr_info *gr, const drmp3_uint8 *hdr) -{ - int max_band[3], n_sfb = gr->n_long_sfb + gr->n_short_sfb; - int i, max_blocks = gr->n_short_sfb ? 3 : 1; - drmp3_L3_stereo_top_band(left + 576, gr->sfbtab, n_sfb, max_band); - if (gr->n_long_sfb) - { - max_band[0] = max_band[1] = max_band[2] = DRMP3_MAX(DRMP3_MAX(max_band[0], max_band[1]), max_band[2]); - } - for (i = 0; i < max_blocks; i++) - { - int default_pos = DRMP3_HDR_TEST_MPEG1(hdr) ? 3 : 0; - int itop = n_sfb - max_blocks + i; - int prev = itop - max_blocks; - ist_pos[itop] = (drmp3_uint8)(max_band[i] >= prev ? default_pos : ist_pos[prev]); - } - drmp3_L3_stereo_process(left, ist_pos, gr->sfbtab, hdr, max_band, gr[1].scalefac_compress & 1); -} -static void drmp3_L3_reorder(float *grbuf, float *scratch, const drmp3_uint8 *sfb) -{ - int i, len; - float *src = grbuf, *dst = scratch; - for (;0 != (len = *sfb); sfb += 3, src += 2*len) - { - for (i = 0; i < len; i++, src++) - { - *dst++ = src[0*len]; - *dst++ = src[1*len]; - *dst++ = src[2*len]; - } - } - DRMP3_COPY_MEMORY(grbuf, scratch, (dst - scratch)*sizeof(float)); -} -static void drmp3_L3_antialias(float *grbuf, int nbands) -{ - static const float g_aa[2][8] = { - {0.85749293f,0.88174200f,0.94962865f,0.98331459f,0.99551782f,0.99916056f,0.99989920f,0.99999316f}, - {0.51449576f,0.47173197f,0.31337745f,0.18191320f,0.09457419f,0.04096558f,0.01419856f,0.00369997f} - }; - for (; nbands > 0; nbands--, grbuf += 18) - { - int i = 0; -#if DRMP3_HAVE_SIMD - if (drmp3_have_simd()) for (; i < 8; i += 4) - { - drmp3_f4 vu = DRMP3_VLD(grbuf + 18 + i); - drmp3_f4 vd = DRMP3_VLD(grbuf + 14 - i); - drmp3_f4 vc0 = DRMP3_VLD(g_aa[0] + i); - drmp3_f4 vc1 = DRMP3_VLD(g_aa[1] + i); - vd = DRMP3_VREV(vd); - DRMP3_VSTORE(grbuf + 18 + i, DRMP3_VSUB(DRMP3_VMUL(vu, vc0), DRMP3_VMUL(vd, vc1))); - vd = DRMP3_VADD(DRMP3_VMUL(vu, vc1), DRMP3_VMUL(vd, vc0)); - DRMP3_VSTORE(grbuf + 14 - i, DRMP3_VREV(vd)); - } -#endif -#ifndef DR_MP3_ONLY_SIMD - for(; i < 8; i++) - { - float u = grbuf[18 + i]; - float d = grbuf[17 - i]; - grbuf[18 + i] = u*g_aa[0][i] - d*g_aa[1][i]; - grbuf[17 - i] = u*g_aa[1][i] + d*g_aa[0][i]; - } -#endif - } -} -static void drmp3_L3_dct3_9(float *y) -{ - float s0, s1, s2, s3, s4, s5, s6, s7, s8, t0, t2, t4; - s0 = y[0]; s2 = y[2]; s4 = y[4]; s6 = y[6]; s8 = y[8]; - t0 = s0 + s6*0.5f; - s0 -= s6; - t4 = (s4 + s2)*0.93969262f; - t2 = (s8 + s2)*0.76604444f; - s6 = (s4 - s8)*0.17364818f; - s4 += s8 - s2; - s2 = s0 - s4*0.5f; - y[4] = s4 + s0; - s8 = t0 - t2 + s6; - s0 = t0 - t4 + t2; - s4 = t0 + t4 - s6; - s1 = y[1]; s3 = y[3]; s5 = y[5]; s7 = y[7]; - s3 *= 0.86602540f; - t0 = (s5 + s1)*0.98480775f; - t4 = (s5 - s7)*0.34202014f; - t2 = (s1 + s7)*0.64278761f; - s1 = (s1 - s5 - s7)*0.86602540f; - s5 = t0 - s3 - t2; - s7 = t4 - s3 - t0; - s3 = t4 + s3 - t2; - y[0] = s4 - s7; - y[1] = s2 + s1; - y[2] = s0 - s3; - y[3] = s8 + s5; - y[5] = s8 - s5; - y[6] = s0 + s3; - y[7] = s2 - s1; - y[8] = s4 + s7; -} -static void drmp3_L3_imdct36(float *grbuf, float *overlap, const float *window, int nbands) -{ - int i, j; - static const float g_twid9[18] = { - 0.73727734f,0.79335334f,0.84339145f,0.88701083f,0.92387953f,0.95371695f,0.97629601f,0.99144486f,0.99904822f,0.67559021f,0.60876143f,0.53729961f,0.46174861f,0.38268343f,0.30070580f,0.21643961f,0.13052619f,0.04361938f - }; - for (j = 0; j < nbands; j++, grbuf += 18, overlap += 9) - { - float co[9], si[9]; - co[0] = -grbuf[0]; - si[0] = grbuf[17]; - for (i = 0; i < 4; i++) - { - si[8 - 2*i] = grbuf[4*i + 1] - grbuf[4*i + 2]; - co[1 + 2*i] = grbuf[4*i + 1] + grbuf[4*i + 2]; - si[7 - 2*i] = grbuf[4*i + 4] - grbuf[4*i + 3]; - co[2 + 2*i] = -(grbuf[4*i + 3] + grbuf[4*i + 4]); - } - drmp3_L3_dct3_9(co); - drmp3_L3_dct3_9(si); - si[1] = -si[1]; - si[3] = -si[3]; - si[5] = -si[5]; - si[7] = -si[7]; - i = 0; -#if DRMP3_HAVE_SIMD - if (drmp3_have_simd()) for (; i < 8; i += 4) - { - drmp3_f4 vovl = DRMP3_VLD(overlap + i); - drmp3_f4 vc = DRMP3_VLD(co + i); - drmp3_f4 vs = DRMP3_VLD(si + i); - drmp3_f4 vr0 = DRMP3_VLD(g_twid9 + i); - drmp3_f4 vr1 = DRMP3_VLD(g_twid9 + 9 + i); - drmp3_f4 vw0 = DRMP3_VLD(window + i); - drmp3_f4 vw1 = DRMP3_VLD(window + 9 + i); - drmp3_f4 vsum = DRMP3_VADD(DRMP3_VMUL(vc, vr1), DRMP3_VMUL(vs, vr0)); - DRMP3_VSTORE(overlap + i, DRMP3_VSUB(DRMP3_VMUL(vc, vr0), DRMP3_VMUL(vs, vr1))); - DRMP3_VSTORE(grbuf + i, DRMP3_VSUB(DRMP3_VMUL(vovl, vw0), DRMP3_VMUL(vsum, vw1))); - vsum = DRMP3_VADD(DRMP3_VMUL(vovl, vw1), DRMP3_VMUL(vsum, vw0)); - DRMP3_VSTORE(grbuf + 14 - i, DRMP3_VREV(vsum)); - } -#endif - for (; i < 9; i++) - { - float ovl = overlap[i]; - float sum = co[i]*g_twid9[9 + i] + si[i]*g_twid9[0 + i]; - overlap[i] = co[i]*g_twid9[0 + i] - si[i]*g_twid9[9 + i]; - grbuf[i] = ovl*window[0 + i] - sum*window[9 + i]; - grbuf[17 - i] = ovl*window[9 + i] + sum*window[0 + i]; - } - } -} -static void drmp3_L3_idct3(float x0, float x1, float x2, float *dst) -{ - float m1 = x1*0.86602540f; - float a1 = x0 - x2*0.5f; - dst[1] = x0 + x2; - dst[0] = a1 + m1; - dst[2] = a1 - m1; -} -static void drmp3_L3_imdct12(float *x, float *dst, float *overlap) -{ - static const float g_twid3[6] = { 0.79335334f,0.92387953f,0.99144486f, 0.60876143f,0.38268343f,0.13052619f }; - float co[3], si[3]; - int i; - drmp3_L3_idct3(-x[0], x[6] + x[3], x[12] + x[9], co); - drmp3_L3_idct3(x[15], x[12] - x[9], x[6] - x[3], si); - si[1] = -si[1]; - for (i = 0; i < 3; i++) - { - float ovl = overlap[i]; - float sum = co[i]*g_twid3[3 + i] + si[i]*g_twid3[0 + i]; - overlap[i] = co[i]*g_twid3[0 + i] - si[i]*g_twid3[3 + i]; - dst[i] = ovl*g_twid3[2 - i] - sum*g_twid3[5 - i]; - dst[5 - i] = ovl*g_twid3[5 - i] + sum*g_twid3[2 - i]; - } -} -static void drmp3_L3_imdct_short(float *grbuf, float *overlap, int nbands) -{ - for (;nbands > 0; nbands--, overlap += 9, grbuf += 18) - { - float tmp[18]; - DRMP3_COPY_MEMORY(tmp, grbuf, sizeof(tmp)); - DRMP3_COPY_MEMORY(grbuf, overlap, 6*sizeof(float)); - drmp3_L3_imdct12(tmp, grbuf + 6, overlap + 6); - drmp3_L3_imdct12(tmp + 1, grbuf + 12, overlap + 6); - drmp3_L3_imdct12(tmp + 2, overlap, overlap + 6); - } -} -static void drmp3_L3_change_sign(float *grbuf) -{ - int b, i; - for (b = 0, grbuf += 18; b < 32; b += 2, grbuf += 36) - for (i = 1; i < 18; i += 2) - grbuf[i] = -grbuf[i]; -} -static void drmp3_L3_imdct_gr(float *grbuf, float *overlap, unsigned block_type, unsigned n_long_bands) -{ - static const float g_mdct_window[2][18] = { - { 0.99904822f,0.99144486f,0.97629601f,0.95371695f,0.92387953f,0.88701083f,0.84339145f,0.79335334f,0.73727734f,0.04361938f,0.13052619f,0.21643961f,0.30070580f,0.38268343f,0.46174861f,0.53729961f,0.60876143f,0.67559021f }, - { 1,1,1,1,1,1,0.99144486f,0.92387953f,0.79335334f,0,0,0,0,0,0,0.13052619f,0.38268343f,0.60876143f } - }; - if (n_long_bands) - { - drmp3_L3_imdct36(grbuf, overlap, g_mdct_window[0], n_long_bands); - grbuf += 18*n_long_bands; - overlap += 9*n_long_bands; - } - if (block_type == DRMP3_SHORT_BLOCK_TYPE) - drmp3_L3_imdct_short(grbuf, overlap, 32 - n_long_bands); - else - drmp3_L3_imdct36(grbuf, overlap, g_mdct_window[block_type == DRMP3_STOP_BLOCK_TYPE], 32 - n_long_bands); -} -static void drmp3_L3_save_reservoir(drmp3dec *h, drmp3dec_scratch *s) -{ - int pos = (s->bs.pos + 7)/8u; - int remains = s->bs.limit/8u - pos; - if (remains > DRMP3_MAX_BITRESERVOIR_BYTES) - { - pos += remains - DRMP3_MAX_BITRESERVOIR_BYTES; - remains = DRMP3_MAX_BITRESERVOIR_BYTES; - } - if (remains > 0) - { - DRMP3_MOVE_MEMORY(h->reserv_buf, s->maindata + pos, remains); - } - h->reserv = remains; -} -static int drmp3_L3_restore_reservoir(drmp3dec *h, drmp3_bs *bs, drmp3dec_scratch *s, int main_data_begin) -{ - int frame_bytes = (bs->limit - bs->pos)/8; - int bytes_have = DRMP3_MIN(h->reserv, main_data_begin); - DRMP3_COPY_MEMORY(s->maindata, h->reserv_buf + DRMP3_MAX(0, h->reserv - main_data_begin), DRMP3_MIN(h->reserv, main_data_begin)); - DRMP3_COPY_MEMORY(s->maindata + bytes_have, bs->buf + bs->pos/8, frame_bytes); - drmp3_bs_init(&s->bs, s->maindata, bytes_have + frame_bytes); - return h->reserv >= main_data_begin; -} -static void drmp3_L3_decode(drmp3dec *h, drmp3dec_scratch *s, drmp3_L3_gr_info *gr_info, int nch) -{ - int ch; - for (ch = 0; ch < nch; ch++) - { - int layer3gr_limit = s->bs.pos + gr_info[ch].part_23_length; - drmp3_L3_decode_scalefactors(h->header, s->ist_pos[ch], &s->bs, gr_info + ch, s->scf, ch); - drmp3_L3_huffman(s->grbuf[ch], &s->bs, gr_info + ch, s->scf, layer3gr_limit); - } - if (DRMP3_HDR_TEST_I_STEREO(h->header)) - { - drmp3_L3_intensity_stereo(s->grbuf[0], s->ist_pos[1], gr_info, h->header); - } else if (DRMP3_HDR_IS_MS_STEREO(h->header)) - { - drmp3_L3_midside_stereo(s->grbuf[0], 576); - } - for (ch = 0; ch < nch; ch++, gr_info++) - { - int aa_bands = 31; - int n_long_bands = (gr_info->mixed_block_flag ? 2 : 0) << (int)(DRMP3_HDR_GET_MY_SAMPLE_RATE(h->header) == 2); - if (gr_info->n_short_sfb) - { - aa_bands = n_long_bands - 1; - drmp3_L3_reorder(s->grbuf[ch] + n_long_bands*18, s->syn[0], gr_info->sfbtab + gr_info->n_long_sfb); - } - drmp3_L3_antialias(s->grbuf[ch], aa_bands); - drmp3_L3_imdct_gr(s->grbuf[ch], h->mdct_overlap[ch], gr_info->block_type, n_long_bands); - drmp3_L3_change_sign(s->grbuf[ch]); - } -} -static void drmp3d_DCT_II(float *grbuf, int n) -{ - static const float g_sec[24] = { - 10.19000816f,0.50060302f,0.50241929f,3.40760851f,0.50547093f,0.52249861f,2.05778098f,0.51544732f,0.56694406f,1.48416460f,0.53104258f,0.64682180f,1.16943991f,0.55310392f,0.78815460f,0.97256821f,0.58293498f,1.06067765f,0.83934963f,0.62250412f,1.72244716f,0.74453628f,0.67480832f,5.10114861f - }; - int i, k = 0; -#if DRMP3_HAVE_SIMD - if (drmp3_have_simd()) for (; k < n; k += 4) - { - drmp3_f4 t[4][8], *x; - float *y = grbuf + k; - for (x = t[0], i = 0; i < 8; i++, x++) - { - drmp3_f4 x0 = DRMP3_VLD(&y[i*18]); - drmp3_f4 x1 = DRMP3_VLD(&y[(15 - i)*18]); - drmp3_f4 x2 = DRMP3_VLD(&y[(16 + i)*18]); - drmp3_f4 x3 = DRMP3_VLD(&y[(31 - i)*18]); - drmp3_f4 t0 = DRMP3_VADD(x0, x3); - drmp3_f4 t1 = DRMP3_VADD(x1, x2); - drmp3_f4 t2 = DRMP3_VMUL_S(DRMP3_VSUB(x1, x2), g_sec[3*i + 0]); - drmp3_f4 t3 = DRMP3_VMUL_S(DRMP3_VSUB(x0, x3), g_sec[3*i + 1]); - x[0] = DRMP3_VADD(t0, t1); - x[8] = DRMP3_VMUL_S(DRMP3_VSUB(t0, t1), g_sec[3*i + 2]); - x[16] = DRMP3_VADD(t3, t2); - x[24] = DRMP3_VMUL_S(DRMP3_VSUB(t3, t2), g_sec[3*i + 2]); - } - for (x = t[0], i = 0; i < 4; i++, x += 8) - { - drmp3_f4 x0 = x[0], x1 = x[1], x2 = x[2], x3 = x[3], x4 = x[4], x5 = x[5], x6 = x[6], x7 = x[7], xt; - xt = DRMP3_VSUB(x0, x7); x0 = DRMP3_VADD(x0, x7); - x7 = DRMP3_VSUB(x1, x6); x1 = DRMP3_VADD(x1, x6); - x6 = DRMP3_VSUB(x2, x5); x2 = DRMP3_VADD(x2, x5); - x5 = DRMP3_VSUB(x3, x4); x3 = DRMP3_VADD(x3, x4); - x4 = DRMP3_VSUB(x0, x3); x0 = DRMP3_VADD(x0, x3); - x3 = DRMP3_VSUB(x1, x2); x1 = DRMP3_VADD(x1, x2); - x[0] = DRMP3_VADD(x0, x1); - x[4] = DRMP3_VMUL_S(DRMP3_VSUB(x0, x1), 0.70710677f); - x5 = DRMP3_VADD(x5, x6); - x6 = DRMP3_VMUL_S(DRMP3_VADD(x6, x7), 0.70710677f); - x7 = DRMP3_VADD(x7, xt); - x3 = DRMP3_VMUL_S(DRMP3_VADD(x3, x4), 0.70710677f); - x5 = DRMP3_VSUB(x5, DRMP3_VMUL_S(x7, 0.198912367f)); - x7 = DRMP3_VADD(x7, DRMP3_VMUL_S(x5, 0.382683432f)); - x5 = DRMP3_VSUB(x5, DRMP3_VMUL_S(x7, 0.198912367f)); - x0 = DRMP3_VSUB(xt, x6); xt = DRMP3_VADD(xt, x6); - x[1] = DRMP3_VMUL_S(DRMP3_VADD(xt, x7), 0.50979561f); - x[2] = DRMP3_VMUL_S(DRMP3_VADD(x4, x3), 0.54119611f); - x[3] = DRMP3_VMUL_S(DRMP3_VSUB(x0, x5), 0.60134488f); - x[5] = DRMP3_VMUL_S(DRMP3_VADD(x0, x5), 0.89997619f); - x[6] = DRMP3_VMUL_S(DRMP3_VSUB(x4, x3), 1.30656302f); - x[7] = DRMP3_VMUL_S(DRMP3_VSUB(xt, x7), 2.56291556f); - } - if (k > n - 3) - { -#if DRMP3_HAVE_SSE -#define DRMP3_VSAVE2(i, v) _mm_storel_pi((__m64 *)(void*)&y[i*18], v) -#else -#define DRMP3_VSAVE2(i, v) vst1_f32((float32_t *)&y[(i)*18], vget_low_f32(v)) -#endif - for (i = 0; i < 7; i++, y += 4*18) - { - drmp3_f4 s = DRMP3_VADD(t[3][i], t[3][i + 1]); - DRMP3_VSAVE2(0, t[0][i]); - DRMP3_VSAVE2(1, DRMP3_VADD(t[2][i], s)); - DRMP3_VSAVE2(2, DRMP3_VADD(t[1][i], t[1][i + 1])); - DRMP3_VSAVE2(3, DRMP3_VADD(t[2][1 + i], s)); - } - DRMP3_VSAVE2(0, t[0][7]); - DRMP3_VSAVE2(1, DRMP3_VADD(t[2][7], t[3][7])); - DRMP3_VSAVE2(2, t[1][7]); - DRMP3_VSAVE2(3, t[3][7]); - } else - { -#define DRMP3_VSAVE4(i, v) DRMP3_VSTORE(&y[(i)*18], v) - for (i = 0; i < 7; i++, y += 4*18) - { - drmp3_f4 s = DRMP3_VADD(t[3][i], t[3][i + 1]); - DRMP3_VSAVE4(0, t[0][i]); - DRMP3_VSAVE4(1, DRMP3_VADD(t[2][i], s)); - DRMP3_VSAVE4(2, DRMP3_VADD(t[1][i], t[1][i + 1])); - DRMP3_VSAVE4(3, DRMP3_VADD(t[2][1 + i], s)); - } - DRMP3_VSAVE4(0, t[0][7]); - DRMP3_VSAVE4(1, DRMP3_VADD(t[2][7], t[3][7])); - DRMP3_VSAVE4(2, t[1][7]); - DRMP3_VSAVE4(3, t[3][7]); - } - } else -#endif -#ifdef DR_MP3_ONLY_SIMD - {} -#else - for (; k < n; k++) - { - float t[4][8], *x, *y = grbuf + k; - for (x = t[0], i = 0; i < 8; i++, x++) - { - float x0 = y[i*18]; - float x1 = y[(15 - i)*18]; - float x2 = y[(16 + i)*18]; - float x3 = y[(31 - i)*18]; - float t0 = x0 + x3; - float t1 = x1 + x2; - float t2 = (x1 - x2)*g_sec[3*i + 0]; - float t3 = (x0 - x3)*g_sec[3*i + 1]; - x[0] = t0 + t1; - x[8] = (t0 - t1)*g_sec[3*i + 2]; - x[16] = t3 + t2; - x[24] = (t3 - t2)*g_sec[3*i + 2]; - } - for (x = t[0], i = 0; i < 4; i++, x += 8) - { - float x0 = x[0], x1 = x[1], x2 = x[2], x3 = x[3], x4 = x[4], x5 = x[5], x6 = x[6], x7 = x[7], xt; - xt = x0 - x7; x0 += x7; - x7 = x1 - x6; x1 += x6; - x6 = x2 - x5; x2 += x5; - x5 = x3 - x4; x3 += x4; - x4 = x0 - x3; x0 += x3; - x3 = x1 - x2; x1 += x2; - x[0] = x0 + x1; - x[4] = (x0 - x1)*0.70710677f; - x5 = x5 + x6; - x6 = (x6 + x7)*0.70710677f; - x7 = x7 + xt; - x3 = (x3 + x4)*0.70710677f; - x5 -= x7*0.198912367f; - x7 += x5*0.382683432f; - x5 -= x7*0.198912367f; - x0 = xt - x6; xt += x6; - x[1] = (xt + x7)*0.50979561f; - x[2] = (x4 + x3)*0.54119611f; - x[3] = (x0 - x5)*0.60134488f; - x[5] = (x0 + x5)*0.89997619f; - x[6] = (x4 - x3)*1.30656302f; - x[7] = (xt - x7)*2.56291556f; - } - for (i = 0; i < 7; i++, y += 4*18) - { - y[0*18] = t[0][i]; - y[1*18] = t[2][i] + t[3][i] + t[3][i + 1]; - y[2*18] = t[1][i] + t[1][i + 1]; - y[3*18] = t[2][i + 1] + t[3][i] + t[3][i + 1]; - } - y[0*18] = t[0][7]; - y[1*18] = t[2][7] + t[3][7]; - y[2*18] = t[1][7]; - y[3*18] = t[3][7]; - } -#endif -} -#ifndef DR_MP3_FLOAT_OUTPUT -typedef drmp3_int16 drmp3d_sample_t; -static drmp3_int16 drmp3d_scale_pcm(float sample) -{ - drmp3_int16 s; -#if DRMP3_HAVE_ARMV6 - drmp3_int32 s32 = (drmp3_int32)(sample + .5f); - s32 -= (s32 < 0); - s = (drmp3_int16)drmp3_clip_int16_arm(s32); -#else - if (sample >= 32766.5) return (drmp3_int16) 32767; - if (sample <= -32767.5) return (drmp3_int16)-32768; - s = (drmp3_int16)(sample + .5f); - s -= (s < 0); -#endif - return s; -} -#else -typedef float drmp3d_sample_t; -static float drmp3d_scale_pcm(float sample) -{ - return sample*(1.f/32768.f); -} -#endif -static void drmp3d_synth_pair(drmp3d_sample_t *pcm, int nch, const float *z) -{ - float a; - a = (z[14*64] - z[ 0]) * 29; - a += (z[ 1*64] + z[13*64]) * 213; - a += (z[12*64] - z[ 2*64]) * 459; - a += (z[ 3*64] + z[11*64]) * 2037; - a += (z[10*64] - z[ 4*64]) * 5153; - a += (z[ 5*64] + z[ 9*64]) * 6574; - a += (z[ 8*64] - z[ 6*64]) * 37489; - a += z[ 7*64] * 75038; - pcm[0] = drmp3d_scale_pcm(a); - z += 2; - a = z[14*64] * 104; - a += z[12*64] * 1567; - a += z[10*64] * 9727; - a += z[ 8*64] * 64019; - a += z[ 6*64] * -9975; - a += z[ 4*64] * -45; - a += z[ 2*64] * 146; - a += z[ 0*64] * -5; - pcm[16*nch] = drmp3d_scale_pcm(a); -} -static void drmp3d_synth(float *xl, drmp3d_sample_t *dstl, int nch, float *lins) -{ - int i; - float *xr = xl + 576*(nch - 1); - drmp3d_sample_t *dstr = dstl + (nch - 1); - static const float g_win[] = { - -1,26,-31,208,218,401,-519,2063,2000,4788,-5517,7134,5959,35640,-39336,74992, - -1,24,-35,202,222,347,-581,2080,1952,4425,-5879,7640,5288,33791,-41176,74856, - -1,21,-38,196,225,294,-645,2087,1893,4063,-6237,8092,4561,31947,-43006,74630, - -1,19,-41,190,227,244,-711,2085,1822,3705,-6589,8492,3776,30112,-44821,74313, - -1,17,-45,183,228,197,-779,2075,1739,3351,-6935,8840,2935,28289,-46617,73908, - -1,16,-49,176,228,153,-848,2057,1644,3004,-7271,9139,2037,26482,-48390,73415, - -2,14,-53,169,227,111,-919,2032,1535,2663,-7597,9389,1082,24694,-50137,72835, - -2,13,-58,161,224,72,-991,2001,1414,2330,-7910,9592,70,22929,-51853,72169, - -2,11,-63,154,221,36,-1064,1962,1280,2006,-8209,9750,-998,21189,-53534,71420, - -2,10,-68,147,215,2,-1137,1919,1131,1692,-8491,9863,-2122,19478,-55178,70590, - -3,9,-73,139,208,-29,-1210,1870,970,1388,-8755,9935,-3300,17799,-56778,69679, - -3,8,-79,132,200,-57,-1283,1817,794,1095,-8998,9966,-4533,16155,-58333,68692, - -4,7,-85,125,189,-83,-1356,1759,605,814,-9219,9959,-5818,14548,-59838,67629, - -4,7,-91,117,177,-106,-1428,1698,402,545,-9416,9916,-7154,12980,-61289,66494, - -5,6,-97,111,163,-127,-1498,1634,185,288,-9585,9838,-8540,11455,-62684,65290 - }; - float *zlin = lins + 15*64; - const float *w = g_win; - zlin[4*15] = xl[18*16]; - zlin[4*15 + 1] = xr[18*16]; - zlin[4*15 + 2] = xl[0]; - zlin[4*15 + 3] = xr[0]; - zlin[4*31] = xl[1 + 18*16]; - zlin[4*31 + 1] = xr[1 + 18*16]; - zlin[4*31 + 2] = xl[1]; - zlin[4*31 + 3] = xr[1]; - drmp3d_synth_pair(dstr, nch, lins + 4*15 + 1); - drmp3d_synth_pair(dstr + 32*nch, nch, lins + 4*15 + 64 + 1); - drmp3d_synth_pair(dstl, nch, lins + 4*15); - drmp3d_synth_pair(dstl + 32*nch, nch, lins + 4*15 + 64); -#if DRMP3_HAVE_SIMD - if (drmp3_have_simd()) for (i = 14; i >= 0; i--) - { -#define DRMP3_VLOAD(k) drmp3_f4 w0 = DRMP3_VSET(*w++); drmp3_f4 w1 = DRMP3_VSET(*w++); drmp3_f4 vz = DRMP3_VLD(&zlin[4*i - 64*k]); drmp3_f4 vy = DRMP3_VLD(&zlin[4*i - 64*(15 - k)]); -#define DRMP3_V0(k) { DRMP3_VLOAD(k) b = DRMP3_VADD(DRMP3_VMUL(vz, w1), DRMP3_VMUL(vy, w0)) ; a = DRMP3_VSUB(DRMP3_VMUL(vz, w0), DRMP3_VMUL(vy, w1)); } -#define DRMP3_V1(k) { DRMP3_VLOAD(k) b = DRMP3_VADD(b, DRMP3_VADD(DRMP3_VMUL(vz, w1), DRMP3_VMUL(vy, w0))); a = DRMP3_VADD(a, DRMP3_VSUB(DRMP3_VMUL(vz, w0), DRMP3_VMUL(vy, w1))); } -#define DRMP3_V2(k) { DRMP3_VLOAD(k) b = DRMP3_VADD(b, DRMP3_VADD(DRMP3_VMUL(vz, w1), DRMP3_VMUL(vy, w0))); a = DRMP3_VADD(a, DRMP3_VSUB(DRMP3_VMUL(vy, w1), DRMP3_VMUL(vz, w0))); } - drmp3_f4 a, b; - zlin[4*i] = xl[18*(31 - i)]; - zlin[4*i + 1] = xr[18*(31 - i)]; - zlin[4*i + 2] = xl[1 + 18*(31 - i)]; - zlin[4*i + 3] = xr[1 + 18*(31 - i)]; - zlin[4*i + 64] = xl[1 + 18*(1 + i)]; - zlin[4*i + 64 + 1] = xr[1 + 18*(1 + i)]; - zlin[4*i - 64 + 2] = xl[18*(1 + i)]; - zlin[4*i - 64 + 3] = xr[18*(1 + i)]; - DRMP3_V0(0) DRMP3_V2(1) DRMP3_V1(2) DRMP3_V2(3) DRMP3_V1(4) DRMP3_V2(5) DRMP3_V1(6) DRMP3_V2(7) - { -#ifndef DR_MP3_FLOAT_OUTPUT -#if DRMP3_HAVE_SSE - static const drmp3_f4 g_max = { 32767.0f, 32767.0f, 32767.0f, 32767.0f }; - static const drmp3_f4 g_min = { -32768.0f, -32768.0f, -32768.0f, -32768.0f }; - __m128i pcm8 = _mm_packs_epi32(_mm_cvtps_epi32(_mm_max_ps(_mm_min_ps(a, g_max), g_min)), - _mm_cvtps_epi32(_mm_max_ps(_mm_min_ps(b, g_max), g_min))); - dstr[(15 - i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 1); - dstr[(17 + i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 5); - dstl[(15 - i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 0); - dstl[(17 + i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 4); - dstr[(47 - i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 3); - dstr[(49 + i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 7); - dstl[(47 - i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 2); - dstl[(49 + i)*nch] = (drmp3_int16)_mm_extract_epi16(pcm8, 6); -#else - int16x4_t pcma, pcmb; - a = DRMP3_VADD(a, DRMP3_VSET(0.5f)); - b = DRMP3_VADD(b, DRMP3_VSET(0.5f)); - pcma = vqmovn_s32(vqaddq_s32(vcvtq_s32_f32(a), vreinterpretq_s32_u32(vcltq_f32(a, DRMP3_VSET(0))))); - pcmb = vqmovn_s32(vqaddq_s32(vcvtq_s32_f32(b), vreinterpretq_s32_u32(vcltq_f32(b, DRMP3_VSET(0))))); - vst1_lane_s16(dstr + (15 - i)*nch, pcma, 1); - vst1_lane_s16(dstr + (17 + i)*nch, pcmb, 1); - vst1_lane_s16(dstl + (15 - i)*nch, pcma, 0); - vst1_lane_s16(dstl + (17 + i)*nch, pcmb, 0); - vst1_lane_s16(dstr + (47 - i)*nch, pcma, 3); - vst1_lane_s16(dstr + (49 + i)*nch, pcmb, 3); - vst1_lane_s16(dstl + (47 - i)*nch, pcma, 2); - vst1_lane_s16(dstl + (49 + i)*nch, pcmb, 2); -#endif -#else - #if DRMP3_HAVE_SSE - static const drmp3_f4 g_scale = { 1.0f/32768.0f, 1.0f/32768.0f, 1.0f/32768.0f, 1.0f/32768.0f }; - #else - const drmp3_f4 g_scale = vdupq_n_f32(1.0f/32768.0f); - #endif - a = DRMP3_VMUL(a, g_scale); - b = DRMP3_VMUL(b, g_scale); -#if DRMP3_HAVE_SSE - _mm_store_ss(dstr + (15 - i)*nch, _mm_shuffle_ps(a, a, _MM_SHUFFLE(1, 1, 1, 1))); - _mm_store_ss(dstr + (17 + i)*nch, _mm_shuffle_ps(b, b, _MM_SHUFFLE(1, 1, 1, 1))); - _mm_store_ss(dstl + (15 - i)*nch, _mm_shuffle_ps(a, a, _MM_SHUFFLE(0, 0, 0, 0))); - _mm_store_ss(dstl + (17 + i)*nch, _mm_shuffle_ps(b, b, _MM_SHUFFLE(0, 0, 0, 0))); - _mm_store_ss(dstr + (47 - i)*nch, _mm_shuffle_ps(a, a, _MM_SHUFFLE(3, 3, 3, 3))); - _mm_store_ss(dstr + (49 + i)*nch, _mm_shuffle_ps(b, b, _MM_SHUFFLE(3, 3, 3, 3))); - _mm_store_ss(dstl + (47 - i)*nch, _mm_shuffle_ps(a, a, _MM_SHUFFLE(2, 2, 2, 2))); - _mm_store_ss(dstl + (49 + i)*nch, _mm_shuffle_ps(b, b, _MM_SHUFFLE(2, 2, 2, 2))); -#else - vst1q_lane_f32(dstr + (15 - i)*nch, a, 1); - vst1q_lane_f32(dstr + (17 + i)*nch, b, 1); - vst1q_lane_f32(dstl + (15 - i)*nch, a, 0); - vst1q_lane_f32(dstl + (17 + i)*nch, b, 0); - vst1q_lane_f32(dstr + (47 - i)*nch, a, 3); - vst1q_lane_f32(dstr + (49 + i)*nch, b, 3); - vst1q_lane_f32(dstl + (47 - i)*nch, a, 2); - vst1q_lane_f32(dstl + (49 + i)*nch, b, 2); -#endif -#endif - } - } else -#endif -#ifdef DR_MP3_ONLY_SIMD - {} -#else - for (i = 14; i >= 0; i--) - { -#define DRMP3_LOAD(k) float w0 = *w++; float w1 = *w++; float *vz = &zlin[4*i - k*64]; float *vy = &zlin[4*i - (15 - k)*64]; -#define DRMP3_S0(k) { int j; DRMP3_LOAD(k); for (j = 0; j < 4; j++) b[j] = vz[j]*w1 + vy[j]*w0, a[j] = vz[j]*w0 - vy[j]*w1; } -#define DRMP3_S1(k) { int j; DRMP3_LOAD(k); for (j = 0; j < 4; j++) b[j] += vz[j]*w1 + vy[j]*w0, a[j] += vz[j]*w0 - vy[j]*w1; } -#define DRMP3_S2(k) { int j; DRMP3_LOAD(k); for (j = 0; j < 4; j++) b[j] += vz[j]*w1 + vy[j]*w0, a[j] += vy[j]*w1 - vz[j]*w0; } - float a[4], b[4]; - zlin[4*i] = xl[18*(31 - i)]; - zlin[4*i + 1] = xr[18*(31 - i)]; - zlin[4*i + 2] = xl[1 + 18*(31 - i)]; - zlin[4*i + 3] = xr[1 + 18*(31 - i)]; - zlin[4*(i + 16)] = xl[1 + 18*(1 + i)]; - zlin[4*(i + 16) + 1] = xr[1 + 18*(1 + i)]; - zlin[4*(i - 16) + 2] = xl[18*(1 + i)]; - zlin[4*(i - 16) + 3] = xr[18*(1 + i)]; - DRMP3_S0(0) DRMP3_S2(1) DRMP3_S1(2) DRMP3_S2(3) DRMP3_S1(4) DRMP3_S2(5) DRMP3_S1(6) DRMP3_S2(7) - dstr[(15 - i)*nch] = drmp3d_scale_pcm(a[1]); - dstr[(17 + i)*nch] = drmp3d_scale_pcm(b[1]); - dstl[(15 - i)*nch] = drmp3d_scale_pcm(a[0]); - dstl[(17 + i)*nch] = drmp3d_scale_pcm(b[0]); - dstr[(47 - i)*nch] = drmp3d_scale_pcm(a[3]); - dstr[(49 + i)*nch] = drmp3d_scale_pcm(b[3]); - dstl[(47 - i)*nch] = drmp3d_scale_pcm(a[2]); - dstl[(49 + i)*nch] = drmp3d_scale_pcm(b[2]); - } -#endif -} -static void drmp3d_synth_granule(float *qmf_state, float *grbuf, int nbands, int nch, drmp3d_sample_t *pcm, float *lins) -{ - int i; - for (i = 0; i < nch; i++) - { - drmp3d_DCT_II(grbuf + 576*i, nbands); - } - DRMP3_COPY_MEMORY(lins, qmf_state, sizeof(float)*15*64); - for (i = 0; i < nbands; i += 2) - { - drmp3d_synth(grbuf + i, pcm + 32*nch*i, nch, lins + i*64); - } -#ifndef DR_MP3_NONSTANDARD_BUT_LOGICAL - if (nch == 1) - { - for (i = 0; i < 15*64; i += 2) - { - qmf_state[i] = lins[nbands*64 + i]; - } - } else -#endif - { - DRMP3_COPY_MEMORY(qmf_state, lins + nbands*64, sizeof(float)*15*64); - } -} -static int drmp3d_match_frame(const drmp3_uint8 *hdr, int mp3_bytes, int frame_bytes) -{ - int i, nmatch; - for (i = 0, nmatch = 0; nmatch < DRMP3_MAX_FRAME_SYNC_MATCHES; nmatch++) - { - i += drmp3_hdr_frame_bytes(hdr + i, frame_bytes) + drmp3_hdr_padding(hdr + i); - if (i + DRMP3_HDR_SIZE > mp3_bytes) - return nmatch > 0; - if (!drmp3_hdr_compare(hdr, hdr + i)) - return 0; - } - return 1; -} -static int drmp3d_find_frame(const drmp3_uint8 *mp3, int mp3_bytes, int *free_format_bytes, int *ptr_frame_bytes) -{ - int i, k; - for (i = 0; i < mp3_bytes - DRMP3_HDR_SIZE; i++, mp3++) - { - if (drmp3_hdr_valid(mp3)) - { - int frame_bytes = drmp3_hdr_frame_bytes(mp3, *free_format_bytes); - int frame_and_padding = frame_bytes + drmp3_hdr_padding(mp3); - for (k = DRMP3_HDR_SIZE; !frame_bytes && k < DRMP3_MAX_FREE_FORMAT_FRAME_SIZE && i + 2*k < mp3_bytes - DRMP3_HDR_SIZE; k++) - { - if (drmp3_hdr_compare(mp3, mp3 + k)) - { - int fb = k - drmp3_hdr_padding(mp3); - int nextfb = fb + drmp3_hdr_padding(mp3 + k); - if (i + k + nextfb + DRMP3_HDR_SIZE > mp3_bytes || !drmp3_hdr_compare(mp3, mp3 + k + nextfb)) - continue; - frame_and_padding = k; - frame_bytes = fb; - *free_format_bytes = fb; - } - } - if ((frame_bytes && i + frame_and_padding <= mp3_bytes && - drmp3d_match_frame(mp3, mp3_bytes - i, frame_bytes)) || - (!i && frame_and_padding == mp3_bytes)) - { - *ptr_frame_bytes = frame_and_padding; - return i; - } - *free_format_bytes = 0; - } - } - *ptr_frame_bytes = 0; - return mp3_bytes; -} -DRMP3_API void drmp3dec_init(drmp3dec *dec) -{ - dec->header[0] = 0; -} -DRMP3_API int drmp3dec_decode_frame(drmp3dec *dec, const drmp3_uint8 *mp3, int mp3_bytes, void *pcm, drmp3dec_frame_info *info) -{ - int i = 0, igr, frame_size = 0, success = 1; - const drmp3_uint8 *hdr; - drmp3_bs bs_frame[1]; - drmp3dec_scratch scratch; - if (mp3_bytes > 4 && dec->header[0] == 0xff && drmp3_hdr_compare(dec->header, mp3)) - { - frame_size = drmp3_hdr_frame_bytes(mp3, dec->free_format_bytes) + drmp3_hdr_padding(mp3); - if (frame_size != mp3_bytes && (frame_size + DRMP3_HDR_SIZE > mp3_bytes || !drmp3_hdr_compare(mp3, mp3 + frame_size))) - { - frame_size = 0; - } - } - if (!frame_size) - { - DRMP3_ZERO_MEMORY(dec, sizeof(drmp3dec)); - i = drmp3d_find_frame(mp3, mp3_bytes, &dec->free_format_bytes, &frame_size); - if (!frame_size || i + frame_size > mp3_bytes) - { - info->frame_bytes = i; - return 0; - } - } - hdr = mp3 + i; - DRMP3_COPY_MEMORY(dec->header, hdr, DRMP3_HDR_SIZE); - info->frame_bytes = i + frame_size; - info->channels = DRMP3_HDR_IS_MONO(hdr) ? 1 : 2; - info->hz = drmp3_hdr_sample_rate_hz(hdr); - info->layer = 4 - DRMP3_HDR_GET_LAYER(hdr); - info->bitrate_kbps = drmp3_hdr_bitrate_kbps(hdr); - drmp3_bs_init(bs_frame, hdr + DRMP3_HDR_SIZE, frame_size - DRMP3_HDR_SIZE); - if (DRMP3_HDR_IS_CRC(hdr)) - { - drmp3_bs_get_bits(bs_frame, 16); - } - if (info->layer == 3) - { - int main_data_begin = drmp3_L3_read_side_info(bs_frame, scratch.gr_info, hdr); - if (main_data_begin < 0 || bs_frame->pos > bs_frame->limit) - { - drmp3dec_init(dec); - return 0; - } - success = drmp3_L3_restore_reservoir(dec, bs_frame, &scratch, main_data_begin); - if (success && pcm != NULL) - { - for (igr = 0; igr < (DRMP3_HDR_TEST_MPEG1(hdr) ? 2 : 1); igr++, pcm = DRMP3_OFFSET_PTR(pcm, sizeof(drmp3d_sample_t)*576*info->channels)) - { - DRMP3_ZERO_MEMORY(scratch.grbuf[0], 576*2*sizeof(float)); - drmp3_L3_decode(dec, &scratch, scratch.gr_info + igr*info->channels, info->channels); - drmp3d_synth_granule(dec->qmf_state, scratch.grbuf[0], 18, info->channels, (drmp3d_sample_t*)pcm, scratch.syn[0]); - } - } - drmp3_L3_save_reservoir(dec, &scratch); - } else - { -#ifdef DR_MP3_ONLY_MP3 - return 0; -#else - drmp3_L12_scale_info sci[1]; - if (pcm == NULL) { - return drmp3_hdr_frame_samples(hdr); - } - drmp3_L12_read_scale_info(hdr, bs_frame, sci); - DRMP3_ZERO_MEMORY(scratch.grbuf[0], 576*2*sizeof(float)); - for (i = 0, igr = 0; igr < 3; igr++) - { - if (12 == (i += drmp3_L12_dequantize_granule(scratch.grbuf[0] + i, bs_frame, sci, info->layer | 1))) - { - i = 0; - drmp3_L12_apply_scf_384(sci, sci->scf + igr, scratch.grbuf[0]); - drmp3d_synth_granule(dec->qmf_state, scratch.grbuf[0], 12, info->channels, (drmp3d_sample_t*)pcm, scratch.syn[0]); - DRMP3_ZERO_MEMORY(scratch.grbuf[0], 576*2*sizeof(float)); - pcm = DRMP3_OFFSET_PTR(pcm, sizeof(drmp3d_sample_t)*384*info->channels); - } - if (bs_frame->pos > bs_frame->limit) - { - drmp3dec_init(dec); - return 0; - } - } -#endif - } - return success*drmp3_hdr_frame_samples(dec->header); -} -DRMP3_API void drmp3dec_f32_to_s16(const float *in, drmp3_int16 *out, size_t num_samples) -{ - size_t i = 0; -#if DRMP3_HAVE_SIMD - size_t aligned_count = num_samples & ~7; - for(; i < aligned_count; i+=8) - { - drmp3_f4 scale = DRMP3_VSET(32768.0f); - drmp3_f4 a = DRMP3_VMUL(DRMP3_VLD(&in[i ]), scale); - drmp3_f4 b = DRMP3_VMUL(DRMP3_VLD(&in[i+4]), scale); -#if DRMP3_HAVE_SSE - drmp3_f4 s16max = DRMP3_VSET( 32767.0f); - drmp3_f4 s16min = DRMP3_VSET(-32768.0f); - __m128i pcm8 = _mm_packs_epi32(_mm_cvtps_epi32(_mm_max_ps(_mm_min_ps(a, s16max), s16min)), - _mm_cvtps_epi32(_mm_max_ps(_mm_min_ps(b, s16max), s16min))); - out[i ] = (drmp3_int16)_mm_extract_epi16(pcm8, 0); - out[i+1] = (drmp3_int16)_mm_extract_epi16(pcm8, 1); - out[i+2] = (drmp3_int16)_mm_extract_epi16(pcm8, 2); - out[i+3] = (drmp3_int16)_mm_extract_epi16(pcm8, 3); - out[i+4] = (drmp3_int16)_mm_extract_epi16(pcm8, 4); - out[i+5] = (drmp3_int16)_mm_extract_epi16(pcm8, 5); - out[i+6] = (drmp3_int16)_mm_extract_epi16(pcm8, 6); - out[i+7] = (drmp3_int16)_mm_extract_epi16(pcm8, 7); -#else - int16x4_t pcma, pcmb; - a = DRMP3_VADD(a, DRMP3_VSET(0.5f)); - b = DRMP3_VADD(b, DRMP3_VSET(0.5f)); - pcma = vqmovn_s32(vqaddq_s32(vcvtq_s32_f32(a), vreinterpretq_s32_u32(vcltq_f32(a, DRMP3_VSET(0))))); - pcmb = vqmovn_s32(vqaddq_s32(vcvtq_s32_f32(b), vreinterpretq_s32_u32(vcltq_f32(b, DRMP3_VSET(0))))); - vst1_lane_s16(out+i , pcma, 0); - vst1_lane_s16(out+i+1, pcma, 1); - vst1_lane_s16(out+i+2, pcma, 2); - vst1_lane_s16(out+i+3, pcma, 3); - vst1_lane_s16(out+i+4, pcmb, 0); - vst1_lane_s16(out+i+5, pcmb, 1); - vst1_lane_s16(out+i+6, pcmb, 2); - vst1_lane_s16(out+i+7, pcmb, 3); -#endif - } -#endif - for(; i < num_samples; i++) - { - float sample = in[i] * 32768.0f; - if (sample >= 32766.5) - out[i] = (drmp3_int16) 32767; - else if (sample <= -32767.5) - out[i] = (drmp3_int16)-32768; - else - { - short s = (drmp3_int16)(sample + .5f); - s -= (s < 0); - out[i] = s; - } - } -} -#if defined(SIZE_MAX) - #define DRMP3_SIZE_MAX SIZE_MAX -#else - #if defined(_WIN64) || defined(_LP64) || defined(__LP64__) - #define DRMP3_SIZE_MAX ((drmp3_uint64)0xFFFFFFFFFFFFFFFF) - #else - #define DRMP3_SIZE_MAX 0xFFFFFFFF - #endif -#endif -#ifndef DRMP3_SEEK_LEADING_MP3_FRAMES -#define DRMP3_SEEK_LEADING_MP3_FRAMES 2 -#endif -#define DRMP3_MIN_DATA_CHUNK_SIZE 16384 -#ifndef DRMP3_DATA_CHUNK_SIZE -#define DRMP3_DATA_CHUNK_SIZE (DRMP3_MIN_DATA_CHUNK_SIZE*4) -#endif -#define DRMP3_COUNTOF(x) (sizeof(x) / sizeof(x[0])) -#define DRMP3_CLAMP(x, lo, hi) (DRMP3_MAX(lo, DRMP3_MIN(x, hi))) -#ifndef DRMP3_PI_D -#define DRMP3_PI_D 3.14159265358979323846264 -#endif -#define DRMP3_DEFAULT_RESAMPLER_LPF_ORDER 2 -static DRMP3_INLINE float drmp3_mix_f32(float x, float y, float a) -{ - return x*(1-a) + y*a; -} -static DRMP3_INLINE float drmp3_mix_f32_fast(float x, float y, float a) -{ - float r0 = (y - x); - float r1 = r0*a; - return x + r1; -} -static DRMP3_INLINE drmp3_uint32 drmp3_gcf_u32(drmp3_uint32 a, drmp3_uint32 b) -{ - for (;;) { - if (b == 0) { - break; - } else { - drmp3_uint32 t = a; - a = b; - b = t % a; - } - } - return a; -} -static void* drmp3__malloc_default(size_t sz, void* pUserData) -{ - (void)pUserData; - return DRMP3_MALLOC(sz); -} -static void* drmp3__realloc_default(void* p, size_t sz, void* pUserData) -{ - (void)pUserData; - return DRMP3_REALLOC(p, sz); -} -static void drmp3__free_default(void* p, void* pUserData) -{ - (void)pUserData; - DRMP3_FREE(p); -} -static void* drmp3__malloc_from_callbacks(size_t sz, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks == NULL) { - return NULL; - } - if (pAllocationCallbacks->onMalloc != NULL) { - return pAllocationCallbacks->onMalloc(sz, pAllocationCallbacks->pUserData); - } - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(NULL, sz, pAllocationCallbacks->pUserData); - } - return NULL; -} -static void* drmp3__realloc_from_callbacks(void* p, size_t szNew, size_t szOld, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks == NULL) { - return NULL; - } - if (pAllocationCallbacks->onRealloc != NULL) { - return pAllocationCallbacks->onRealloc(p, szNew, pAllocationCallbacks->pUserData); - } - if (pAllocationCallbacks->onMalloc != NULL && pAllocationCallbacks->onFree != NULL) { - void* p2; - p2 = pAllocationCallbacks->onMalloc(szNew, pAllocationCallbacks->pUserData); - if (p2 == NULL) { - return NULL; - } - if (p != NULL) { - DRMP3_COPY_MEMORY(p2, p, szOld); - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } - return p2; - } - return NULL; -} -static void drmp3__free_from_callbacks(void* p, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (p == NULL || pAllocationCallbacks == NULL) { - return; - } - if (pAllocationCallbacks->onFree != NULL) { - pAllocationCallbacks->onFree(p, pAllocationCallbacks->pUserData); - } -} -static drmp3_allocation_callbacks drmp3_copy_allocation_callbacks_or_defaults(const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - return *pAllocationCallbacks; - } else { - drmp3_allocation_callbacks allocationCallbacks; - allocationCallbacks.pUserData = NULL; - allocationCallbacks.onMalloc = drmp3__malloc_default; - allocationCallbacks.onRealloc = drmp3__realloc_default; - allocationCallbacks.onFree = drmp3__free_default; - return allocationCallbacks; - } -} -static size_t drmp3__on_read(drmp3* pMP3, void* pBufferOut, size_t bytesToRead) -{ - size_t bytesRead = pMP3->onRead(pMP3->pUserData, pBufferOut, bytesToRead); - pMP3->streamCursor += bytesRead; - return bytesRead; -} -static drmp3_bool32 drmp3__on_seek(drmp3* pMP3, int offset, drmp3_seek_origin origin) -{ - DRMP3_ASSERT(offset >= 0); - if (!pMP3->onSeek(pMP3->pUserData, offset, origin)) { - return DRMP3_FALSE; - } - if (origin == drmp3_seek_origin_start) { - pMP3->streamCursor = (drmp3_uint64)offset; - } else { - pMP3->streamCursor += offset; - } - return DRMP3_TRUE; -} -static drmp3_bool32 drmp3__on_seek_64(drmp3* pMP3, drmp3_uint64 offset, drmp3_seek_origin origin) -{ - if (offset <= 0x7FFFFFFF) { - return drmp3__on_seek(pMP3, (int)offset, origin); - } - if (!drmp3__on_seek(pMP3, 0x7FFFFFFF, drmp3_seek_origin_start)) { - return DRMP3_FALSE; - } - offset -= 0x7FFFFFFF; - while (offset > 0) { - if (offset <= 0x7FFFFFFF) { - if (!drmp3__on_seek(pMP3, (int)offset, drmp3_seek_origin_current)) { - return DRMP3_FALSE; - } - offset = 0; - } else { - if (!drmp3__on_seek(pMP3, 0x7FFFFFFF, drmp3_seek_origin_current)) { - return DRMP3_FALSE; - } - offset -= 0x7FFFFFFF; - } - } - return DRMP3_TRUE; -} -static drmp3_uint32 drmp3_decode_next_frame_ex__callbacks(drmp3* pMP3, drmp3d_sample_t* pPCMFrames) -{ - drmp3_uint32 pcmFramesRead = 0; - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(pMP3->onRead != NULL); - if (pMP3->atEnd) { - return 0; - } - for (;;) { - drmp3dec_frame_info info; - if (pMP3->dataSize < DRMP3_MIN_DATA_CHUNK_SIZE) { - size_t bytesRead; - if (pMP3->pData != NULL) { - DRMP3_MOVE_MEMORY(pMP3->pData, pMP3->pData + pMP3->dataConsumed, pMP3->dataSize); - } - pMP3->dataConsumed = 0; - if (pMP3->dataCapacity < DRMP3_DATA_CHUNK_SIZE) { - drmp3_uint8* pNewData; - size_t newDataCap; - newDataCap = DRMP3_DATA_CHUNK_SIZE; - pNewData = (drmp3_uint8*)drmp3__realloc_from_callbacks(pMP3->pData, newDataCap, pMP3->dataCapacity, &pMP3->allocationCallbacks); - if (pNewData == NULL) { - return 0; - } - pMP3->pData = pNewData; - pMP3->dataCapacity = newDataCap; - } - bytesRead = drmp3__on_read(pMP3, pMP3->pData + pMP3->dataSize, (pMP3->dataCapacity - pMP3->dataSize)); - if (bytesRead == 0) { - if (pMP3->dataSize == 0) { - pMP3->atEnd = DRMP3_TRUE; - return 0; - } - } - pMP3->dataSize += bytesRead; - } - if (pMP3->dataSize > INT_MAX) { - pMP3->atEnd = DRMP3_TRUE; - return 0; - } - DRMP3_ASSERT(pMP3->pData != NULL); - DRMP3_ASSERT(pMP3->dataCapacity > 0); - pcmFramesRead = drmp3dec_decode_frame(&pMP3->decoder, pMP3->pData + pMP3->dataConsumed, (int)pMP3->dataSize, pPCMFrames, &info); - if (info.frame_bytes > 0) { - pMP3->dataConsumed += (size_t)info.frame_bytes; - pMP3->dataSize -= (size_t)info.frame_bytes; - } - if (pcmFramesRead > 0) { - pcmFramesRead = drmp3_hdr_frame_samples(pMP3->decoder.header); - pMP3->pcmFramesConsumedInMP3Frame = 0; - pMP3->pcmFramesRemainingInMP3Frame = pcmFramesRead; - pMP3->mp3FrameChannels = info.channels; - pMP3->mp3FrameSampleRate = info.hz; - break; - } else if (info.frame_bytes == 0) { - size_t bytesRead; - DRMP3_MOVE_MEMORY(pMP3->pData, pMP3->pData + pMP3->dataConsumed, pMP3->dataSize); - pMP3->dataConsumed = 0; - if (pMP3->dataCapacity == pMP3->dataSize) { - drmp3_uint8* pNewData; - size_t newDataCap; - newDataCap = pMP3->dataCapacity + DRMP3_DATA_CHUNK_SIZE; - pNewData = (drmp3_uint8*)drmp3__realloc_from_callbacks(pMP3->pData, newDataCap, pMP3->dataCapacity, &pMP3->allocationCallbacks); - if (pNewData == NULL) { - return 0; - } - pMP3->pData = pNewData; - pMP3->dataCapacity = newDataCap; - } - bytesRead = drmp3__on_read(pMP3, pMP3->pData + pMP3->dataSize, (pMP3->dataCapacity - pMP3->dataSize)); - if (bytesRead == 0) { - pMP3->atEnd = DRMP3_TRUE; - return 0; - } - pMP3->dataSize += bytesRead; - } - }; - return pcmFramesRead; -} -static drmp3_uint32 drmp3_decode_next_frame_ex__memory(drmp3* pMP3, drmp3d_sample_t* pPCMFrames) -{ - drmp3_uint32 pcmFramesRead = 0; - drmp3dec_frame_info info; - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(pMP3->memory.pData != NULL); - if (pMP3->atEnd) { - return 0; - } - for (;;) { - pcmFramesRead = drmp3dec_decode_frame(&pMP3->decoder, pMP3->memory.pData + pMP3->memory.currentReadPos, (int)(pMP3->memory.dataSize - pMP3->memory.currentReadPos), pPCMFrames, &info); - if (pcmFramesRead > 0) { - pcmFramesRead = drmp3_hdr_frame_samples(pMP3->decoder.header); - pMP3->pcmFramesConsumedInMP3Frame = 0; - pMP3->pcmFramesRemainingInMP3Frame = pcmFramesRead; - pMP3->mp3FrameChannels = info.channels; - pMP3->mp3FrameSampleRate = info.hz; - break; - } else if (info.frame_bytes > 0) { - pMP3->memory.currentReadPos += (size_t)info.frame_bytes; - } else { - break; - } - } - pMP3->memory.currentReadPos += (size_t)info.frame_bytes; - return pcmFramesRead; -} -static drmp3_uint32 drmp3_decode_next_frame_ex(drmp3* pMP3, drmp3d_sample_t* pPCMFrames) -{ - if (pMP3->memory.pData != NULL && pMP3->memory.dataSize > 0) { - return drmp3_decode_next_frame_ex__memory(pMP3, pPCMFrames); - } else { - return drmp3_decode_next_frame_ex__callbacks(pMP3, pPCMFrames); - } -} -static drmp3_uint32 drmp3_decode_next_frame(drmp3* pMP3) -{ - DRMP3_ASSERT(pMP3 != NULL); - return drmp3_decode_next_frame_ex(pMP3, (drmp3d_sample_t*)pMP3->pcmFrames); -} -#if 0 -static drmp3_uint32 drmp3_seek_next_frame(drmp3* pMP3) -{ - drmp3_uint32 pcmFrameCount; - DRMP3_ASSERT(pMP3 != NULL); - pcmFrameCount = drmp3_decode_next_frame_ex(pMP3, NULL); - if (pcmFrameCount == 0) { - return 0; - } - pMP3->currentPCMFrame += pcmFrameCount; - pMP3->pcmFramesConsumedInMP3Frame = pcmFrameCount; - pMP3->pcmFramesRemainingInMP3Frame = 0; - return pcmFrameCount; -} -#endif -static drmp3_bool32 drmp3_init_internal(drmp3* pMP3, drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(onRead != NULL); - drmp3dec_init(&pMP3->decoder); - pMP3->onRead = onRead; - pMP3->onSeek = onSeek; - pMP3->pUserData = pUserData; - pMP3->allocationCallbacks = drmp3_copy_allocation_callbacks_or_defaults(pAllocationCallbacks); - if (pMP3->allocationCallbacks.onFree == NULL || (pMP3->allocationCallbacks.onMalloc == NULL && pMP3->allocationCallbacks.onRealloc == NULL)) { - return DRMP3_FALSE; - } - if (drmp3_decode_next_frame(pMP3) == 0) { - drmp3__free_from_callbacks(pMP3->pData, &pMP3->allocationCallbacks); - return DRMP3_FALSE; - } - pMP3->channels = pMP3->mp3FrameChannels; - pMP3->sampleRate = pMP3->mp3FrameSampleRate; - return DRMP3_TRUE; -} -DRMP3_API drmp3_bool32 drmp3_init(drmp3* pMP3, drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pMP3 == NULL || onRead == NULL) { - return DRMP3_FALSE; - } - DRMP3_ZERO_OBJECT(pMP3); - return drmp3_init_internal(pMP3, onRead, onSeek, pUserData, pAllocationCallbacks); -} -static size_t drmp3__on_read_memory(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - drmp3* pMP3 = (drmp3*)pUserData; - size_t bytesRemaining; - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(pMP3->memory.dataSize >= pMP3->memory.currentReadPos); - bytesRemaining = pMP3->memory.dataSize - pMP3->memory.currentReadPos; - if (bytesToRead > bytesRemaining) { - bytesToRead = bytesRemaining; - } - if (bytesToRead > 0) { - DRMP3_COPY_MEMORY(pBufferOut, pMP3->memory.pData + pMP3->memory.currentReadPos, bytesToRead); - pMP3->memory.currentReadPos += bytesToRead; - } - return bytesToRead; -} -static drmp3_bool32 drmp3__on_seek_memory(void* pUserData, int byteOffset, drmp3_seek_origin origin) -{ - drmp3* pMP3 = (drmp3*)pUserData; - DRMP3_ASSERT(pMP3 != NULL); - if (origin == drmp3_seek_origin_current) { - if (byteOffset > 0) { - if (pMP3->memory.currentReadPos + byteOffset > pMP3->memory.dataSize) { - byteOffset = (int)(pMP3->memory.dataSize - pMP3->memory.currentReadPos); - } - } else { - if (pMP3->memory.currentReadPos < (size_t)-byteOffset) { - byteOffset = -(int)pMP3->memory.currentReadPos; - } - } - pMP3->memory.currentReadPos += byteOffset; - } else { - if ((drmp3_uint32)byteOffset <= pMP3->memory.dataSize) { - pMP3->memory.currentReadPos = byteOffset; - } else { - pMP3->memory.currentReadPos = pMP3->memory.dataSize; - } - } - return DRMP3_TRUE; -} -DRMP3_API drmp3_bool32 drmp3_init_memory(drmp3* pMP3, const void* pData, size_t dataSize, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pMP3 == NULL) { - return DRMP3_FALSE; - } - DRMP3_ZERO_OBJECT(pMP3); - if (pData == NULL || dataSize == 0) { - return DRMP3_FALSE; - } - pMP3->memory.pData = (const drmp3_uint8*)pData; - pMP3->memory.dataSize = dataSize; - pMP3->memory.currentReadPos = 0; - return drmp3_init_internal(pMP3, drmp3__on_read_memory, drmp3__on_seek_memory, pMP3, pAllocationCallbacks); -} -#ifndef DR_MP3_NO_STDIO -#include -#include -#include -static drmp3_result drmp3_result_from_errno(int e) -{ - switch (e) - { - case 0: return DRMP3_SUCCESS; - #ifdef EPERM - case EPERM: return DRMP3_INVALID_OPERATION; - #endif - #ifdef ENOENT - case ENOENT: return DRMP3_DOES_NOT_EXIST; - #endif - #ifdef ESRCH - case ESRCH: return DRMP3_DOES_NOT_EXIST; - #endif - #ifdef EINTR - case EINTR: return DRMP3_INTERRUPT; - #endif - #ifdef EIO - case EIO: return DRMP3_IO_ERROR; - #endif - #ifdef ENXIO - case ENXIO: return DRMP3_DOES_NOT_EXIST; - #endif - #ifdef E2BIG - case E2BIG: return DRMP3_INVALID_ARGS; - #endif - #ifdef ENOEXEC - case ENOEXEC: return DRMP3_INVALID_FILE; - #endif - #ifdef EBADF - case EBADF: return DRMP3_INVALID_FILE; - #endif - #ifdef ECHILD - case ECHILD: return DRMP3_ERROR; - #endif - #ifdef EAGAIN - case EAGAIN: return DRMP3_UNAVAILABLE; - #endif - #ifdef ENOMEM - case ENOMEM: return DRMP3_OUT_OF_MEMORY; - #endif - #ifdef EACCES - case EACCES: return DRMP3_ACCESS_DENIED; - #endif - #ifdef EFAULT - case EFAULT: return DRMP3_BAD_ADDRESS; - #endif - #ifdef ENOTBLK - case ENOTBLK: return DRMP3_ERROR; - #endif - #ifdef EBUSY - case EBUSY: return DRMP3_BUSY; - #endif - #ifdef EEXIST - case EEXIST: return DRMP3_ALREADY_EXISTS; - #endif - #ifdef EXDEV - case EXDEV: return DRMP3_ERROR; - #endif - #ifdef ENODEV - case ENODEV: return DRMP3_DOES_NOT_EXIST; - #endif - #ifdef ENOTDIR - case ENOTDIR: return DRMP3_NOT_DIRECTORY; - #endif - #ifdef EISDIR - case EISDIR: return DRMP3_IS_DIRECTORY; - #endif - #ifdef EINVAL - case EINVAL: return DRMP3_INVALID_ARGS; - #endif - #ifdef ENFILE - case ENFILE: return DRMP3_TOO_MANY_OPEN_FILES; - #endif - #ifdef EMFILE - case EMFILE: return DRMP3_TOO_MANY_OPEN_FILES; - #endif - #ifdef ENOTTY - case ENOTTY: return DRMP3_INVALID_OPERATION; - #endif - #ifdef ETXTBSY - case ETXTBSY: return DRMP3_BUSY; - #endif - #ifdef EFBIG - case EFBIG: return DRMP3_TOO_BIG; - #endif - #ifdef ENOSPC - case ENOSPC: return DRMP3_NO_SPACE; - #endif - #ifdef ESPIPE - case ESPIPE: return DRMP3_BAD_SEEK; - #endif - #ifdef EROFS - case EROFS: return DRMP3_ACCESS_DENIED; - #endif - #ifdef EMLINK - case EMLINK: return DRMP3_TOO_MANY_LINKS; - #endif - #ifdef EPIPE - case EPIPE: return DRMP3_BAD_PIPE; - #endif - #ifdef EDOM - case EDOM: return DRMP3_OUT_OF_RANGE; - #endif - #ifdef ERANGE - case ERANGE: return DRMP3_OUT_OF_RANGE; - #endif - #ifdef EDEADLK - case EDEADLK: return DRMP3_DEADLOCK; - #endif - #ifdef ENAMETOOLONG - case ENAMETOOLONG: return DRMP3_PATH_TOO_LONG; - #endif - #ifdef ENOLCK - case ENOLCK: return DRMP3_ERROR; - #endif - #ifdef ENOSYS - case ENOSYS: return DRMP3_NOT_IMPLEMENTED; - #endif - #ifdef ENOTEMPTY - case ENOTEMPTY: return DRMP3_DIRECTORY_NOT_EMPTY; - #endif - #ifdef ELOOP - case ELOOP: return DRMP3_TOO_MANY_LINKS; - #endif - #ifdef ENOMSG - case ENOMSG: return DRMP3_NO_MESSAGE; - #endif - #ifdef EIDRM - case EIDRM: return DRMP3_ERROR; - #endif - #ifdef ECHRNG - case ECHRNG: return DRMP3_ERROR; - #endif - #ifdef EL2NSYNC - case EL2NSYNC: return DRMP3_ERROR; - #endif - #ifdef EL3HLT - case EL3HLT: return DRMP3_ERROR; - #endif - #ifdef EL3RST - case EL3RST: return DRMP3_ERROR; - #endif - #ifdef ELNRNG - case ELNRNG: return DRMP3_OUT_OF_RANGE; - #endif - #ifdef EUNATCH - case EUNATCH: return DRMP3_ERROR; - #endif - #ifdef ENOCSI - case ENOCSI: return DRMP3_ERROR; - #endif - #ifdef EL2HLT - case EL2HLT: return DRMP3_ERROR; - #endif - #ifdef EBADE - case EBADE: return DRMP3_ERROR; - #endif - #ifdef EBADR - case EBADR: return DRMP3_ERROR; - #endif - #ifdef EXFULL - case EXFULL: return DRMP3_ERROR; - #endif - #ifdef ENOANO - case ENOANO: return DRMP3_ERROR; - #endif - #ifdef EBADRQC - case EBADRQC: return DRMP3_ERROR; - #endif - #ifdef EBADSLT - case EBADSLT: return DRMP3_ERROR; - #endif - #ifdef EBFONT - case EBFONT: return DRMP3_INVALID_FILE; - #endif - #ifdef ENOSTR - case ENOSTR: return DRMP3_ERROR; - #endif - #ifdef ENODATA - case ENODATA: return DRMP3_NO_DATA_AVAILABLE; - #endif - #ifdef ETIME - case ETIME: return DRMP3_TIMEOUT; - #endif - #ifdef ENOSR - case ENOSR: return DRMP3_NO_DATA_AVAILABLE; - #endif - #ifdef ENONET - case ENONET: return DRMP3_NO_NETWORK; - #endif - #ifdef ENOPKG - case ENOPKG: return DRMP3_ERROR; - #endif - #ifdef EREMOTE - case EREMOTE: return DRMP3_ERROR; - #endif - #ifdef ENOLINK - case ENOLINK: return DRMP3_ERROR; - #endif - #ifdef EADV - case EADV: return DRMP3_ERROR; - #endif - #ifdef ESRMNT - case ESRMNT: return DRMP3_ERROR; - #endif - #ifdef ECOMM - case ECOMM: return DRMP3_ERROR; - #endif - #ifdef EPROTO - case EPROTO: return DRMP3_ERROR; - #endif - #ifdef EMULTIHOP - case EMULTIHOP: return DRMP3_ERROR; - #endif - #ifdef EDOTDOT - case EDOTDOT: return DRMP3_ERROR; - #endif - #ifdef EBADMSG - case EBADMSG: return DRMP3_BAD_MESSAGE; - #endif - #ifdef EOVERFLOW - case EOVERFLOW: return DRMP3_TOO_BIG; - #endif - #ifdef ENOTUNIQ - case ENOTUNIQ: return DRMP3_NOT_UNIQUE; - #endif - #ifdef EBADFD - case EBADFD: return DRMP3_ERROR; - #endif - #ifdef EREMCHG - case EREMCHG: return DRMP3_ERROR; - #endif - #ifdef ELIBACC - case ELIBACC: return DRMP3_ACCESS_DENIED; - #endif - #ifdef ELIBBAD - case ELIBBAD: return DRMP3_INVALID_FILE; - #endif - #ifdef ELIBSCN - case ELIBSCN: return DRMP3_INVALID_FILE; - #endif - #ifdef ELIBMAX - case ELIBMAX: return DRMP3_ERROR; - #endif - #ifdef ELIBEXEC - case ELIBEXEC: return DRMP3_ERROR; - #endif - #ifdef EILSEQ - case EILSEQ: return DRMP3_INVALID_DATA; - #endif - #ifdef ERESTART - case ERESTART: return DRMP3_ERROR; - #endif - #ifdef ESTRPIPE - case ESTRPIPE: return DRMP3_ERROR; - #endif - #ifdef EUSERS - case EUSERS: return DRMP3_ERROR; - #endif - #ifdef ENOTSOCK - case ENOTSOCK: return DRMP3_NOT_SOCKET; - #endif - #ifdef EDESTADDRREQ - case EDESTADDRREQ: return DRMP3_NO_ADDRESS; - #endif - #ifdef EMSGSIZE - case EMSGSIZE: return DRMP3_TOO_BIG; - #endif - #ifdef EPROTOTYPE - case EPROTOTYPE: return DRMP3_BAD_PROTOCOL; - #endif - #ifdef ENOPROTOOPT - case ENOPROTOOPT: return DRMP3_PROTOCOL_UNAVAILABLE; - #endif - #ifdef EPROTONOSUPPORT - case EPROTONOSUPPORT: return DRMP3_PROTOCOL_NOT_SUPPORTED; - #endif - #ifdef ESOCKTNOSUPPORT - case ESOCKTNOSUPPORT: return DRMP3_SOCKET_NOT_SUPPORTED; - #endif - #ifdef EOPNOTSUPP - case EOPNOTSUPP: return DRMP3_INVALID_OPERATION; - #endif - #ifdef EPFNOSUPPORT - case EPFNOSUPPORT: return DRMP3_PROTOCOL_FAMILY_NOT_SUPPORTED; - #endif - #ifdef EAFNOSUPPORT - case EAFNOSUPPORT: return DRMP3_ADDRESS_FAMILY_NOT_SUPPORTED; - #endif - #ifdef EADDRINUSE - case EADDRINUSE: return DRMP3_ALREADY_IN_USE; - #endif - #ifdef EADDRNOTAVAIL - case EADDRNOTAVAIL: return DRMP3_ERROR; - #endif - #ifdef ENETDOWN - case ENETDOWN: return DRMP3_NO_NETWORK; - #endif - #ifdef ENETUNREACH - case ENETUNREACH: return DRMP3_NO_NETWORK; - #endif - #ifdef ENETRESET - case ENETRESET: return DRMP3_NO_NETWORK; - #endif - #ifdef ECONNABORTED - case ECONNABORTED: return DRMP3_NO_NETWORK; - #endif - #ifdef ECONNRESET - case ECONNRESET: return DRMP3_CONNECTION_RESET; - #endif - #ifdef ENOBUFS - case ENOBUFS: return DRMP3_NO_SPACE; - #endif - #ifdef EISCONN - case EISCONN: return DRMP3_ALREADY_CONNECTED; - #endif - #ifdef ENOTCONN - case ENOTCONN: return DRMP3_NOT_CONNECTED; - #endif - #ifdef ESHUTDOWN - case ESHUTDOWN: return DRMP3_ERROR; - #endif - #ifdef ETOOMANYREFS - case ETOOMANYREFS: return DRMP3_ERROR; - #endif - #ifdef ETIMEDOUT - case ETIMEDOUT: return DRMP3_TIMEOUT; - #endif - #ifdef ECONNREFUSED - case ECONNREFUSED: return DRMP3_CONNECTION_REFUSED; - #endif - #ifdef EHOSTDOWN - case EHOSTDOWN: return DRMP3_NO_HOST; - #endif - #ifdef EHOSTUNREACH - case EHOSTUNREACH: return DRMP3_NO_HOST; - #endif - #ifdef EALREADY - case EALREADY: return DRMP3_IN_PROGRESS; - #endif - #ifdef EINPROGRESS - case EINPROGRESS: return DRMP3_IN_PROGRESS; - #endif - #ifdef ESTALE - case ESTALE: return DRMP3_INVALID_FILE; - #endif - #ifdef EUCLEAN - case EUCLEAN: return DRMP3_ERROR; - #endif - #ifdef ENOTNAM - case ENOTNAM: return DRMP3_ERROR; - #endif - #ifdef ENAVAIL - case ENAVAIL: return DRMP3_ERROR; - #endif - #ifdef EISNAM - case EISNAM: return DRMP3_ERROR; - #endif - #ifdef EREMOTEIO - case EREMOTEIO: return DRMP3_IO_ERROR; - #endif - #ifdef EDQUOT - case EDQUOT: return DRMP3_NO_SPACE; - #endif - #ifdef ENOMEDIUM - case ENOMEDIUM: return DRMP3_DOES_NOT_EXIST; - #endif - #ifdef EMEDIUMTYPE - case EMEDIUMTYPE: return DRMP3_ERROR; - #endif - #ifdef ECANCELED - case ECANCELED: return DRMP3_CANCELLED; - #endif - #ifdef ENOKEY - case ENOKEY: return DRMP3_ERROR; - #endif - #ifdef EKEYEXPIRED - case EKEYEXPIRED: return DRMP3_ERROR; - #endif - #ifdef EKEYREVOKED - case EKEYREVOKED: return DRMP3_ERROR; - #endif - #ifdef EKEYREJECTED - case EKEYREJECTED: return DRMP3_ERROR; - #endif - #ifdef EOWNERDEAD - case EOWNERDEAD: return DRMP3_ERROR; - #endif - #ifdef ENOTRECOVERABLE - case ENOTRECOVERABLE: return DRMP3_ERROR; - #endif - #ifdef ERFKILL - case ERFKILL: return DRMP3_ERROR; - #endif - #ifdef EHWPOISON - case EHWPOISON: return DRMP3_ERROR; - #endif - default: return DRMP3_ERROR; - } -} -static drmp3_result drmp3_fopen(FILE** ppFile, const char* pFilePath, const char* pOpenMode) -{ -#if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err; -#endif - if (ppFile != NULL) { - *ppFile = NULL; - } - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return DRMP3_INVALID_ARGS; - } -#if defined(_MSC_VER) && _MSC_VER >= 1400 - err = fopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return drmp3_result_from_errno(err); - } -#else -#if defined(_WIN32) || defined(__APPLE__) - *ppFile = fopen(pFilePath, pOpenMode); -#else - #if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64 && defined(_LARGEFILE64_SOURCE) - *ppFile = fopen64(pFilePath, pOpenMode); - #else - *ppFile = fopen(pFilePath, pOpenMode); - #endif -#endif - if (*ppFile == NULL) { - drmp3_result result = drmp3_result_from_errno(errno); - if (result == DRMP3_SUCCESS) { - result = DRMP3_ERROR; - } - return result; - } -#endif - return DRMP3_SUCCESS; -} -#if defined(_WIN32) - #if defined(_MSC_VER) || defined(__MINGW64__) || (!defined(__STRICT_ANSI__) && !defined(_NO_EXT_KEYS)) - #define DRMP3_HAS_WFOPEN - #endif -#endif -static drmp3_result drmp3_wfopen(FILE** ppFile, const wchar_t* pFilePath, const wchar_t* pOpenMode, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (ppFile != NULL) { - *ppFile = NULL; - } - if (pFilePath == NULL || pOpenMode == NULL || ppFile == NULL) { - return DRMP3_INVALID_ARGS; - } -#if defined(DRMP3_HAS_WFOPEN) - { - #if defined(_MSC_VER) && _MSC_VER >= 1400 - errno_t err = _wfopen_s(ppFile, pFilePath, pOpenMode); - if (err != 0) { - return drmp3_result_from_errno(err); - } - #else - *ppFile = _wfopen(pFilePath, pOpenMode); - if (*ppFile == NULL) { - return drmp3_result_from_errno(errno); - } - #endif - (void)pAllocationCallbacks; - } -#else - #if defined(__DJGPP__) - { - } - #else - { - mbstate_t mbs; - size_t lenMB; - const wchar_t* pFilePathTemp = pFilePath; - char* pFilePathMB = NULL; - char pOpenModeMB[32] = {0}; - DRMP3_ZERO_OBJECT(&mbs); - lenMB = wcsrtombs(NULL, &pFilePathTemp, 0, &mbs); - if (lenMB == (size_t)-1) { - return drmp3_result_from_errno(errno); - } - pFilePathMB = (char*)drmp3__malloc_from_callbacks(lenMB + 1, pAllocationCallbacks); - if (pFilePathMB == NULL) { - return DRMP3_OUT_OF_MEMORY; - } - pFilePathTemp = pFilePath; - DRMP3_ZERO_OBJECT(&mbs); - wcsrtombs(pFilePathMB, &pFilePathTemp, lenMB + 1, &mbs); - { - size_t i = 0; - for (;;) { - if (pOpenMode[i] == 0) { - pOpenModeMB[i] = '\0'; - break; - } - pOpenModeMB[i] = (char)pOpenMode[i]; - i += 1; - } - } - *ppFile = fopen(pFilePathMB, pOpenModeMB); - drmp3__free_from_callbacks(pFilePathMB, pAllocationCallbacks); - } - #endif - if (*ppFile == NULL) { - return DRMP3_ERROR; - } -#endif - return DRMP3_SUCCESS; -} -static size_t drmp3__on_read_stdio(void* pUserData, void* pBufferOut, size_t bytesToRead) -{ - return fread(pBufferOut, 1, bytesToRead, (FILE*)pUserData); -} -static drmp3_bool32 drmp3__on_seek_stdio(void* pUserData, int offset, drmp3_seek_origin origin) -{ - return fseek((FILE*)pUserData, offset, (origin == drmp3_seek_origin_current) ? SEEK_CUR : SEEK_SET) == 0; -} -DRMP3_API drmp3_bool32 drmp3_init_file(drmp3* pMP3, const char* pFilePath, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3_bool32 result; - FILE* pFile; - if (drmp3_fopen(&pFile, pFilePath, "rb") != DRMP3_SUCCESS) { - return DRMP3_FALSE; - } - result = drmp3_init(pMP3, drmp3__on_read_stdio, drmp3__on_seek_stdio, (void*)pFile, pAllocationCallbacks); - if (result != DRMP3_TRUE) { - fclose(pFile); - return result; - } - return DRMP3_TRUE; -} -DRMP3_API drmp3_bool32 drmp3_init_file_w(drmp3* pMP3, const wchar_t* pFilePath, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3_bool32 result; - FILE* pFile; - if (drmp3_wfopen(&pFile, pFilePath, L"rb", pAllocationCallbacks) != DRMP3_SUCCESS) { - return DRMP3_FALSE; - } - result = drmp3_init(pMP3, drmp3__on_read_stdio, drmp3__on_seek_stdio, (void*)pFile, pAllocationCallbacks); - if (result != DRMP3_TRUE) { - fclose(pFile); - return result; - } - return DRMP3_TRUE; -} -#endif -DRMP3_API void drmp3_uninit(drmp3* pMP3) -{ - if (pMP3 == NULL) { - return; - } -#ifndef DR_MP3_NO_STDIO - if (pMP3->onRead == drmp3__on_read_stdio) { - FILE* pFile = (FILE*)pMP3->pUserData; - if (pFile != NULL) { - fclose(pFile); - pMP3->pUserData = NULL; - } - } -#endif - drmp3__free_from_callbacks(pMP3->pData, &pMP3->allocationCallbacks); -} -#if defined(DR_MP3_FLOAT_OUTPUT) -static void drmp3_f32_to_s16(drmp3_int16* dst, const float* src, drmp3_uint64 sampleCount) -{ - drmp3_uint64 i; - drmp3_uint64 i4; - drmp3_uint64 sampleCount4; - i = 0; - sampleCount4 = sampleCount >> 2; - for (i4 = 0; i4 < sampleCount4; i4 += 1) { - float x0 = src[i+0]; - float x1 = src[i+1]; - float x2 = src[i+2]; - float x3 = src[i+3]; - x0 = ((x0 < -1) ? -1 : ((x0 > 1) ? 1 : x0)); - x1 = ((x1 < -1) ? -1 : ((x1 > 1) ? 1 : x1)); - x2 = ((x2 < -1) ? -1 : ((x2 > 1) ? 1 : x2)); - x3 = ((x3 < -1) ? -1 : ((x3 > 1) ? 1 : x3)); - x0 = x0 * 32767.0f; - x1 = x1 * 32767.0f; - x2 = x2 * 32767.0f; - x3 = x3 * 32767.0f; - dst[i+0] = (drmp3_int16)x0; - dst[i+1] = (drmp3_int16)x1; - dst[i+2] = (drmp3_int16)x2; - dst[i+3] = (drmp3_int16)x3; - i += 4; - } - for (; i < sampleCount; i += 1) { - float x = src[i]; - x = ((x < -1) ? -1 : ((x > 1) ? 1 : x)); - x = x * 32767.0f; - dst[i] = (drmp3_int16)x; - } -} -#endif -#if !defined(DR_MP3_FLOAT_OUTPUT) -static void drmp3_s16_to_f32(float* dst, const drmp3_int16* src, drmp3_uint64 sampleCount) -{ - drmp3_uint64 i; - for (i = 0; i < sampleCount; i += 1) { - float x = (float)src[i]; - x = x * 0.000030517578125f; - dst[i] = x; - } -} -#endif -static drmp3_uint64 drmp3_read_pcm_frames_raw(drmp3* pMP3, drmp3_uint64 framesToRead, void* pBufferOut) -{ - drmp3_uint64 totalFramesRead = 0; - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(pMP3->onRead != NULL); - while (framesToRead > 0) { - drmp3_uint32 framesToConsume = (drmp3_uint32)DRMP3_MIN(pMP3->pcmFramesRemainingInMP3Frame, framesToRead); - if (pBufferOut != NULL) { - #if defined(DR_MP3_FLOAT_OUTPUT) - float* pFramesOutF32 = (float*)DRMP3_OFFSET_PTR(pBufferOut, sizeof(float) * totalFramesRead * pMP3->channels); - float* pFramesInF32 = (float*)DRMP3_OFFSET_PTR(&pMP3->pcmFrames[0], sizeof(float) * pMP3->pcmFramesConsumedInMP3Frame * pMP3->mp3FrameChannels); - DRMP3_COPY_MEMORY(pFramesOutF32, pFramesInF32, sizeof(float) * framesToConsume * pMP3->channels); - #else - drmp3_int16* pFramesOutS16 = (drmp3_int16*)DRMP3_OFFSET_PTR(pBufferOut, sizeof(drmp3_int16) * totalFramesRead * pMP3->channels); - drmp3_int16* pFramesInS16 = (drmp3_int16*)DRMP3_OFFSET_PTR(&pMP3->pcmFrames[0], sizeof(drmp3_int16) * pMP3->pcmFramesConsumedInMP3Frame * pMP3->mp3FrameChannels); - DRMP3_COPY_MEMORY(pFramesOutS16, pFramesInS16, sizeof(drmp3_int16) * framesToConsume * pMP3->channels); - #endif - } - pMP3->currentPCMFrame += framesToConsume; - pMP3->pcmFramesConsumedInMP3Frame += framesToConsume; - pMP3->pcmFramesRemainingInMP3Frame -= framesToConsume; - totalFramesRead += framesToConsume; - framesToRead -= framesToConsume; - if (framesToRead == 0) { - break; - } - DRMP3_ASSERT(pMP3->pcmFramesRemainingInMP3Frame == 0); - if (drmp3_decode_next_frame(pMP3) == 0) { - break; - } - } - return totalFramesRead; -} -DRMP3_API drmp3_uint64 drmp3_read_pcm_frames_f32(drmp3* pMP3, drmp3_uint64 framesToRead, float* pBufferOut) -{ - if (pMP3 == NULL || pMP3->onRead == NULL) { - return 0; - } -#if defined(DR_MP3_FLOAT_OUTPUT) - return drmp3_read_pcm_frames_raw(pMP3, framesToRead, pBufferOut); -#else - { - drmp3_int16 pTempS16[8192]; - drmp3_uint64 totalPCMFramesRead = 0; - while (totalPCMFramesRead < framesToRead) { - drmp3_uint64 framesJustRead; - drmp3_uint64 framesRemaining = framesToRead - totalPCMFramesRead; - drmp3_uint64 framesToReadNow = DRMP3_COUNTOF(pTempS16) / pMP3->channels; - if (framesToReadNow > framesRemaining) { - framesToReadNow = framesRemaining; - } - framesJustRead = drmp3_read_pcm_frames_raw(pMP3, framesToReadNow, pTempS16); - if (framesJustRead == 0) { - break; - } - drmp3_s16_to_f32((float*)DRMP3_OFFSET_PTR(pBufferOut, sizeof(float) * totalPCMFramesRead * pMP3->channels), pTempS16, framesJustRead * pMP3->channels); - totalPCMFramesRead += framesJustRead; - } - return totalPCMFramesRead; - } -#endif -} -DRMP3_API drmp3_uint64 drmp3_read_pcm_frames_s16(drmp3* pMP3, drmp3_uint64 framesToRead, drmp3_int16* pBufferOut) -{ - if (pMP3 == NULL || pMP3->onRead == NULL) { - return 0; - } -#if !defined(DR_MP3_FLOAT_OUTPUT) - return drmp3_read_pcm_frames_raw(pMP3, framesToRead, pBufferOut); -#else - { - float pTempF32[4096]; - drmp3_uint64 totalPCMFramesRead = 0; - while (totalPCMFramesRead < framesToRead) { - drmp3_uint64 framesJustRead; - drmp3_uint64 framesRemaining = framesToRead - totalPCMFramesRead; - drmp3_uint64 framesToReadNow = DRMP3_COUNTOF(pTempF32) / pMP3->channels; - if (framesToReadNow > framesRemaining) { - framesToReadNow = framesRemaining; - } - framesJustRead = drmp3_read_pcm_frames_raw(pMP3, framesToReadNow, pTempF32); - if (framesJustRead == 0) { - break; - } - drmp3_f32_to_s16((drmp3_int16*)DRMP3_OFFSET_PTR(pBufferOut, sizeof(drmp3_int16) * totalPCMFramesRead * pMP3->channels), pTempF32, framesJustRead * pMP3->channels); - totalPCMFramesRead += framesJustRead; - } - return totalPCMFramesRead; - } -#endif -} -static void drmp3_reset(drmp3* pMP3) -{ - DRMP3_ASSERT(pMP3 != NULL); - pMP3->pcmFramesConsumedInMP3Frame = 0; - pMP3->pcmFramesRemainingInMP3Frame = 0; - pMP3->currentPCMFrame = 0; - pMP3->dataSize = 0; - pMP3->atEnd = DRMP3_FALSE; - drmp3dec_init(&pMP3->decoder); -} -static drmp3_bool32 drmp3_seek_to_start_of_stream(drmp3* pMP3) -{ - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(pMP3->onSeek != NULL); - if (!drmp3__on_seek(pMP3, 0, drmp3_seek_origin_start)) { - return DRMP3_FALSE; - } - drmp3_reset(pMP3); - return DRMP3_TRUE; -} -static drmp3_bool32 drmp3_seek_forward_by_pcm_frames__brute_force(drmp3* pMP3, drmp3_uint64 frameOffset) -{ - drmp3_uint64 framesRead; -#if defined(DR_MP3_FLOAT_OUTPUT) - framesRead = drmp3_read_pcm_frames_f32(pMP3, frameOffset, NULL); -#else - framesRead = drmp3_read_pcm_frames_s16(pMP3, frameOffset, NULL); -#endif - if (framesRead != frameOffset) { - return DRMP3_FALSE; - } - return DRMP3_TRUE; -} -static drmp3_bool32 drmp3_seek_to_pcm_frame__brute_force(drmp3* pMP3, drmp3_uint64 frameIndex) -{ - DRMP3_ASSERT(pMP3 != NULL); - if (frameIndex == pMP3->currentPCMFrame) { - return DRMP3_TRUE; - } - if (frameIndex < pMP3->currentPCMFrame) { - if (!drmp3_seek_to_start_of_stream(pMP3)) { - return DRMP3_FALSE; - } - } - DRMP3_ASSERT(frameIndex >= pMP3->currentPCMFrame); - return drmp3_seek_forward_by_pcm_frames__brute_force(pMP3, (frameIndex - pMP3->currentPCMFrame)); -} -static drmp3_bool32 drmp3_find_closest_seek_point(drmp3* pMP3, drmp3_uint64 frameIndex, drmp3_uint32* pSeekPointIndex) -{ - drmp3_uint32 iSeekPoint; - DRMP3_ASSERT(pSeekPointIndex != NULL); - *pSeekPointIndex = 0; - if (frameIndex < pMP3->pSeekPoints[0].pcmFrameIndex) { - return DRMP3_FALSE; - } - for (iSeekPoint = 0; iSeekPoint < pMP3->seekPointCount; ++iSeekPoint) { - if (pMP3->pSeekPoints[iSeekPoint].pcmFrameIndex > frameIndex) { - break; - } - *pSeekPointIndex = iSeekPoint; - } - return DRMP3_TRUE; -} -static drmp3_bool32 drmp3_seek_to_pcm_frame__seek_table(drmp3* pMP3, drmp3_uint64 frameIndex) -{ - drmp3_seek_point seekPoint; - drmp3_uint32 priorSeekPointIndex; - drmp3_uint16 iMP3Frame; - drmp3_uint64 leftoverFrames; - DRMP3_ASSERT(pMP3 != NULL); - DRMP3_ASSERT(pMP3->pSeekPoints != NULL); - DRMP3_ASSERT(pMP3->seekPointCount > 0); - if (drmp3_find_closest_seek_point(pMP3, frameIndex, &priorSeekPointIndex)) { - seekPoint = pMP3->pSeekPoints[priorSeekPointIndex]; - } else { - seekPoint.seekPosInBytes = 0; - seekPoint.pcmFrameIndex = 0; - seekPoint.mp3FramesToDiscard = 0; - seekPoint.pcmFramesToDiscard = 0; - } - if (!drmp3__on_seek_64(pMP3, seekPoint.seekPosInBytes, drmp3_seek_origin_start)) { - return DRMP3_FALSE; - } - drmp3_reset(pMP3); - for (iMP3Frame = 0; iMP3Frame < seekPoint.mp3FramesToDiscard; ++iMP3Frame) { - drmp3_uint32 pcmFramesRead; - drmp3d_sample_t* pPCMFrames; - pPCMFrames = NULL; - if (iMP3Frame == seekPoint.mp3FramesToDiscard-1) { - pPCMFrames = (drmp3d_sample_t*)pMP3->pcmFrames; - } - pcmFramesRead = drmp3_decode_next_frame_ex(pMP3, pPCMFrames); - if (pcmFramesRead == 0) { - return DRMP3_FALSE; - } - } - pMP3->currentPCMFrame = seekPoint.pcmFrameIndex - seekPoint.pcmFramesToDiscard; - leftoverFrames = frameIndex - pMP3->currentPCMFrame; - return drmp3_seek_forward_by_pcm_frames__brute_force(pMP3, leftoverFrames); -} -DRMP3_API drmp3_bool32 drmp3_seek_to_pcm_frame(drmp3* pMP3, drmp3_uint64 frameIndex) -{ - if (pMP3 == NULL || pMP3->onSeek == NULL) { - return DRMP3_FALSE; - } - if (frameIndex == 0) { - return drmp3_seek_to_start_of_stream(pMP3); - } - if (pMP3->pSeekPoints != NULL && pMP3->seekPointCount > 0) { - return drmp3_seek_to_pcm_frame__seek_table(pMP3, frameIndex); - } else { - return drmp3_seek_to_pcm_frame__brute_force(pMP3, frameIndex); - } -} -DRMP3_API drmp3_bool32 drmp3_get_mp3_and_pcm_frame_count(drmp3* pMP3, drmp3_uint64* pMP3FrameCount, drmp3_uint64* pPCMFrameCount) -{ - drmp3_uint64 currentPCMFrame; - drmp3_uint64 totalPCMFrameCount; - drmp3_uint64 totalMP3FrameCount; - if (pMP3 == NULL) { - return DRMP3_FALSE; - } - if (pMP3->onSeek == NULL) { - return DRMP3_FALSE; - } - currentPCMFrame = pMP3->currentPCMFrame; - if (!drmp3_seek_to_start_of_stream(pMP3)) { - return DRMP3_FALSE; - } - totalPCMFrameCount = 0; - totalMP3FrameCount = 0; - for (;;) { - drmp3_uint32 pcmFramesInCurrentMP3Frame; - pcmFramesInCurrentMP3Frame = drmp3_decode_next_frame_ex(pMP3, NULL); - if (pcmFramesInCurrentMP3Frame == 0) { - break; - } - totalPCMFrameCount += pcmFramesInCurrentMP3Frame; - totalMP3FrameCount += 1; - } - if (!drmp3_seek_to_start_of_stream(pMP3)) { - return DRMP3_FALSE; - } - if (!drmp3_seek_to_pcm_frame(pMP3, currentPCMFrame)) { - return DRMP3_FALSE; - } - if (pMP3FrameCount != NULL) { - *pMP3FrameCount = totalMP3FrameCount; - } - if (pPCMFrameCount != NULL) { - *pPCMFrameCount = totalPCMFrameCount; - } - return DRMP3_TRUE; -} -DRMP3_API drmp3_uint64 drmp3_get_pcm_frame_count(drmp3* pMP3) -{ - drmp3_uint64 totalPCMFrameCount; - if (!drmp3_get_mp3_and_pcm_frame_count(pMP3, NULL, &totalPCMFrameCount)) { - return 0; - } - return totalPCMFrameCount; -} -DRMP3_API drmp3_uint64 drmp3_get_mp3_frame_count(drmp3* pMP3) -{ - drmp3_uint64 totalMP3FrameCount; - if (!drmp3_get_mp3_and_pcm_frame_count(pMP3, &totalMP3FrameCount, NULL)) { - return 0; - } - return totalMP3FrameCount; -} -static void drmp3__accumulate_running_pcm_frame_count(drmp3* pMP3, drmp3_uint32 pcmFrameCountIn, drmp3_uint64* pRunningPCMFrameCount, float* pRunningPCMFrameCountFractionalPart) -{ - float srcRatio; - float pcmFrameCountOutF; - drmp3_uint32 pcmFrameCountOut; - srcRatio = (float)pMP3->mp3FrameSampleRate / (float)pMP3->sampleRate; - DRMP3_ASSERT(srcRatio > 0); - pcmFrameCountOutF = *pRunningPCMFrameCountFractionalPart + (pcmFrameCountIn / srcRatio); - pcmFrameCountOut = (drmp3_uint32)pcmFrameCountOutF; - *pRunningPCMFrameCountFractionalPart = pcmFrameCountOutF - pcmFrameCountOut; - *pRunningPCMFrameCount += pcmFrameCountOut; -} -typedef struct -{ - drmp3_uint64 bytePos; - drmp3_uint64 pcmFrameIndex; -} drmp3__seeking_mp3_frame_info; -DRMP3_API drmp3_bool32 drmp3_calculate_seek_points(drmp3* pMP3, drmp3_uint32* pSeekPointCount, drmp3_seek_point* pSeekPoints) -{ - drmp3_uint32 seekPointCount; - drmp3_uint64 currentPCMFrame; - drmp3_uint64 totalMP3FrameCount; - drmp3_uint64 totalPCMFrameCount; - if (pMP3 == NULL || pSeekPointCount == NULL || pSeekPoints == NULL) { - return DRMP3_FALSE; - } - seekPointCount = *pSeekPointCount; - if (seekPointCount == 0) { - return DRMP3_FALSE; - } - currentPCMFrame = pMP3->currentPCMFrame; - if (!drmp3_get_mp3_and_pcm_frame_count(pMP3, &totalMP3FrameCount, &totalPCMFrameCount)) { - return DRMP3_FALSE; - } - if (totalMP3FrameCount < DRMP3_SEEK_LEADING_MP3_FRAMES+1) { - seekPointCount = 1; - pSeekPoints[0].seekPosInBytes = 0; - pSeekPoints[0].pcmFrameIndex = 0; - pSeekPoints[0].mp3FramesToDiscard = 0; - pSeekPoints[0].pcmFramesToDiscard = 0; - } else { - drmp3_uint64 pcmFramesBetweenSeekPoints; - drmp3__seeking_mp3_frame_info mp3FrameInfo[DRMP3_SEEK_LEADING_MP3_FRAMES+1]; - drmp3_uint64 runningPCMFrameCount = 0; - float runningPCMFrameCountFractionalPart = 0; - drmp3_uint64 nextTargetPCMFrame; - drmp3_uint32 iMP3Frame; - drmp3_uint32 iSeekPoint; - if (seekPointCount > totalMP3FrameCount-1) { - seekPointCount = (drmp3_uint32)totalMP3FrameCount-1; - } - pcmFramesBetweenSeekPoints = totalPCMFrameCount / (seekPointCount+1); - if (!drmp3_seek_to_start_of_stream(pMP3)) { - return DRMP3_FALSE; - } - for (iMP3Frame = 0; iMP3Frame < DRMP3_SEEK_LEADING_MP3_FRAMES+1; ++iMP3Frame) { - drmp3_uint32 pcmFramesInCurrentMP3FrameIn; - DRMP3_ASSERT(pMP3->streamCursor >= pMP3->dataSize); - mp3FrameInfo[iMP3Frame].bytePos = pMP3->streamCursor - pMP3->dataSize; - mp3FrameInfo[iMP3Frame].pcmFrameIndex = runningPCMFrameCount; - pcmFramesInCurrentMP3FrameIn = drmp3_decode_next_frame_ex(pMP3, NULL); - if (pcmFramesInCurrentMP3FrameIn == 0) { - return DRMP3_FALSE; - } - drmp3__accumulate_running_pcm_frame_count(pMP3, pcmFramesInCurrentMP3FrameIn, &runningPCMFrameCount, &runningPCMFrameCountFractionalPart); - } - nextTargetPCMFrame = 0; - for (iSeekPoint = 0; iSeekPoint < seekPointCount; ++iSeekPoint) { - nextTargetPCMFrame += pcmFramesBetweenSeekPoints; - for (;;) { - if (nextTargetPCMFrame < runningPCMFrameCount) { - pSeekPoints[iSeekPoint].seekPosInBytes = mp3FrameInfo[0].bytePos; - pSeekPoints[iSeekPoint].pcmFrameIndex = nextTargetPCMFrame; - pSeekPoints[iSeekPoint].mp3FramesToDiscard = DRMP3_SEEK_LEADING_MP3_FRAMES; - pSeekPoints[iSeekPoint].pcmFramesToDiscard = (drmp3_uint16)(nextTargetPCMFrame - mp3FrameInfo[DRMP3_SEEK_LEADING_MP3_FRAMES-1].pcmFrameIndex); - break; - } else { - size_t i; - drmp3_uint32 pcmFramesInCurrentMP3FrameIn; - for (i = 0; i < DRMP3_COUNTOF(mp3FrameInfo)-1; ++i) { - mp3FrameInfo[i] = mp3FrameInfo[i+1]; - } - mp3FrameInfo[DRMP3_COUNTOF(mp3FrameInfo)-1].bytePos = pMP3->streamCursor - pMP3->dataSize; - mp3FrameInfo[DRMP3_COUNTOF(mp3FrameInfo)-1].pcmFrameIndex = runningPCMFrameCount; - pcmFramesInCurrentMP3FrameIn = drmp3_decode_next_frame_ex(pMP3, NULL); - if (pcmFramesInCurrentMP3FrameIn == 0) { - pSeekPoints[iSeekPoint].seekPosInBytes = mp3FrameInfo[0].bytePos; - pSeekPoints[iSeekPoint].pcmFrameIndex = nextTargetPCMFrame; - pSeekPoints[iSeekPoint].mp3FramesToDiscard = DRMP3_SEEK_LEADING_MP3_FRAMES; - pSeekPoints[iSeekPoint].pcmFramesToDiscard = (drmp3_uint16)(nextTargetPCMFrame - mp3FrameInfo[DRMP3_SEEK_LEADING_MP3_FRAMES-1].pcmFrameIndex); - break; - } - drmp3__accumulate_running_pcm_frame_count(pMP3, pcmFramesInCurrentMP3FrameIn, &runningPCMFrameCount, &runningPCMFrameCountFractionalPart); - } - } - } - if (!drmp3_seek_to_start_of_stream(pMP3)) { - return DRMP3_FALSE; - } - if (!drmp3_seek_to_pcm_frame(pMP3, currentPCMFrame)) { - return DRMP3_FALSE; - } - } - *pSeekPointCount = seekPointCount; - return DRMP3_TRUE; -} -DRMP3_API drmp3_bool32 drmp3_bind_seek_table(drmp3* pMP3, drmp3_uint32 seekPointCount, drmp3_seek_point* pSeekPoints) -{ - if (pMP3 == NULL) { - return DRMP3_FALSE; - } - if (seekPointCount == 0 || pSeekPoints == NULL) { - pMP3->seekPointCount = 0; - pMP3->pSeekPoints = NULL; - } else { - pMP3->seekPointCount = seekPointCount; - pMP3->pSeekPoints = pSeekPoints; - } - return DRMP3_TRUE; -} -static float* drmp3__full_read_and_close_f32(drmp3* pMP3, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount) -{ - drmp3_uint64 totalFramesRead = 0; - drmp3_uint64 framesCapacity = 0; - float* pFrames = NULL; - float temp[4096]; - DRMP3_ASSERT(pMP3 != NULL); - for (;;) { - drmp3_uint64 framesToReadRightNow = DRMP3_COUNTOF(temp) / pMP3->channels; - drmp3_uint64 framesJustRead = drmp3_read_pcm_frames_f32(pMP3, framesToReadRightNow, temp); - if (framesJustRead == 0) { - break; - } - if (framesCapacity < totalFramesRead + framesJustRead) { - drmp3_uint64 oldFramesBufferSize; - drmp3_uint64 newFramesBufferSize; - drmp3_uint64 newFramesCap; - float* pNewFrames; - newFramesCap = framesCapacity * 2; - if (newFramesCap < totalFramesRead + framesJustRead) { - newFramesCap = totalFramesRead + framesJustRead; - } - oldFramesBufferSize = framesCapacity * pMP3->channels * sizeof(float); - newFramesBufferSize = newFramesCap * pMP3->channels * sizeof(float); - if (newFramesBufferSize > (drmp3_uint64)DRMP3_SIZE_MAX) { - break; - } - pNewFrames = (float*)drmp3__realloc_from_callbacks(pFrames, (size_t)newFramesBufferSize, (size_t)oldFramesBufferSize, &pMP3->allocationCallbacks); - if (pNewFrames == NULL) { - drmp3__free_from_callbacks(pFrames, &pMP3->allocationCallbacks); - break; - } - pFrames = pNewFrames; - framesCapacity = newFramesCap; - } - DRMP3_COPY_MEMORY(pFrames + totalFramesRead*pMP3->channels, temp, (size_t)(framesJustRead*pMP3->channels*sizeof(float))); - totalFramesRead += framesJustRead; - if (framesJustRead != framesToReadRightNow) { - break; - } - } - if (pConfig != NULL) { - pConfig->channels = pMP3->channels; - pConfig->sampleRate = pMP3->sampleRate; - } - drmp3_uninit(pMP3); - if (pTotalFrameCount) { - *pTotalFrameCount = totalFramesRead; - } - return pFrames; -} -static drmp3_int16* drmp3__full_read_and_close_s16(drmp3* pMP3, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount) -{ - drmp3_uint64 totalFramesRead = 0; - drmp3_uint64 framesCapacity = 0; - drmp3_int16* pFrames = NULL; - drmp3_int16 temp[4096]; - DRMP3_ASSERT(pMP3 != NULL); - for (;;) { - drmp3_uint64 framesToReadRightNow = DRMP3_COUNTOF(temp) / pMP3->channels; - drmp3_uint64 framesJustRead = drmp3_read_pcm_frames_s16(pMP3, framesToReadRightNow, temp); - if (framesJustRead == 0) { - break; - } - if (framesCapacity < totalFramesRead + framesJustRead) { - drmp3_uint64 newFramesBufferSize; - drmp3_uint64 oldFramesBufferSize; - drmp3_uint64 newFramesCap; - drmp3_int16* pNewFrames; - newFramesCap = framesCapacity * 2; - if (newFramesCap < totalFramesRead + framesJustRead) { - newFramesCap = totalFramesRead + framesJustRead; - } - oldFramesBufferSize = framesCapacity * pMP3->channels * sizeof(drmp3_int16); - newFramesBufferSize = newFramesCap * pMP3->channels * sizeof(drmp3_int16); - if (newFramesBufferSize > (drmp3_uint64)DRMP3_SIZE_MAX) { - break; - } - pNewFrames = (drmp3_int16*)drmp3__realloc_from_callbacks(pFrames, (size_t)newFramesBufferSize, (size_t)oldFramesBufferSize, &pMP3->allocationCallbacks); - if (pNewFrames == NULL) { - drmp3__free_from_callbacks(pFrames, &pMP3->allocationCallbacks); - break; - } - pFrames = pNewFrames; - framesCapacity = newFramesCap; - } - DRMP3_COPY_MEMORY(pFrames + totalFramesRead*pMP3->channels, temp, (size_t)(framesJustRead*pMP3->channels*sizeof(drmp3_int16))); - totalFramesRead += framesJustRead; - if (framesJustRead != framesToReadRightNow) { - break; - } - } - if (pConfig != NULL) { - pConfig->channels = pMP3->channels; - pConfig->sampleRate = pMP3->sampleRate; - } - drmp3_uninit(pMP3); - if (pTotalFrameCount) { - *pTotalFrameCount = totalFramesRead; - } - return pFrames; -} -DRMP3_API float* drmp3_open_and_read_pcm_frames_f32(drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3 mp3; - if (!drmp3_init(&mp3, onRead, onSeek, pUserData, pAllocationCallbacks)) { - return NULL; - } - return drmp3__full_read_and_close_f32(&mp3, pConfig, pTotalFrameCount); -} -DRMP3_API drmp3_int16* drmp3_open_and_read_pcm_frames_s16(drmp3_read_proc onRead, drmp3_seek_proc onSeek, void* pUserData, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3 mp3; - if (!drmp3_init(&mp3, onRead, onSeek, pUserData, pAllocationCallbacks)) { - return NULL; - } - return drmp3__full_read_and_close_s16(&mp3, pConfig, pTotalFrameCount); -} -DRMP3_API float* drmp3_open_memory_and_read_pcm_frames_f32(const void* pData, size_t dataSize, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3 mp3; - if (!drmp3_init_memory(&mp3, pData, dataSize, pAllocationCallbacks)) { - return NULL; - } - return drmp3__full_read_and_close_f32(&mp3, pConfig, pTotalFrameCount); -} -DRMP3_API drmp3_int16* drmp3_open_memory_and_read_pcm_frames_s16(const void* pData, size_t dataSize, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3 mp3; - if (!drmp3_init_memory(&mp3, pData, dataSize, pAllocationCallbacks)) { - return NULL; - } - return drmp3__full_read_and_close_s16(&mp3, pConfig, pTotalFrameCount); -} -#ifndef DR_MP3_NO_STDIO -DRMP3_API float* drmp3_open_file_and_read_pcm_frames_f32(const char* filePath, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3 mp3; - if (!drmp3_init_file(&mp3, filePath, pAllocationCallbacks)) { - return NULL; - } - return drmp3__full_read_and_close_f32(&mp3, pConfig, pTotalFrameCount); -} -DRMP3_API drmp3_int16* drmp3_open_file_and_read_pcm_frames_s16(const char* filePath, drmp3_config* pConfig, drmp3_uint64* pTotalFrameCount, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - drmp3 mp3; - if (!drmp3_init_file(&mp3, filePath, pAllocationCallbacks)) { - return NULL; - } - return drmp3__full_read_and_close_s16(&mp3, pConfig, pTotalFrameCount); -} -#endif -DRMP3_API void* drmp3_malloc(size_t sz, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - return drmp3__malloc_from_callbacks(sz, pAllocationCallbacks); - } else { - return drmp3__malloc_default(sz, NULL); - } -} -DRMP3_API void drmp3_free(void* p, const drmp3_allocation_callbacks* pAllocationCallbacks) -{ - if (pAllocationCallbacks != NULL) { - drmp3__free_from_callbacks(p, pAllocationCallbacks); - } else { - drmp3__free_default(p, NULL); - } -} -#endif -/* dr_mp3_c end */ -#endif /* DRMP3_IMPLEMENTATION */ -#endif /* MA_NO_MP3 */ - - -/* End globally disabled warnings. */ -#if defined(_MSC_VER) - #pragma warning(pop) -#endif - -#endif /* miniaudio_c */ -#endif /* MINIAUDIO_IMPLEMENTATION */ - - -/* -This software is available as a choice of the following licenses. Choose -whichever you prefer. - -=============================================================================== -ALTERNATIVE 1 - Public Domain (www.unlicense.org) -=============================================================================== -This is free and unencumbered software released into the public domain. - -Anyone is free to copy, modify, publish, use, compile, sell, or distribute this -software, either in source code form or as a compiled binary, for any purpose, -commercial or non-commercial, and by any means. - -In jurisdictions that recognize copyright laws, the author or authors of this -software dedicate any and all copyright interest in the software to the public -domain. We make this dedication for the benefit of the public at large and to -the detriment of our heirs and successors. We intend this dedication to be an -overt act of relinquishment in perpetuity of all present and future rights to -this software under copyright law. - -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 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. - -For more information, please refer to - -=============================================================================== -ALTERNATIVE 2 - MIT No Attribution -=============================================================================== -Copyright 2023 David Reid - -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. - -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. -*/ diff --git a/source/engine/s7.c b/source/engine/s7.c deleted file mode 100644 index fa241bd..0000000 --- a/source/engine/s7.c +++ /dev/null @@ -1,96035 +0,0 @@ -/* s7, a Scheme interpreter - * - * derived from TinyScheme 1.39, but not a single byte of that code remains - * SPDX-License-Identifier: 0BSD - * - * Bill Schottstaedt, bil@ccrma.stanford.edu - * - * Mike Scholz provided the FreeBSD support (complex trig funcs, etc) - * Rick Taube, Andrew Burnson, Donny Ward, Greg Santucci, and Christos Vagias provided the MS Visual C++ support - * Kjetil Matheussen provided the mingw support - * - * Documentation is in s7.h and s7.html. - * s7test.scm is a regression test. - * repl.scm is a vt100-based listener. - * nrepl.scm is a notcurses-based listener. - * cload.scm and lib*.scm tie in various C libraries. - * lint.scm checks Scheme code for infelicities. - * r7rs.scm implements some of r7rs (small). - * write.scm currrently has pretty-print. - * mockery.scm has the mock-data definitions. - * reactive.scm has reactive-set and friends. - * stuff.scm has some stuff. - * profile.scm has code to display profile data. - * debug.scm has debugging aids. - * case.scm has case*, an extension of case to pattern matching. - * timing tests are in the s7 tools directory - * - * s7.c is organized as follows: - * structs and type flags - * internal debugging stuff - * constants - * GC - * stacks - * symbols and keywords - * lets - * continuations - * numbers - * characters - * strings - * ports - * format - * lists - * vectors - * hash-tables - * c-objects - * functions - * equal? - * generic length, copy, reverse, fill!, append - * error handlers - * sundry leftovers - * the optimizers - * multiple-values, quasiquote - * eval - * *s7* - * initialization and free - * repl - * - * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible, - * H_* are documentation strings, Q_* are procedure signatures, scheme "?" corresponds to C "is_", scheme "->" to C "_to_", - * *_1 are ancillary functions, big_* refer to gmp, *_nr means no return, inline_* means always-inline. - * - * ---------------- compile time switches ---------------- - */ - -#if defined __has_include -# if __has_include ("mus-config.h") -# include "mus-config.h" -# endif -#else - #include "mus-config.h" -#endif - -/* - * Your config file goes here, or just replace that #include line with the defines you need. - * The compile-time switches involve booleans, complex numbers, and multiprecision arithmetic. - * Currently we assume we have setjmp.h (used by the error handlers). - * - * Complex number support, which is problematic in C++, Solaris, and netBSD - * is on the HAVE_COMPLEX_NUMBERS switch. In OSX or Linux, if you're not using C++, - * - * #define HAVE_COMPLEX_NUMBERS 1 - * #define HAVE_COMPLEX_TRIG 1 - * - * In C++ I use: - * - * #define HAVE_COMPLEX_NUMBERS 1 - * #define HAVE_COMPLEX_TRIG 0 - * - * In Windows and tcc, both are 0. - * - * Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so - * HAVE_COMPLEX_NUMBERS means we can find - * cimag creal cabs csqrt carg conj - * and HAVE_COMPLEX_TRIG means we have - * cacos cacosh casin casinh catan catanh ccos ccosh cexp clog cpow csin csinh ctan ctanh - * - * When HAVE_COMPLEX_NUMBERS is 0, the complex functions are stubs that simply return their - * argument -- this will be very confusing for the s7 user because, for example, (sqrt -2) - * will return something bogus (it might not signal an error). - * - * so the incoming (non-s7-specific) compile-time switches are - * HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P - * if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead, - * the default is to assume that we're running on a 64-bit machine. - * - * To get multiprecision arithmetic, set WITH_GMP to 1. - * You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later) - * - * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__ - * - * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included. - * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN - * to use nrepl, also define WITH_NOTCURSES - * - * -O3 is often slower than -O2 (at least according to callgrind) - * -march=native seems to improve tree-vectorization which is important in Snd - * -ffast-math makes a mess of NaNs, and does not appear to be faster - * this code doesn't compile anymore in gcc 4.3 - */ - -#if (defined(__GNUC__) || defined(__clang__) || defined(__TINYC__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old */ - #define WITH_GCC 1 -#else - #define WITH_GCC 0 -#endif - - -/* ---------------- initial sizes ---------------- */ - -#ifndef INITIAL_HEAP_SIZE - #define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */ -#endif -/* the heap grows as needed, this is its initial size. If the initial heap is small, s7 can run in about 2.5 Mbytes of memory. - * There are many cases where a bigger heap is faster (but harware cache size probably matters more). - * The heap size must be a multiple of 32. Each object takes 48 bytes. - */ - -#ifndef SYMBOL_TABLE_SIZE - #define SYMBOL_TABLE_SIZE 32749 -#endif -/* names are hashed into the symbol table (a vector) and collisions are chained as lists */ -/* 16381: thash +80 [string_to_symbol_p_p] +40 if 24001, tlet +80 [symbol_p_p], +32 24001 */ - -#ifndef INITIAL_STACK_SIZE - #define INITIAL_STACK_SIZE 4096 /* was 2048 17-Mar-21 */ -#endif -/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */ - -#define STACK_RESIZE_TRIGGER (INITIAL_STACK_SIZE / 2) - -#ifndef INITIAL_PROTECTED_OBJECTS_SIZE - #define INITIAL_PROTECTED_OBJECTS_SIZE 16 -#endif -/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */ - -#ifndef GC_TEMPS_SIZE - #define GC_TEMPS_SIZE 256 -#endif -/* the number of recent objects that are temporarily gc-protected; 8 works for s7test and snd-test. - * For the FFI, this sets the lag between a call on s7_cons and the first moment when its result - * might be vulnerable to the GC. - */ - - -/* ---------------- scheme choices ---------------- */ - -#ifndef WITH_GMP - #define WITH_GMP 0 - /* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc - * WITH_GMP adds the following functions: bignum and bignum?, and (*s7* 'bignum-precision) - */ -#endif - -#ifndef DEFAULT_BIGNUM_PRECISION - #define DEFAULT_BIGNUM_PRECISION 128 /* (*s7* 'bignum-precision) initial value, must be >= 2 */ -#endif - -#ifndef WITH_PURE_S7 - #define WITH_PURE_S7 0 -#endif -#if WITH_PURE_S7 - #define WITH_EXTRA_EXPONENT_MARKERS 0 - #define WITH_IMMUTABLE_UNQUOTE 1 - /* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values - * and a lot more (inexact/exact, integer-length, etc) -- see s7.html. - */ -#endif - -#ifndef WITH_EXTRA_EXPONENT_MARKERS - #define WITH_EXTRA_EXPONENT_MARKERS 0 -#endif -/* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */ - -#ifndef WITH_SYSTEM_EXTRAS - #define WITH_SYSTEM_EXTRAS (!_MSC_VER) - /* this adds several functions that access file info, directories, times, etc */ -#endif - -#ifndef WITH_IMMUTABLE_UNQUOTE - #define WITH_IMMUTABLE_UNQUOTE 0 - /* this removes the name "unquote" */ -#endif - -#ifndef WITH_C_LOADER - #if WITH_GCC && (!__MINGW32__) && (!__CYGWIN__) - #define WITH_C_LOADER 1 - /* (load file.so [e]) looks for (e 'init_func) and if found, calls it as the shared object init function. - * If WITH_SYSTEM_EXTRAS is 0, the caller needs to supply system and delete-file so that cload.scm works. - */ - #else - #define WITH_C_LOADER 0 - /* I think dlopen et al are available in MS C, but I have no way to test them; see load_shared_object below */ - #endif -#endif - -#ifndef WITH_HISTORY - #define WITH_HISTORY 0 - /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */ -#endif - -#ifndef DEFAULT_HISTORY_SIZE - #define DEFAULT_HISTORY_SIZE 8 - /* this is the default length of the eval history buffer */ -#endif -#if WITH_HISTORY - #define MAX_HISTORY_SIZE 1048576 -#endif - -#ifndef DEFAULT_PRINT_LENGTH - #define DEFAULT_PRINT_LENGTH 12 /* (*s7* 'print-length) initial value, was 32 but Snd uses 12, 23-Jul-21 */ -#endif - -#ifndef WITH_NUMBER_SEPARATOR - #define WITH_NUMBER_SEPARATOR 0 -#endif - -/* in case mus-config.h forgets these */ -#ifdef _MSC_VER - #ifndef HAVE_COMPLEX_NUMBERS - #define HAVE_COMPLEX_NUMBERS 0 - #endif - #ifndef HAVE_COMPLEX_TRIG - #define HAVE_COMPLEX_TRIG 0 - #endif -#else - #ifndef HAVE_COMPLEX_NUMBERS - #if __TINYC__ - #define HAVE_COMPLEX_NUMBERS 0 - #else - #define HAVE_COMPLEX_NUMBERS 1 - #endif - #endif - #if __cplusplus || __TINYC__ - #ifndef HAVE_COMPLEX_TRIG - #define HAVE_COMPLEX_TRIG 0 - #endif - #else - #ifndef HAVE_COMPLEX_TRIG - #define HAVE_COMPLEX_TRIG 1 - #endif - #endif -#endif - -#ifndef WITH_MULTITHREAD_CHECKS - #define WITH_MULTITHREAD_CHECKS 0 - /* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */ -#endif - -#ifndef WITH_WARNINGS - #define WITH_WARNINGS 0 - /* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */ -#endif - -#ifndef S7_DEBUGGING - #define S7_DEBUGGING 0 -#endif - -#undef DEBUGGING -#define DEBUGGING typo! -#define HAVE_GMP typo! - -#define SHOW_EVAL_OPS 0 -#ifndef _GNU_SOURCE - #define _GNU_SOURCE /* for qsort_r, grumble... */ -#endif - -#ifndef _MSC_VER - #include - #include - #include - #include - #include -#else - /* in Snd these are in mus-config.h */ - #ifndef MUS_CONFIG_H_LOADED - #if _MSC_VER < 1900 - #define snprintf _snprintf - #endif - #if _MSC_VER > 1200 - #define _CRT_SECURE_NO_DEPRECATE 1 - #define _CRT_NONSTDC_NO_DEPRECATE 1 - #define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1 - #endif - #endif - #include - #pragma warning(disable: 4244) /* conversion might cause loss of data warning */ -#endif - -#if WITH_GCC && (!S7_DEBUGGING) - #define Inline inline __attribute__((__always_inline__)) -#else - #ifdef _MSC_VER - #define Inline __forceinline - #else - #define Inline inline - #endif -#endif - -#ifndef WITH_VECTORIZE - #define WITH_VECTORIZE 1 -#endif - -#if (WITH_VECTORIZE) && (defined(__GNUC__) && __GNUC__ >= 5) /* is this included -in -O2 now? */ - #define Vectorized __attribute__((optimize("tree-vectorize"))) -#else - #define Vectorized -#endif - -#if WITH_GCC - #define Sentinel __attribute__((sentinel)) -#else - #define Sentinel -#endif - -#ifdef _MSC_VER - #define noreturn _Noreturn /* deprecated in C23 */ -#else - #define noreturn __attribute__((noreturn)) - /* this is ok in gcc/g++/clang and tcc; pure attribute is rarely applicable here, and does not seem to be helpful (maybe safe_strlen) */ -#endif - -#ifndef S7_ALIGNED - #define S7_ALIGNED 0 - /* memclr, local_strcmp and local_memset */ -#endif - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef _MSC_VER - #define MS_WINDOWS 1 -#else - #define MS_WINDOWS 0 -#endif - -#if defined(_MSC_VER) || defined(__MINGW32__) - #define Jmp_Buf jmp_buf - #define SetJmp(A, B) setjmp(A) - #define LongJmp(A, B) longjmp(A, B) -#else - #define Jmp_Buf sigjmp_buf - #define SetJmp(A, B) sigsetjmp(A, B) - #define LongJmp(A, B) siglongjmp(A, B) - /* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??) - * unfortunately sigsetjmp is noticeably slower than setjmp, especially when s7_optimize_1 is called a lot. - * In one case, the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 seconds, and - * yet callgrind says there is almost no difference? I removed setjmp from s7_optimize. - */ -#endif - -#if (!MS_WINDOWS) - #include -#endif - -#if __cplusplus - #include -#else - #include -#endif - -/* there is also apparently __STDC_NO_COMPLEX__ */ -#if HAVE_COMPLEX_NUMBERS - #if __cplusplus - #include - #else - #include - #ifndef __SUNPRO_C - #if defined(__sun) && defined(__SVR4) - #undef _Complex_I - #define _Complex_I 1.0fi - #endif - #endif - #endif - - #ifndef CMPLX - #if (!(defined(__cplusplus))) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)) && !defined(__INTEL_COMPILER) - #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) - #else - #define CMPLX(r, i) ((r) + ((i) * _Complex_I)) - #endif - #endif -#endif - -#include "s7.h" - -#ifndef M_PI - #define M_PI 3.1415926535897932384626433832795029L -#endif - -#ifndef INFINITY - #ifndef HUGE_VAL - #define INFINITY (1.0/0.0) /* -log(0.0) is triggering dumb complaints from cppcheck */ - /* there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF, gcc has __builtin_huge_val() */ - #else - #define INFINITY HUGE_VAL - #endif -#endif - -#ifndef NAN - #define NAN (INFINITY / INFINITY) /* apparently ieee754 suggests 0.0/0.0 */ -#endif - -#define BOLD_TEXT "\033[1m" -#define UNBOLD_TEXT "\033[22m" - -#if ((!__NetBSD__) && ((_MSC_VER) || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L)))) - #define __func__ __FUNCTION__ -#endif - -#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) - #define NUMBER_NAME_SIZE 2 /* pointless */ - #define POINTER_32 true -#else - #define NUMBER_NAME_SIZE 22 /* leave 1 for uint8_t name len (byte 0), 1 for terminating nul */ - #define POINTER_32 false -#endif - -#define WRITE_REAL_PRECISION 16 -typedef long double long_double; - -#define ld64 PRId64 -#define p64 PRIdPTR - -#define MAX_FLOAT_FORMAT_PRECISION 128 - -/* types */ -enum {T_FREE = 0, - T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYNTAX, T_SYMBOL, - T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX, - T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, - T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR, - T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT, T_RANDOM_STATE, T_CONTINUATION, T_GOTO, - T_CLOSURE, T_CLOSURE_STAR, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, - T_C_MACRO, T_C_FUNCTION_STAR, T_C_FUNCTION, T_C_RST_NO_REQ_FUNCTION, - NUM_TYPES}; -/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */ - -static const char *s7_type_names[] = - {"free", "pair", "nil", "unused", "undefined", "unspecified", "eof_object", "boolean", "character", "syntax", "symbol", - "integer", "ratio", "real", "complex", "big_integer", "big_ratio", "big_real", "big_complex", - "string", "c_object", "vector", "int_vector", "float_vector", "byte_vector", - "catch", "dynamic_wind", "hash_table", "let", "iterator", - "stack", "counter", "slot", "c_pointer", "output_port", "input_port", "random_state", "continuation", "goto", - "closure", "closure*", "macro", "macro*", "bacro", "bacro*", - "c_macro", "c_function*", "c_function", "c_rst_no_req_function", - }; - -/* 1:T_PAIR, 2:T_NIL, 3:T_UNUSED, 4:T_UNDEFINED, 5:T_UNSPECIFIED, 6:T_EOF, 7:T_BOOLEAN, 8:T_CHARACTER, 9:T_SYNTAX, 10:T_SYMBOL, - 11:T_INTEGER, 12:T_RATIO, 13:T_REAL, 14:T_COMPLEX, 15:T_BIG_INTEGER, 16:T_BIG_RATIO, 17:T_BIG_REAL, 18:T_BIG_COMPLEX, - 19:T_STRING, 20:T_C_OBJECT, 21:T_VECTOR, 22:T_INT_VECTOR, 23:T_FLOAT_VECTOR, 24:T_BYTE_VECTOR, - 25:T_CATCH, 26:T_DYNAMIC_WIND, 27:T_HASH_TABLE, 28:T_LET, 29:T_ITERATOR, - 30:T_STACK, 31:T_COUNTER, 32:T_SLOT, 33:T_C_POINTER, 34:T_OUTPUT_PORT, 35:T_INPUT_PORT, 36:T_RANDOM_STATE, 37:T_CONTINUATION, 38:T_GOTO, - 39:T_CLOSURE, 40:T_CLOSURE_STAR, 41:T_MACRO, 42:T_MACRO_STAR, 43:T_BACRO, 44:T_BACRO_STAR, - 45:T_C_MACRO, 46:T_C_FUNCTION_STAR, 47:T_C_FUNCTION, 48:T_C_RST_NO_REQ_FUNCTION, - 49:NUM_TYPES -*/ - -typedef struct block_t { - union { - void *data; - s7_pointer d_ptr; - s7_int *i_ptr; - } dx; - int32_t index; - union { - bool needs_free; - uint32_t tag; - } ln; - s7_int size; - union { - struct block_t *next; - char *documentation; - s7_pointer ksym; - s7_int nx_int; - s7_int *ix_ptr; - struct { - uint32_t i1, i2; - } ix; - } nx; - union { - s7_pointer ex_ptr; - void *ex_info; - s7_int ckey; - } ex; -} block_t; - -#define NUM_BLOCK_LISTS 18 -#define TOP_BLOCK_LIST 17 -#define BLOCK_LIST 0 - -#define block_data(p) p->dx.data -#define block_index(p) p->index -#define block_set_index(p, Index) p->index = Index -#define block_size(p) p->size -#define block_set_size(p, Size) p->size = Size -#define block_next(p) p->nx.next -#define block_info(p) p->ex.ex_info - -typedef block_t hash_entry_t; /* I think this means we waste 8 bytes per entry but can use the mallocate functions */ -#define hash_entry_key(p) p->dx.d_ptr -#define hash_entry_value(p) (p)->ex.ex_ptr -#define hash_entry_set_value(p, Val) p->ex.ex_ptr = Val -#define hash_entry_next(p) block_next(p) -#define hash_entry_raw_hash(p) block_size(p) -#define hash_entry_set_raw_hash(p, Hash) block_set_size(p, Hash) - -typedef block_t vdims_t; -#define vdims_rank(p) p->size -#define vector_elements_should_be_freed(p) p->ln.needs_free -#define vdims_dims(p) p->dx.i_ptr -#define vdims_offsets(p) p->nx.ix_ptr -#define vdims_original(p) p->ex.ex_ptr - - -typedef enum {TOKEN_EOF, TOKEN_LEFT_PAREN, TOKEN_RIGHT_PAREN, TOKEN_DOT, TOKEN_ATOM, TOKEN_QUOTE, TOKEN_DOUBLE_QUOTE, TOKEN_BACK_QUOTE, - TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST, TOKEN_VECTOR, TOKEN_BYTE_VECTOR, TOKEN_INT_VECTOR, TOKEN_FLOAT_VECTOR} token_t; - -typedef enum {NO_ARTICLE, INDEFINITE_ARTICLE} article_t; -typedef enum {DWIND_INIT, DWIND_BODY, DWIND_FINISH} dwind_t; -enum {NO_SAFETY = 0, IMMUTABLE_VECTOR_SAFETY, MORE_SAFETY_WARNINGS}; /* (*s7* 'safety) settings */ - -typedef enum {FILE_PORT, STRING_PORT, FUNCTION_PORT} port_type_t; - -typedef struct { - int32_t (*read_character)(s7_scheme *sc, s7_pointer port); /* function to read a character, int32_t for EOF */ - void (*write_character)(s7_scheme *sc, uint8_t c, s7_pointer port); /* function to write a character */ - void (*write_string)(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); /* function to write a string of known length */ - token_t (*read_semicolon)(s7_scheme *sc, s7_pointer port); /* internal skip-to-semicolon reader */ - int32_t (*read_white_space)(s7_scheme *sc, s7_pointer port); /* internal skip white space reader */ - s7_pointer (*read_name)(s7_scheme *sc, s7_pointer pt); /* internal get-next-name reader */ - s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer pt); /* internal get-next-sharp-constant reader */ - s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case); /* function to read a string up to \n */ - void (*displayer)(s7_scheme *sc, const char *s, s7_pointer pt); - void (*close_port)(s7_scheme *sc, s7_pointer p); /* close-in|output-port */ -} port_functions_t; - -typedef struct { - bool needs_free, is_closed; - port_type_t ptype; - FILE *file; - char *filename; - block_t *filename_block; - uint32_t line_number, file_number; - s7_int filename_length; - block_t *block; - s7_pointer orig_str; /* GC protection for string port string or function port function */ - const port_functions_t *pf; - s7_pointer (*input_function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port); - void (*output_function)(s7_scheme *sc, uint8_t c, s7_pointer port); -} port_t; - -typedef enum {o_d_v, o_d_vd, o_d_vdd, o_d_vid, o_d_id, o_d_7pi, o_d_7pii, o_d_7piid, o_d_7piii, o_d_7piiid, - o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd, o_d_dddd, - o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii, o_d_p, - o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii, o_b_7ii, o_b_dd, - o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp, o_p_ppp, o_p_pi, o_p_pi_unchecked, - o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i, o_b_d} opt_func_t; - -typedef struct opt_funcs_t { - opt_func_t typ; - void *func; - struct opt_funcs_t *next; -} opt_funcs_t; - -typedef struct { - const char *name; - int32_t name_length; - uint32_t id; - const char *doc; - opt_funcs_t *opt_data; /* vunion-functions (see below) */ - s7_pointer generic_ff, setter, signature, pars; - s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops); - /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */ - union { - s7_pointer *arg_defaults; - s7_pointer bool_setter; - } dam; - union { - s7_pointer *arg_names; - s7_pointer c_sym; - } sam; - union { - s7_pointer call_args; - void (*marker)(s7_pointer p, s7_int len); - } cam; -} c_proc_t; - - -typedef struct { - s7_int type, outer_type; - s7_pointer scheme_name, getter, setter; - void (*mark)(void *val); - void (*free)(void *value); /* this will go away someday (use gc_free) */ - bool (*eql)(void *val1, void *val2); /* this will go away someday (use equal) */ -#if (!DISABLE_DEPRECATED) - char *(*print)(s7_scheme *sc, void *value); -#endif - s7_pointer (*equal) (s7_scheme *sc, s7_pointer args); - s7_pointer (*equivalent) (s7_scheme *sc, s7_pointer args); - s7_pointer (*ref) (s7_scheme *sc, s7_pointer args); - s7_pointer (*set) (s7_scheme *sc, s7_pointer args); - s7_pointer (*length) (s7_scheme *sc, s7_pointer args); - s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args); - s7_pointer (*copy) (s7_scheme *sc, s7_pointer args); - s7_pointer (*fill) (s7_scheme *sc, s7_pointer args); - s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args); - s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args); - s7_pointer (*gc_mark) (s7_scheme *sc, s7_pointer args); - s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer args); -} c_object_t; - - -typedef s7_int (*hash_map_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object->location mapper */ -typedef hash_entry_t *(*hash_check_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object equality function */ -static hash_map_t default_hash_map[NUM_TYPES]; - -typedef s7_int (*s7_i_7pi_t)(s7_scheme *sc, s7_pointer p, s7_int i1); -typedef s7_int (*s7_i_7pii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2); -typedef s7_int (*s7_i_7piii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3); -typedef s7_int (*s7_i_iii_t)(s7_int i1, s7_int i2, s7_int i3); -typedef s7_int (*s7_i_7i_t)(s7_scheme *sc, s7_int i1); -typedef s7_int (*s7_i_7ii_t)(s7_scheme *sc, s7_int i1, s7_int i2); -typedef bool (*s7_b_pp_t)(s7_pointer p1, s7_pointer p2); -typedef bool (*s7_b_7pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); -typedef bool (*s7_b_7p_t)(s7_scheme *sc, s7_pointer p1); -typedef bool (*s7_b_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i2); -typedef bool (*s7_b_d_t)(s7_double p1); -typedef bool (*s7_b_i_t)(s7_int p1); -typedef bool (*s7_b_ii_t)(s7_int p1, s7_int p2); -typedef bool (*s7_b_7ii_t)(s7_scheme *sc, s7_int p1, s7_int p2); -typedef bool (*s7_b_dd_t)(s7_double p1, s7_double p2); -typedef s7_pointer (*s7_p_t)(s7_scheme *sc); -typedef s7_pointer (*s7_p_ppi_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1); -typedef s7_pointer (*s7_p_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i1); -typedef s7_pointer (*s7_p_pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2); -typedef s7_pointer (*s7_p_pip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2); -typedef s7_pointer (*s7_p_piip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3); -typedef s7_pointer (*s7_p_i_t)(s7_scheme *sc, s7_int i); -typedef s7_pointer (*s7_p_ii_t)(s7_scheme *sc, s7_int i1, s7_int i2); -typedef s7_pointer (*s7_p_dd_t)(s7_scheme *sc, s7_double x1, s7_double x2); -typedef s7_double (*s7_d_7d_t)(s7_scheme *sc, s7_double p1); -typedef s7_double (*s7_d_7dd_t)(s7_scheme *sc, s7_double p1, s7_double p2); -typedef s7_double (*s7_d_7pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2); -typedef s7_double (*s7_d_7piid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_double x1); -typedef s7_double (*s7_d_7piii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_int i3); -typedef s7_double (*s7_d_7piiid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_int i3, s7_double x1); - -typedef struct opt_info opt_info; - -typedef union { - s7_int i; - s7_double x; - s7_pointer p; - void *obj; - opt_info *o1; - s7_function call; - s7_double (*d_f)(void); - s7_double (*d_d_f)(s7_double x); - s7_double (*d_7d_f)(s7_scheme *sc, s7_double x); - s7_double (*d_dd_f)(s7_double x1, s7_double x2); - s7_double (*d_7dd_f)(s7_scheme *sc, s7_double x1, s7_double x2); - s7_double (*d_ddd_f)(s7_double x1, s7_double x2, s7_double x3); - s7_double (*d_dddd_f)(s7_double x1, s7_double x2, s7_double x3, s7_double x4); - s7_double (*d_v_f)(void *obj); - s7_double (*d_vd_f)(void *obj, s7_double fm); - s7_double (*d_vdd_f)(void *obj, s7_double x1, s7_double x2); - s7_double (*d_vid_f)(void *obj, s7_int i, s7_double fm); - s7_double (*d_id_f)(s7_int i, s7_double fm); - s7_double (*d_7pi_f)(s7_scheme *sc, s7_pointer obj, s7_int i1); - s7_double (*d_7pid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_double x); - s7_double (*d_7pii_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2); - s7_double (*d_7piid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_double x); - s7_double (*d_7piii_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_int i3); - s7_double (*d_7piiid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_int i3, s7_double x); - s7_double (*d_ip_f)(s7_int i1, s7_pointer p); - s7_double (*d_pd_f)(s7_pointer obj, s7_double x); - s7_double (*d_p_f)(s7_pointer p); - s7_int (*i_7d_f)(s7_scheme *sc, s7_double i1); - s7_int (*i_7p_f)(s7_scheme *sc, s7_pointer i1); - s7_int (*i_i_f)(s7_int i1); - s7_int (*i_7i_f)(s7_scheme *sc, s7_int i1); - s7_int (*i_ii_f)(s7_int i1, s7_int i2); - s7_int (*i_7ii_f)(s7_scheme *sc, s7_int i1, s7_int i2); - s7_int (*i_iii_f)(s7_int i1, s7_int i2, s7_int i3); - s7_int (*i_7pi_f)(s7_scheme *sc, s7_pointer p, s7_int i1); - s7_int (*i_7pii_f)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2); - s7_int (*i_7piii_f)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3); - bool (*b_i_f)(s7_int p); - bool (*b_d_f)(s7_double p); - bool (*b_p_f)(s7_pointer p); - bool (*b_pp_f)(s7_pointer p1, s7_pointer p2); - bool (*b_7pp_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); - bool (*b_7p_f)(s7_scheme *sc, s7_pointer p1); - bool (*b_pi_f)(s7_scheme *sc, s7_pointer p1, s7_int i2); - bool (*b_ii_f)(s7_int i1, s7_int i2); - bool (*b_7ii_f)(s7_scheme *sc, s7_int i1, s7_int i2); - bool (*b_dd_f)(s7_double x1, s7_double x2); - s7_pointer (*p_f)(s7_scheme *sc); - s7_pointer (*p_p_f)(s7_scheme *sc, s7_pointer p); - s7_pointer (*p_pp_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); - s7_pointer (*p_ppp_f)(s7_scheme *sc, s7_pointer p, s7_pointer p2, s7_pointer p3); - s7_pointer (*p_pi_f)(s7_scheme *sc, s7_pointer p1, s7_int i1); - s7_pointer (*p_pii_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2); - s7_pointer (*p_ppi_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1); - s7_pointer (*p_pip_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2); - s7_pointer (*p_piip_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3); - s7_pointer (*p_i_f)(s7_scheme *sc, s7_int i); - s7_pointer (*p_ii_f)(s7_scheme *sc, s7_int x1, s7_int x2); - s7_pointer (*p_d_f)(s7_scheme *sc, s7_double x); - s7_pointer (*p_dd_f)(s7_scheme *sc, s7_double x1, s7_double x2); - s7_double (*fd)(opt_info *o); - s7_int (*fi)(opt_info *o); - bool (*fb)(opt_info *o); - s7_pointer (*fp)(opt_info *o); -} vunion; - -#define NUM_VUNIONS 15 -struct opt_info { - vunion v[NUM_VUNIONS]; - s7_scheme *sc; -}; - -#define O_WRAP (NUM_VUNIONS - 1) - -#if WITH_GMP -typedef struct bigint {mpz_t n; struct bigint *nxt;} bigint; -typedef struct bigrat {mpq_t q; struct bigrat *nxt;} bigrat; -typedef struct bigflt {mpfr_t x; struct bigflt *nxt;} bigflt; -typedef struct bigcmp {mpc_t z; struct bigcmp *nxt;} bigcmp; - -typedef struct { - mpfr_t error, ux, x0, x1; - mpz_t i, i0, i1, n; - mpz_t p0, q0, r, r1, p1, q1, old_p1, old_q1; - mpfr_t val, e0, e1, e0p, e1p, old_e0, old_e1, old_e0p; - mpq_t q; -} rat_locals_t; -#endif - -typedef intptr_t opcode_t; - - -/* -------------------------------- cell structure -------------------------------- */ - -typedef struct s7_cell { - union { - uint64_t flag; /* type info */ - int64_t signed_flag; - uint8_t type_field; - uint16_t sflag; - struct { - uint32_t unused_low_flag; - uint16_t opt_choice; - uint16_t high_flag; - } opts; - } tf; - union { - - union { /* integers, floats */ - s7_int integer_value; - s7_double real_value; - - struct { /* ratios */ - s7_int numerator; - s7_int denominator; - } fraction_value; - - struct { /* complex numbers */ - s7_double rl; - s7_double im; - } complex_value; - -#if WITH_GMP - bigint *bgi; /* bignums */ - bigrat *bgr; - bigflt *bgf; - bigcmp *bgc; -#endif - } number; - - struct { - s7_int unused1, unused2; /* always int64_t so this is 16 bytes */ - uint8_t name[24]; - } number_name; - - struct { /* ports */ - port_t *port; - uint8_t *data; - s7_int size, point; - block_t *block; - } prt; - - struct{ /* characters */ - uint8_t c, up_c; - int32_t length; - bool alpha_c, digit_c, space_c, upper_c, lower_c; - char c_name[12]; - } chr; - - struct { /* c-pointers */ - void *c_pointer; - s7_pointer c_type, info, weak1, weak2; - } cptr; - - struct { /* vectors */ - s7_int length; - union { - s7_pointer *objects; - s7_int *ints; - s7_double *floats; - uint8_t *bytes; - } elements; - block_t *block; - s7_pointer (*vget)(s7_scheme *sc, s7_pointer vec, s7_int loc); - union { - s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); - s7_pointer fset; - } setv; - } vector; - - struct { /* stacks (internal) struct must match vector above for length/objects */ - s7_int length; - s7_pointer *objects; - block_t *block; - int64_t top, flags; - } stk; - - struct { /* hash-tables */ - s7_int mask; - hash_entry_t **elements; /* a pointer into block below: takes up a field in object.hasher but is faster (50 in thash) */ - hash_check_t hash_func; - hash_map_t *loc; - block_t *block; - } hasher; - - struct { /* iterators */ - s7_pointer obj, cur; - union { - s7_int loc; - s7_pointer lcur; - } lc; - union { - s7_int len; - s7_pointer slow; - hash_entry_t *hcur; - } lw; - s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator); - } iter; - - struct { - c_proc_t *c_proc; /* C functions, macros */ - s7_function ff; - s7_int required_args, optional_args, all_args; /* these could be uint32_t */ - } fnc; - - struct { /* pairs */ - s7_pointer car, cdr, opt1; - union - { - s7_pointer opt2; - s7_int n; - } o2; - union { - s7_pointer opt3; - s7_int n; - uint8_t opt_type; - } o3; - } cons; - - struct { /* special purpose pairs (symbol-table etc) */ - s7_pointer unused_car, unused_cdr; - uint64_t hash; - const char *fstr; - uint64_t location; /* line/file/position, also used in symbol_table as raw_len */ - } sym_cons; - - struct { /* scheme functions */ - s7_pointer args, body, env, setter; /* args can be a symbol, as well as a list, setter can be #f as well as a procedure/closure */ - int32_t arity; - } func; - - struct { /* strings */ - s7_int length; - char *svalue; - uint64_t hash; /* string hash-index */ - block_t *block; - block_t *gensym_block; - } string; - - struct { /* symbols */ - s7_pointer name, global_slot, local_slot; - int64_t id; /* which let last bound the symbol -- for faster symbol lookup */ - uint32_t ctr; /* how many times has symbol been bound */ - uint32_t tag; /* symbol as member of a set (tree-set-memq etc), high 32 bits are in symbol_info (the string block) */ - } sym; - - struct { /* syntax */ - s7_pointer symbol; - opcode_t op; - int32_t min_args, max_args; - const char *documentation; - } syn; - - struct { /* slots (bindings) */ - s7_pointer sym, val, nxt, pending_value, expr; /* pending_value is also the setter field which works by a whisker */ - } slt; - - struct { /* lets (environments) */ - s7_pointer slots, nxt; - int64_t id; /* id of rootlet is -1 */ - union { - struct { - s7_pointer function; /* *function* (symbol) if this is a funclet */ - uint32_t line, file; /* *function* location if it is known */ - } efnc; - struct { - s7_pointer dox1, dox2; /* do loop variables */ - } dox; - s7_int key; /* sc->baffle_ctr type */ - } edat; - } envr; - - struct { /* special stuff like # */ - s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */ - int64_t unused_let_id; /* let_id(sc->nil) is -1, so this needs to align with envr.id above, only used by sc->nil, so free elsewhere */ - const char *name; - s7_int len; - } unq; - - struct { /* #<...> */ - char *name; /* not const because the GC frees it */ - s7_int len; - } undef; - - struct { /* # */ - const char *name; - s7_int len; - } eof; - - struct { /* counter (internal) */ - s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each let created) */ - uint64_t cap; /* sc->capture_let_counter for let reuse */ - } ctr; - - struct { /* random-state */ -#if WITH_GMP - gmp_randstate_t state; -#else - uint64_t seed, carry; -#endif - } rng; - - struct { /* additional object types (C) */ - s7_int type; - void *value; /* the value the caller associates with the c_object */ - s7_pointer e; /* the method list, if any (openlet) */ - s7_scheme *sc; - } c_obj; - - struct { /* continuations */ - block_t *block; - s7_pointer stack, op_stack; - s7_pointer *stack_start, *stack_end; - } cwcc; - - struct { /* call-with-exit */ - uint64_t goto_loc, op_stack_loc; - bool active; - s7_pointer name; - } rexit; - - struct { /* catch */ - uint64_t goto_loc, op_stack_loc; - s7_pointer tag; - s7_pointer handler; - Jmp_Buf *cstack; - } rcatch; /* C++ reserves "catch" I guess */ - - struct { /* dynamic-wind */ - s7_pointer in, out, body; - dwind_t state; - } winder; - } object; - -#if S7_DEBUGGING - int32_t alloc_line, uses, explicit_free_line, gc_line, holders; - int64_t alloc_type, debugger_bits; - const char *alloc_func, *gc_func, *root; - s7_pointer holder; -#endif -} s7_cell; - - -typedef struct s7_big_cell { - s7_cell cell; - int64_t big_hloc; -} s7_big_cell; -typedef struct s7_big_cell *s7_big_pointer; - -typedef struct heap_block_t { - intptr_t start, end; - int64_t offset; - struct heap_block_t *next; -} heap_block_t; - -typedef struct { - s7_pointer *objs; - int32_t size, top, ref, size2; - bool has_hits; - int32_t *refs; - s7_pointer cycle_port, init_port; - s7_int cycle_loc, init_loc, ctr; - bool *defined; -} shared_info_t; - -typedef struct { - s7_int loc, curly_len, ctr; - char *curly_str; - s7_pointer args, orig_str, curly_arg, port, strport; -} format_data_t; - -typedef struct gc_obj_t { - s7_pointer p; - struct gc_obj_t *nxt; -} gc_obj_t; - -typedef struct { - s7_pointer *list; - s7_int size, loc; -} gc_list_t; - -typedef struct { - s7_int size, top, excl_size, excl_top; - s7_pointer *funcs, *let_names, *files; - s7_int *timing_data, *excl, *lines; -} profile_data_t; - - -/* -------------------------------- s7_scheme struct -------------------------------- */ -struct s7_scheme { - s7_pointer code; /* layout of first 4 entries should match stack frame layout */ - s7_pointer curlet; - s7_pointer args; - opcode_t cur_op; - s7_pointer value, cur_code; - token_t tok; - - s7_pointer stack; /* stack is a vector */ - uint32_t stack_size; - s7_pointer *stack_start, *stack_end, *stack_resize_trigger; - - s7_pointer *op_stack, *op_stack_now, *op_stack_end; - uint32_t op_stack_size, max_stack_size; - - s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, **previous_free_heap_top; - int64_t heap_size, gc_freed, gc_total_freed, max_heap_size, gc_temps_size; - s7_double gc_resize_heap_fraction, gc_resize_heap_by_4_fraction; - s7_int gc_calls, gc_total_time, gc_start, gc_end; - heap_block_t *heap_blocks; - -#if WITH_HISTORY - s7_pointer eval_history1, eval_history2, error_history, history_sink, history_pairs, old_cur_code; - bool using_history1; -#endif - -#if WITH_MULTITHREAD_CHECKS - int32_t lock_count; - pthread_mutex_t lock; -#endif - - gc_obj_t *semipermanent_objects, *semipermanent_lets; - s7_pointer protected_objects, protected_setters, protected_setter_symbols; /* vectors of gc-protected objects */ - s7_int *protected_objects_free_list; /* to avoid a linear search for a place to store an object in sc->protected_objects */ - s7_int protected_objects_size, protected_setters_size, protected_setters_loc; - s7_int protected_objects_free_list_loc; - - s7_pointer nil; /* empty list */ - s7_pointer T; /* #t */ - s7_pointer F; /* #f */ - s7_pointer undefined; /* # */ - s7_pointer unspecified; /* # */ - s7_pointer no_value; /* the (values) value */ - s7_pointer unused; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */ - - s7_pointer symbol_table; /* symbol table */ - s7_pointer rootlet, shadow_rootlet; /* rootlet */ - s7_int rootlet_entries; - s7_pointer unlet; /* original bindings of predefined functions */ - - s7_pointer input_port; /* current-input-port */ - s7_pointer *input_port_stack; /* input port stack (load and read internally) */ - uint32_t input_port_stack_size, input_port_stack_loc; - - s7_pointer output_port; /* current-output-port */ - s7_pointer error_port; /* current-error-port */ - s7_pointer owlet; /* owlet */ - s7_pointer error_type, error_data, error_code, error_line, error_file, error_position; /* owlet slots */ - s7_pointer standard_input, standard_output, standard_error; - - s7_pointer sharp_readers; /* the binding pair for the global *#readers* list */ - s7_pointer load_hook; /* *load-hook* hook object */ - s7_pointer autoload_hook; /* *autoload-hook* hook object */ - s7_pointer unbound_variable_hook; /* *unbound-variable-hook* hook object */ - s7_pointer missing_close_paren_hook, rootlet_redefinition_hook; - s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */ - bool gc_off, gc_in_progress; /* gc_off: if true, the GC won't run */ - uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class, subtract_class, num_eq_class; - int32_t format_column, error_argnum; - uint64_t capture_let_counter; - bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, muffle_warnings; - bool got_tc, got_rec, not_tc; - s7_int rec_tc_args, continuation_counter; - int64_t let_number; - unsigned char number_separator; - s7_double default_rationalize_error, equivalent_float_epsilon, hash_table_float_epsilon; - s7_int default_hash_table_length, initial_string_port_length, print_length, objstr_max_len, history_size, true_history_size, output_port_data_size; - s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_format_length, max_port_data_size, rec_loc, rec_len; - s7_pointer stacktrace_defaults; - - s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p; - s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2; - s7_pointer *rec_els; - s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f, rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_fn; - s7_int (*rec_fi1)(opt_info *o); - s7_int (*rec_fi2)(opt_info *o); - s7_int (*rec_fi3)(opt_info *o); - s7_int (*rec_fi4)(opt_info *o); - s7_int (*rec_fi5)(opt_info *o); - s7_int (*rec_fi6)(opt_info *o); - bool (*rec_fb1)(opt_info *o); - bool (*rec_fb2)(opt_info *o); - - opt_info *rec_test_o, *rec_result_o, *rec_a1_o, *rec_a2_o, *rec_a3_o, *rec_a4_o, *rec_a5_o, *rec_a6_o; - s7_i_ii_t rec_i_ii_f; - s7_d_dd_t rec_d_dd_f; - s7_pointer rec_val1, rec_val2; - - int32_t float_format_precision; - vdims_t *wrap_only; - - char *typnam; - int32_t typnam_len, print_width; - s7_pointer *singletons; - block_t *unentry; /* hash-table lookup failure indicator */ - - #define INITIAL_FILE_NAMES_SIZE 8 - s7_pointer *file_names; - int32_t file_names_size, file_names_top; - - #define INITIAL_STRBUF_SIZE 1024 - s7_int strbuf_size; - char *strbuf; - - char *read_line_buf; - s7_int read_line_buf_size; - - s7_pointer w, x, y, z; - s7_pointer temp1, temp2, temp3, temp4, temp5, temp7, temp8, temp9, temp10; - s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, t4_1, u1_1; - s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, elist_6, elist_7; - s7_pointer plist_1, plist_2, plist_2_2, plist_3, qlist_2, qlist_3, clist_1, clist_2, dlist_1, mlist_1, mlist_2; /* dlist|clist and ulist can't overlap */ - - Jmp_Buf *goto_start; - bool longjmp_ok; - int32_t setjmp_loc; - - void (*begin_hook)(s7_scheme *sc, bool *val); - opcode_t begin_op; - - bool debug_or_profile, profiling_gensyms; - s7_int current_line, s7_call_line, debug, profile, profile_position; - s7_pointer profile_prefix; - profile_data_t *profile_data; - const char *current_file, *s7_call_file, *s7_call_name; - - shared_info_t *circle_info; - format_data_t **fdats; - int32_t num_fdats, safety; - gc_list_t *strings, *vectors, *input_ports, *output_ports, *input_string_ports, *continuations, *c_objects, *hash_tables; - gc_list_t *gensyms, *undefineds, *multivectors, *weak_refs, *weak_hash_iterators, *opt1_funcs; -#if (WITH_GMP) - gc_list_t *big_integers, *big_ratios, *big_reals, *big_complexes, *big_random_states; - mpz_t mpz_1, mpz_2, mpz_3, mpz_4; - mpq_t mpq_1, mpq_2, mpq_3; - mpfr_t mpfr_1, mpfr_2, mpfr_3; - mpc_t mpc_1, mpc_2; - rat_locals_t *ratloc; - bigint *bigints; - bigrat *bigrats; - bigflt *bigflts; - bigcmp *bigcmps; -#endif - s7_pointer *setters; - s7_int setters_size, setters_loc; - s7_pointer *tree_pointers; - int32_t tree_pointers_size, tree_pointers_top, semipermanent_cells, num_to_str_size; - s7_pointer format_ports; - uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k; - s7_cell *alloc_pointer_cells; - c_proc_t *alloc_function_cells; - uint32_t alloc_big_pointer_k; - s7_big_cell *alloc_big_pointer_cells; - s7_pointer string_wrappers, integer_wrappers, real_wrappers; - uint8_t *alloc_symbol_cells; - char *num_to_str; - - block_t *block_lists[NUM_BLOCK_LISTS]; - size_t alloc_string_k; - char *alloc_string_cells; - - c_object_t **c_object_types; - int32_t c_object_types_size, num_c_object_types; - s7_pointer type_to_typers[NUM_TYPES]; - - uint32_t syms_tag, syms_tag2; - int32_t bignum_precision; - s7_int baffle_ctr, map_call_ctr; - s7_pointer default_random_state; - - s7_pointer sort_body, sort_begin, sort_v1, sort_v2; - opcode_t sort_op; - s7_int sort_body_len; - s7_b_7pp_t sort_f; - opt_info *sort_o; - bool (*sort_fb)(opt_info *o); - - #define INT_TO_STR_SIZE 32 - char int_to_str1[INT_TO_STR_SIZE], int_to_str2[INT_TO_STR_SIZE], int_to_str3[INT_TO_STR_SIZE], int_to_str4[INT_TO_STR_SIZE], int_to_str5[INT_TO_STR_SIZE]; - - s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, angle_symbol, append_symbol, apply_symbol, apply_values_symbol, arity_symbol, - ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, assq_symbol, assv_symbol, atan_symbol, atanh_symbol, autoload_symbol, autoloader_symbol, - bacro_symbol, bacro_star_symbol, bignum_symbol, byte_vector_symbol, byte_vector_ref_symbol, byte_vector_set_symbol, byte_vector_to_string_symbol, - c_pointer_symbol, c_pointer_info_symbol, c_pointer_to_list_symbol, c_pointer_type_symbol, c_pointer_weak1_symbol, c_pointer_weak2_symbol, - caaaar_symbol, caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, caadr_symbol, - caar_symbol, cadaar_symbol, cadadr_symbol, cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, cadr_symbol, - call_cc_symbol, call_with_current_continuation_symbol, call_with_exit_symbol, call_with_input_file_symbol, - call_with_input_string_symbol, call_with_output_file_symbol, call_with_output_string_symbol, car_symbol, - catch_symbol, cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, cdaddr_symbol, cdadr_symbol, cdar_symbol, - cddaar_symbol, cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, cdddr_symbol, cddr_symbol, cdr_symbol, - ceiling_symbol, char_downcase_symbol, char_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol, - char_position_symbol, char_to_integer_symbol, char_upcase_symbol, cload_directory_symbol, close_input_port_symbol, - close_output_port_symbol, complex_symbol, cons_symbol, copy_symbol, cos_symbol, cosh_symbol, coverlet_symbol, - curlet_symbol, current_error_port_symbol, current_input_port_symbol, current_output_port_symbol, cutlet_symbol, cyclic_sequences_symbol, - denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, documentation_symbol, dynamic_wind_symbol, dynamic_unwind_symbol, - num_eq_symbol, error_symbol, eval_string_symbol, eval_symbol, exact_to_inexact_symbol, exit_symbol, exp_symbol, expt_symbol, - features_symbol, file__symbol, fill_symbol, float_vector_ref_symbol, float_vector_set_symbol, float_vector_symbol, floor_symbol, - flush_output_port_symbol, for_each_symbol, format_symbol, funclet_symbol, _function__symbol, - gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol, - hash_table_entries_symbol, hash_table_key_typer_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol, - hash_table_value_typer_symbol, help_symbol, - imag_part_symbol, immutable_symbol, inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, int_vector_set_symbol, int_vector_symbol, - integer_decode_float_symbol, integer_to_char_symbol, - is_aritable_symbol, is_bignum_symbol, is_boolean_symbol, is_byte_symbol, is_byte_vector_symbol, - is_c_object_symbol, c_object_type_symbol, is_c_pointer_symbol, is_char_alphabetic_symbol, is_char_lower_case_symbol, is_char_numeric_symbol, - is_char_symbol, is_char_upper_case_symbol, is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol, - is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, is_eof_object_symbol, is_eq_symbol, is_equal_symbol, - is_eqv_symbol, is_even_symbol, is_exact_symbol, is_float_vector_symbol, is_funclet_symbol, - is_gensym_symbol, is_goto_symbol, is_hash_table_symbol, is_immutable_symbol, - is_inexact_symbol, is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, is_integer_symbol, is_iterator_symbol, - is_keyword_symbol, is_let_symbol, is_list_symbol, is_macro_symbol, is_equivalent_symbol, is_nan_symbol, is_negative_symbol, - is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, is_output_port_symbol, is_pair_symbol, - is_port_closed_symbol, is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, is_provided_symbol, - is_random_state_symbol, is_rational_symbol, is_real_symbol, is_sequence_symbol, is_string_symbol, is_subvector_symbol, - is_symbol_symbol, is_syntax_symbol, is_vector_symbol, is_weak_hash_table_symbol, is_zero_symbol, - is_float_symbol, is_integer_or_real_at_end_symbol, is_integer_or_any_at_end_symbol, is_unspecified_symbol, is_undefined_symbol, - iterate_symbol, iterator_is_at_end_symbol, iterator_sequence_symbol, - keyword_to_symbol_symbol, - lcm_symbol, length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, let_set_fallback_symbol, - let_set_symbol, let_temporarily_symbol, libraries_symbol, list_ref_symbol, list_set_symbol, list_symbol, list_tail_symbol, list_values_symbol, - load_path_symbol, load_symbol, log_symbol, logand_symbol, logbit_symbol, logior_symbol, lognot_symbol, logxor_symbol, lt_symbol, - macro_symbol, macro_star_symbol, magnitude_symbol, make_byte_vector_symbol, make_float_vector_symbol, make_hash_table_symbol, - make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_symbol, string_to_keyword_symbol, make_list_symbol, make_string_symbol, - make_vector_symbol, map_symbol, max_symbol, member_symbol, memq_symbol, memv_symbol, min_symbol, modulo_symbol, multiply_symbol, - name_symbol, nan_symbol, nan_payload_symbol, newline_symbol, not_symbol, number_to_string_symbol, numerator_symbol, - object_to_string_symbol, object_to_let_symbol, open_input_file_symbol, open_input_function_symbol, open_input_string_symbol, - open_output_file_symbol, open_output_function_symbol, open_output_string_symbol, openlet_symbol, outlet_symbol, owlet_symbol, - pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol, - port_file_symbol, port_position_symbol, procedure_source_symbol, provide_symbol, - qq_append_symbol, quotient_symbol, - random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol, - read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, real_part_symbol, remainder_symbol, - require_symbol, reverse_symbol, reverseb_symbol, rootlet_symbol, round_symbol, - setter_symbol, set_car_symbol, set_cdr_symbol, - set_current_error_port_symbol, set_current_input_port_symbol, set_current_output_port_symbol, - signature_symbol, sin_symbol, sinh_symbol, sort_symbol, sqrt_symbol, - stacktrace_symbol, string_append_symbol, string_copy_symbol, string_downcase_symbol, string_eq_symbol, string_fill_symbol, - string_geq_symbol, string_gt_symbol, string_leq_symbol, string_lt_symbol, string_position_symbol, string_ref_symbol, - string_set_symbol, string_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol, - sublet_symbol, substring_symbol, subtract_symbol, subvector_symbol, subvector_position_symbol, subvector_vector_symbol, - symbol_symbol, symbol_to_dynamic_value_symbol, - symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol, - tan_symbol, tanh_symbol, throw_symbol, string_to_byte_vector_symbol, - tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, type_of_symbol, - unlet_symbol, - values_symbol, varlet_symbol, vector_append_symbol, vector_dimension_symbol, vector_dimensions_symbol, vector_fill_symbol, - vector_rank_symbol, vector_ref_symbol, vector_set_symbol, vector_symbol, vector_typer_symbol, - weak_hash_table_symbol, with_input_from_file_symbol, with_input_from_string_symbol, with_output_to_file_symbol, with_output_to_string_symbol, - write_byte_symbol, write_char_symbol, write_string_symbol, write_symbol, - local_documentation_symbol, local_signature_symbol, local_setter_symbol, local_iterator_symbol; - s7_pointer hash_code_symbol, dummy_equal_hash_table; -#if (!WITH_PURE_S7) - s7_pointer is_char_ready_symbol, char_ci_leq_symbol, char_ci_lt_symbol, char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol, - let_to_list_symbol, integer_length_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_ci_eq_symbol, - string_ci_geq_symbol, string_ci_gt_symbol, string_to_list_symbol, vector_to_list_symbol, string_length_symbol, - list_to_string_symbol, list_to_vector_symbol, vector_length_symbol; -#endif - - /* syntax symbols et al */ - s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, quasiquote_symbol, unquote_symbol, macroexpand_symbol, - define_expansion_symbol, define_expansion_star_symbol, with_let_symbol, if_symbol, autoload_error_symbol, - when_symbol, unless_symbol, begin_symbol, cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol, number_to_real_symbol, - define_symbol, define_star_symbol, define_constant_symbol, with_baffle_symbol, define_macro_symbol, no_setter_symbol, - define_macro_star_symbol, define_bacro_symbol, define_bacro_star_symbol, letrec_symbol, letrec_star_symbol, let_star_symbol, - rest_keyword, allow_other_keys_keyword, readable_keyword, display_keyword, write_keyword, value_symbol, type_symbol, - baffled_symbol, set_symbol, body_symbol, class_name_symbol, feed_to_symbol, format_error_symbol, immutable_error_symbol, - wrong_number_of_args_symbol, read_error_symbol, string_read_error_symbol, syntax_error_symbol, division_by_zero_symbol, bad_result_symbol, - io_error_symbol, invalid_escape_function_symbol, wrong_type_arg_symbol, out_of_range_symbol, out_of_memory_symbol, - missing_method_symbol, unbound_variable_symbol, if_keyword, symbol_table_symbol, profile_in_symbol, trace_in_symbol; - - /* signatures of sequences used as applicable objects: ("hi" 1) */ - s7_pointer string_signature, vector_signature, float_vector_signature, int_vector_signature, byte_vector_signature, - c_object_signature, let_signature, hash_table_signature, pair_signature; - /* common signatures */ - s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_e, pcl_f, pcl_i, pcl_n, pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl, pl_nn; - - /* optimizer s7_functions */ - s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2, subtract_3, subtract_x1, subtract_2f, subtract_f2, simple_char_eq, - char_equal_2, char_greater_2, char_less_2, char_position_csi, string_equal_2, substring_uncopied, display_2, display_f, - string_greater_2, string_less_2, symbol_to_string_uncopied, get_output_string_uncopied, string_equal_2c, string_c1, string_append_2, - vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1, dynamic_wind_unchecked, dynamic_wind_body, dynamic_wind_init, append_2, - fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, vector_2, vector_3, - list_0, list_1, list_2, list_3, list_4, list_set_i, hash_table_ref_2, hash_table_2, list_ref_at_0, list_ref_at_1, list_ref_at_2, - format_f, format_no_column, format_just_control_string, format_as_objstr, values_uncopied, int_log2, - memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, simple_inlet, sublet_curlet, profile_out, simple_list_values, - lint_let_ref, lint_let_set, geq_2, add_i_random, is_defined_in_rootlet; - - s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2, max_2, min_2, max_3, min_3, - num_eq_2, num_eq_xi, num_eq_ix, less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf, greater_2, - leq_xi, leq_2, leq_ixx, geq_xi, geq_xf, random_i, random_f, random_1, - mul_2_ff, mul_2_ii, mul_2_if, mul_2_fi, mul_2_xi, mul_2_ix, mul_2_fx, mul_2_xf, - add_2_ff, add_2_ii, add_2_if, add_2_fi, add_2_xi, add_2_ix, add_2_fx, add_2_xf; - s7_pointer seed_symbol, carry_symbol; - - /* object->let symbols */ - s7_pointer active_symbol, goto_symbol, data_symbol, weak_symbol, dimensions_symbol, info_symbol, c_type_symbol, source_symbol, c_object_ref_symbol, - at_end_symbol, sequence_symbol, position_symbol, entries_symbol, function_symbol, open_symbol, alias_symbol, port_type_symbol, - file_symbol, file_info_symbol, line_symbol, c_object_let_symbol, class_symbol, current_value_symbol, closed_symbol, - mutable_symbol, size_symbol, original_vector_symbol, pointer_symbol; - -#if WITH_SYSTEM_EXTRAS - s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, getenv_symbol, system_symbol, directory_to_list_symbol, file_mtime_symbol; -#endif - s7_pointer open_input_function_choices[S7_NUM_READ_CHOICES]; - s7_pointer closed_input_function, closed_output_function; - s7_pointer vector_set_function, string_set_function, list_set_function, hash_table_set_function, let_set_function, c_object_set_function, last_function; - s7_pointer wrong_type_arg_info, out_of_range_info, sole_arg_wrong_type_info, sole_arg_out_of_range_info; - - #define NUM_SAFE_PRELISTS 8 - #define NUM_SAFE_LISTS 64 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test */ - s7_pointer safe_lists[NUM_SAFE_LISTS]; - int32_t current_safe_list; - - s7_pointer autoload_table, s7_starlet, s7_starlet_symbol, let_temp_hook; - const char ***autoload_names; - s7_int *autoload_names_sizes; - bool **autoloaded_already; - s7_int autoload_names_loc, autoload_names_top; - int32_t format_depth; - bool undefined_identifier_warnings, undefined_constant_warnings, stop_at_error; - - opt_funcs_t *alloc_opt_func_cells; - int32_t alloc_opt_func_k; - - int32_t pc; - #define OPTS_SIZE 256 /* pqw-vox needs 178 */ - opt_info *opts[OPTS_SIZE + 1]; /* this form is a lot faster than opt_info**! */ - - #define INITIAL_SAVED_POINTERS_SIZE 256 - void **saved_pointers; - s7_int saved_pointers_loc, saved_pointers_size; - - s7_pointer type_names[NUM_TYPES]; - -#if S7_DEBUGGING - int32_t *tc_rec_calls; - int32_t last_gc_line; - bool printing_gc_info; -#endif -}; - -#if S7_DEBUGGING - static void gdb_break(void) {}; -#endif -#if S7_DEBUGGING || POINTER_32 || WITH_WARNINGS -static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit), but also used if S7_DEBUGGING unfortunately */ -#endif - -static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info); - -#if POINTER_32 -static void *Malloc(size_t bytes) -{ - void *p = malloc(bytes); - if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); - return(p); -} - -static void *Calloc(size_t nmemb, size_t size) -{ - void *p = calloc(nmemb, size); - if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); - return(p); -} - -static void *Realloc(void *ptr, size_t size) -{ - void *p = realloc(ptr, size); - if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); - return(p); -} -#else -#define Malloc malloc -#define Calloc calloc -#define Realloc realloc -#endif - - -/* -------------------------------- mallocate -------------------------------- */ -static void add_saved_pointer(s7_scheme *sc, void *p) -{ - if (sc->saved_pointers_loc == sc->saved_pointers_size) - { - sc->saved_pointers_size *= 2; - sc->saved_pointers = (void **)Realloc(sc->saved_pointers, sc->saved_pointers_size * sizeof(void *)); - } - sc->saved_pointers[sc->saved_pointers_loc++] = p; -} - -static const int32_t intlen_bits[256] = - {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8}; - -static void memclr(void *s, size_t n) -{ - uint8_t *s2; -#if S7_ALIGNED - s2 = (uint8_t *)s; -#else -#if (defined(__x86_64__) || defined(__i386__)) - if (n >= 8) - { - int64_t *s1 = (int64_t *)s; - size_t n8 = n >> 3; - do {*s1++ = 0;} while (--n8 > 0); /* LOOP_4 here is slower */ - n &= 7; - s2 = (uint8_t *)s1; - } - else s2 = (uint8_t *)s; -#else - s2 = (uint8_t *)s; -#endif -#endif - while (n > 0) - { - *s2++ = 0; - n--; - } -} - -#define LOOP_4(Code) do {Code; Code; Code; Code;} while (0) -#define LOOP_8(Code) do {Code; Code; Code; Code; Code; Code; Code; Code;} while (0) -#define STEP_8(Var) (((Var) & 0x7) == 0) -#define STEP_64(Var) (((Var) & 0x3f) == 0) - -#if POINTER_32 -#define memclr64 memclr -#else -static Vectorized void memclr64(void *p, size_t bytes) -{ - size_t n = bytes >> 3; - int64_t *vals = (int64_t *)p; - for (size_t i = 0; i < n; ) - LOOP_8(vals[i++] = 0); -} -#endif - -static void init_block_lists(s7_scheme *sc) -{ - for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++) - sc->block_lists[i] = NULL; -} - -static inline void liberate(s7_scheme *sc, block_t *p) -{ - if (block_index(p) != TOP_BLOCK_LIST) - { - block_next(p) = (struct block_t *)sc->block_lists[block_index(p)]; - sc->block_lists[block_index(p)] = p; - } - else - { - if (block_data(p)) - { - free(block_data(p)); - block_data(p) = NULL; - } - block_next(p) = (struct block_t *)sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = p; - } -} - -static inline void liberate_block(s7_scheme *sc, block_t *p) -{ - block_next(p) = (struct block_t *)sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST=0 */ - sc->block_lists[BLOCK_LIST] = p; -} - -static void fill_block_list(s7_scheme *sc) -{ - #define BLOCK_MALLOC_SIZE 256 - block_t *b = (block_t *)Malloc(BLOCK_MALLOC_SIZE * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */ - add_saved_pointer(sc, b); - sc->block_lists[BLOCK_LIST] = b; - for (int32_t i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++) - block_next(b) = (block_t *)(b + 1); - block_next(b) = NULL; -} - -static inline block_t *mallocate_block(s7_scheme *sc) -{ - block_t *p; - if (!sc->block_lists[BLOCK_LIST]) - fill_block_list(sc); /* this is much faster than allocating blocks as needed */ - p = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = (block_t *)(block_next(p)); - block_set_index(p, BLOCK_LIST); - return(p); -} - -static inline char *permalloc(s7_scheme *sc, size_t len) -{ - #define ALLOC_STRING_SIZE (65536 * 8) /* going up to 16 made no difference in timings */ - #define ALLOC_MAX_STRING (512 * 8) /* was 256 -- sets max size of block space lost at the end, but smaller = more direct malloc calls */ - char *result; - size_t next_k; - - len = (len + 7) & (~7); /* 8-byte aligned -- more than half the time, len is already 8-byte aligned */ - next_k = sc->alloc_string_k + len; - if (next_k > ALLOC_STRING_SIZE) - { - if (len >= ALLOC_MAX_STRING) - { - result = (char *)Malloc(len); - add_saved_pointer(sc, result); - return(result); - } - sc->alloc_string_cells = (char *)Malloc(ALLOC_STRING_SIZE); /* get a new block */ - add_saved_pointer(sc, sc->alloc_string_cells); - sc->alloc_string_k = 0; - next_k = len; - } - result = &(sc->alloc_string_cells[sc->alloc_string_k]); - sc->alloc_string_k = next_k; - return(result); -} - -static Inline block_t *inline_mallocate(s7_scheme *sc, size_t bytes) -{ - block_t *p; - if (bytes > 0) - { - int32_t index; - if (bytes <= 8) /* presetting a version of intlen_bits with 3's gave only a small speed-up */ - index = 3; - else - { - if (bytes <= 256) - index = intlen_bits[bytes - 1]; - else index = (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) : TOP_BLOCK_LIST; /* expansion to (1 << 17) made no difference */ - } - p = sc->block_lists[index]; - if (p) - sc->block_lists[index] = (block_t *)block_next(p); - else - { - if (index < (TOP_BLOCK_LIST - 1)) - { - p = sc->block_lists[index + 1]; - if (p) - { - /* we are "borrowing" a block from the next larger bin -- this saves space but costs a bit of time. - * in a tauto run repeating every call 1000 times, the old form ends up at 129M and 31.1 secs, - * whereas the borrowing form ends at 116M and 31.5 secs, but most of my tests show a slight - * speed-up, probably because grabbing a block here is faster than making a new one. - * Worst case is tlet: 8 slower in callgrind. - */ - sc->block_lists[index + 1] = (block_t *)block_next(p); - block_set_size(p, bytes); - return(p); - }} - p = mallocate_block(sc); - block_data(p) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); - block_set_index(p, index); - }} - else p = mallocate_block(sc); - block_set_size(p, bytes); - return(p); -} - -static block_t *mallocate(s7_scheme *sc, size_t bytes) {return(inline_mallocate(sc, bytes));} - -static block_t *callocate(s7_scheme *sc, size_t bytes) -{ - block_t *p = inline_mallocate(sc, bytes); - if ((block_data(p)) && (block_index(p) != BLOCK_LIST)) - { - if ((bytes & (~0x3f)) > 0) - memclr64((void *)block_data(p), bytes & (~0x3f)); - if ((bytes & 0x3f) > 0) - memclr((void *)((uint8_t *)block_data(p) + (bytes & (~0x3f))), bytes & 0x3f); - } - return(p); -} - -static block_t *reallocate(s7_scheme *sc, block_t *op, size_t bytes) -{ - block_t *np = inline_mallocate(sc, bytes); - if (block_data(op)) /* presumably block_data(np) is not null */ - memcpy((uint8_t *)(block_data(np)), (uint8_t *)(block_data(op)), block_size(op)); - liberate(sc, op); - return(np); -} - -/* we can't export mallocate et al without also exporting block_t or accessors for it - * that is, the block_t* pointer returned can't be used as if it were the void* pointer returned by malloc - * ideally we'd have a way to release excessive mallocate bins, but they are permalloc'd individually - */ - - -/* -------------------------------------------------------------------------------- */ -typedef enum {P_DISPLAY, P_WRITE, P_READABLE, P_KEY, P_CODE} use_write_t; - -static s7_pointer too_many_arguments_string, not_enough_arguments_string, cant_bind_immutable_string, - a_boolean_string, a_byte_vector_string, a_format_port_string, a_let_string, a_list_string, a_non_constant_symbol_string, - a_non_negative_integer_string, a_normal_procedure_string, a_normal_real_string, a_number_string, a_procedure_string, a_procedure_or_a_macro_string, - a_proper_list_string, a_random_state_object_string, a_rational_string, a_sequence_string, a_symbol_string, a_thunk_string, a_valid_radix_string, - an_association_list_string, an_eq_func_string, an_input_file_port_string, an_input_port_string, an_input_string_port_string, an_open_input_port_string, - an_open_output_port_string, an_output_port_or_f_string, an_output_file_port_string, an_output_port_string, an_output_string_port_string, - an_unsigned_byte_string, caaar_a_list_string, caadr_a_list_string, caar_a_list_string, cadar_a_list_string, caddr_a_list_string, - cadr_a_list_string, car_a_list_string, cdaar_a_list_string, cdadr_a_list_string, cdar_a_list_string, cddar_a_list_string, - cdddr_a_list_string, cddr_a_list_string, cdr_a_list_string, immutable_error_string, it_is_infinite_string, it_is_nan_string, - it_is_negative_string, it_is_too_large_string, it_is_too_small_string, parameter_set_twice_string, result_is_too_large_string, - something_applicable_string, too_many_indices_string, intermediate_too_large_string, - format_string_1, format_string_2, format_string_3, format_string_4, keyword_value_missing_string; - -static bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES], t_big_number_p[NUM_TYPES]; -static bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES]; -static bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], t_has_closure_let[NUM_TYPES]; -static bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES], t_vector_p[NUM_TYPES]; -static bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], t_macro_setter_p[NUM_TYPES]; -#if S7_DEBUGGING -static bool t_freeze_p[NUM_TYPES]; /* free_cell sanity check */ -static bool t_ext_p[NUM_TYPES]; /* make sure internal types don't leak out */ -#endif - -static void init_types(void) -{ - for (int32_t i = 0; i < NUM_TYPES; i++) - { - t_number_p[i] = false; - t_small_real_p[i] = false; - t_real_p[i] = false; - t_rational_p[i] = false; - t_simple_p[i] = false; - t_structure_p[i] = false; - t_any_macro_p[i] = false; - t_any_closure_p[i] = false; - t_has_closure_let[i] = false; - t_sequence_p[i] = false; - t_mappable_p[i] = false; - t_vector_p[i] = false; - t_applicable_p[i] = false; - t_procedure_p[i] = false; - t_macro_setter_p[i] = false; -#if S7_DEBUGGING - t_freeze_p[i] = false; - t_ext_p[i] = false; -#endif - } - t_number_p[T_INTEGER] = true; - t_number_p[T_RATIO] = true; - t_number_p[T_REAL] = true; - t_number_p[T_COMPLEX] = true; - t_number_p[T_BIG_INTEGER] = true; - t_number_p[T_BIG_RATIO] = true; - t_number_p[T_BIG_REAL] = true; - t_number_p[T_BIG_COMPLEX] = true; - - t_rational_p[T_INTEGER] = true; - t_rational_p[T_RATIO] = true; - t_rational_p[T_BIG_INTEGER] = true; - t_rational_p[T_BIG_RATIO] = true; - - t_small_real_p[T_INTEGER] = true; - t_small_real_p[T_RATIO] = true; - t_small_real_p[T_REAL] = true; - - t_real_p[T_INTEGER] = true; - t_real_p[T_RATIO] = true; - t_real_p[T_REAL] = true; - t_real_p[T_BIG_INTEGER] = true; - t_real_p[T_BIG_RATIO] = true; - t_real_p[T_BIG_REAL] = true; - - t_big_number_p[T_BIG_INTEGER] = true; - t_big_number_p[T_BIG_RATIO] = true; - t_big_number_p[T_BIG_REAL] = true; - t_big_number_p[T_BIG_COMPLEX] = true; - - t_structure_p[T_PAIR] = true; - t_structure_p[T_VECTOR] = true; - t_structure_p[T_HASH_TABLE] = true; - t_structure_p[T_SLOT] = true; - t_structure_p[T_LET] = true; - t_structure_p[T_ITERATOR] = true; - t_structure_p[T_C_POINTER] = true; - t_structure_p[T_C_OBJECT] = true; - - t_sequence_p[T_NIL] = true; - t_sequence_p[T_PAIR] = true; - t_sequence_p[T_STRING] = true; - t_sequence_p[T_VECTOR] = true; - t_sequence_p[T_INT_VECTOR] = true; - t_sequence_p[T_FLOAT_VECTOR] = true; - t_sequence_p[T_BYTE_VECTOR] = true; - t_sequence_p[T_HASH_TABLE] = true; - t_sequence_p[T_LET] = true; - t_sequence_p[T_C_OBJECT] = true; /* this assumes the object has a length method? */ - - t_mappable_p[T_PAIR] = true; - t_mappable_p[T_STRING] = true; - t_mappable_p[T_VECTOR] = true; - t_mappable_p[T_INT_VECTOR] = true; - t_mappable_p[T_FLOAT_VECTOR] = true; - t_mappable_p[T_BYTE_VECTOR] = true; - t_mappable_p[T_HASH_TABLE] = true; - t_mappable_p[T_LET] = true; - t_mappable_p[T_C_OBJECT] = true; - t_mappable_p[T_ITERATOR] = true; - t_mappable_p[T_C_MACRO] = true; - t_mappable_p[T_MACRO] = true; - t_mappable_p[T_BACRO] = true; - t_mappable_p[T_MACRO_STAR] = true; - t_mappable_p[T_BACRO_STAR] = true; - t_mappable_p[T_CLOSURE] = true; - t_mappable_p[T_CLOSURE_STAR] = true; - - t_vector_p[T_VECTOR] = true; - t_vector_p[T_INT_VECTOR] = true; - t_vector_p[T_FLOAT_VECTOR] = true; - t_vector_p[T_BYTE_VECTOR] = true; - - t_applicable_p[T_PAIR] = true; - t_applicable_p[T_STRING] = true; - t_applicable_p[T_VECTOR] = true; - t_applicable_p[T_INT_VECTOR] = true; - t_applicable_p[T_FLOAT_VECTOR] = true; - t_applicable_p[T_BYTE_VECTOR] = true; - t_applicable_p[T_HASH_TABLE] = true; - t_applicable_p[T_ITERATOR] = true; - t_applicable_p[T_LET] = true; - t_applicable_p[T_C_OBJECT] = true; - t_applicable_p[T_C_MACRO] = true; - t_applicable_p[T_MACRO] = true; - t_applicable_p[T_BACRO] = true; - t_applicable_p[T_MACRO_STAR] = true; - t_applicable_p[T_BACRO_STAR] = true; - t_applicable_p[T_SYNTAX] = true; - t_applicable_p[T_C_FUNCTION] = true; - t_applicable_p[T_C_FUNCTION_STAR] = true; - t_applicable_p[T_C_RST_NO_REQ_FUNCTION] = true; - t_applicable_p[T_CLOSURE] = true; - t_applicable_p[T_CLOSURE_STAR] = true; - t_applicable_p[T_GOTO] = true; - t_applicable_p[T_CONTINUATION] = true; - - /* t_procedure_p[T_C_OBJECT] = true; */ - t_procedure_p[T_C_FUNCTION] = true; - t_procedure_p[T_C_FUNCTION_STAR] = true; - t_procedure_p[T_C_RST_NO_REQ_FUNCTION] = true; - t_procedure_p[T_CLOSURE] = true; - t_procedure_p[T_CLOSURE_STAR] = true; - t_procedure_p[T_GOTO] = true; - t_procedure_p[T_CONTINUATION] = true; - - for (int32_t i = T_CLOSURE; i < NUM_TYPES; i++) t_macro_setter_p[i] = true; - t_macro_setter_p[T_SYMBOL] = true; /* (slot setter); apparently T_LET and T_C_OBJECT are not possible here */ - - t_any_macro_p[T_C_MACRO] = true; - t_any_macro_p[T_MACRO] = true; - t_any_macro_p[T_BACRO] = true; - t_any_macro_p[T_MACRO_STAR] = true; - t_any_macro_p[T_BACRO_STAR] = true; - - t_any_closure_p[T_CLOSURE] = true; - t_any_closure_p[T_CLOSURE_STAR] = true; - - t_has_closure_let[T_MACRO] = true; - t_has_closure_let[T_BACRO] = true; - t_has_closure_let[T_MACRO_STAR] = true; - t_has_closure_let[T_BACRO_STAR] = true; - t_has_closure_let[T_CLOSURE] = true; - t_has_closure_let[T_CLOSURE_STAR] = true; - - t_simple_p[T_NIL] = true; - /* t_simple_p[T_UNDEFINED] = true; */ /* only # itself will work with eq? */ - t_simple_p[T_EOF] = true; - t_simple_p[T_BOOLEAN] = true; - t_simple_p[T_CHARACTER] = true; - t_simple_p[T_SYMBOL] = true; - t_simple_p[T_SYNTAX] = true; - t_simple_p[T_C_MACRO] = true; - t_simple_p[T_C_FUNCTION] = true; - t_simple_p[T_C_FUNCTION_STAR] = true; - t_simple_p[T_C_RST_NO_REQ_FUNCTION] = true; - /* not completely sure about the next ones */ - /* t_simple_p[T_LET] = true; */ /* this needs let_equal in member et al, 29-Nov-22 */ - t_simple_p[T_INPUT_PORT] = true; - t_simple_p[T_OUTPUT_PORT] = true; - -#if S7_DEBUGGING - t_freeze_p[T_STRING] = true; - t_freeze_p[T_BYTE_VECTOR] = true; - t_freeze_p[T_VECTOR] = true; - t_freeze_p[T_FLOAT_VECTOR] = true; - t_freeze_p[T_INT_VECTOR] = true; - t_freeze_p[T_UNDEFINED] = true; - t_freeze_p[T_C_OBJECT] = true; - t_freeze_p[T_HASH_TABLE] = true; - t_freeze_p[T_C_FUNCTION] = true; - t_freeze_p[T_CONTINUATION] = true; - t_freeze_p[T_INPUT_PORT] = true; - t_freeze_p[T_OUTPUT_PORT] = true; -#if WITH_GMP - t_freeze_p[T_BIG_INTEGER] = true; - t_freeze_p[T_BIG_RATIO] = true; - t_freeze_p[T_BIG_REAL] = true; - t_freeze_p[T_BIG_COMPLEX] = true; - t_freeze_p[T_RANDOM_STATE] = true; -#endif - t_ext_p[T_UNUSED] = true; - t_ext_p[T_STACK] = true; - t_ext_p[T_SLOT] = true; - t_ext_p[T_DYNAMIC_WIND] = true; - t_ext_p[T_CATCH] = true; - t_ext_p[T_COUNTER] = true; -#if (!WITH_GMP) - t_ext_p[T_BIG_INTEGER] = true; - t_ext_p[T_BIG_RATIO] = true; - t_ext_p[T_BIG_REAL] = true; - t_ext_p[T_BIG_COMPLEX] = true; -#endif -#endif -} - -#if WITH_HISTORY -#define current_code(Sc) car(Sc->cur_code) -#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, T_Ext(Code));} while (0) -#define replace_current_code(Sc, Code) set_car(Sc->cur_code, T_Ext(Code)) -#define mark_current_code(Sc) do {int32_t i; s7_pointer p; for (p = Sc->cur_code, i = 0; i < Sc->history_size; i++, p = cdr(p)) gc_mark(car(p));} while (0) -#else -#define current_code(Sc) Sc->cur_code -#define set_current_code(Sc, Code) Sc->cur_code = T_Ext(Code) -#define replace_current_code(Sc, Code) Sc->cur_code = T_Ext(Code) -#define mark_current_code(Sc) gc_mark(Sc->cur_code) -#endif - -#define full_type(p) ((p)->tf.flag) -#define typesflag(p) ((p)->tf.sflag) -#define TYPE_MASK 0xff - -#if S7_DEBUGGING - static void print_gc_info(s7_scheme *sc, s7_pointer obj, int32_t line); - static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2); - static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line); - - #define unchecked_type(p) ((p)->tf.type_field) -#if WITH_GCC - #define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!cur_sc->printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __LINE__); _t_;}) -#else - #define type(p) (p)->tf.type_field -#endif - #define set_full_type(p, f) set_type_1(p, f, __func__, __LINE__) - /* these check most s7_cell field references (and many type bits) for consistency */ - #define T_App(P) check_ref11(P, __func__, __LINE__) /* applicable or #f */ - #define T_Arg(P) check_ref10(P, __func__, __LINE__) /* closure arg (list, symbol) */ - #define T_BVc(P) check_ref(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Bgf(P) check_ref(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL) - #define T_Bgi(P) check_ref(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL) - #define T_Bgr(P) check_ref(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL) - #define T_Bgz(P) check_ref(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL) - #define T_CMac(P) check_ref(P, T_C_MACRO, __func__, __LINE__, NULL, NULL) - #define T_Cat(P) check_ref(P, T_CATCH, __func__, __LINE__, NULL, NULL) - #define T_Chr(P) check_ref(P, T_CHARACTER, __func__, __LINE__, NULL, NULL) - #define T_Clo(P) check_ref5(P, __func__, __LINE__) /* has closure let */ - #define T_Cmp(P) check_ref(P, T_COMPLEX, __func__, __LINE__, NULL, NULL) - #define T_Con(P) check_ref(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation") - #define T_Ctr(P) check_ref(P, T_COUNTER, __func__, __LINE__, NULL, NULL) - #define T_Dyn(P) check_ref(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) - #define T_Eof(P) check_ref(P, T_EOF, __func__, __LINE__, "sweep", NULL) - #define T_Ext(P) check_ref19(P, __func__, __LINE__) - #define T_Fnc(P) check_ref6(P, __func__, __LINE__) /* any c_function|c_macro */ - #define T_Frc(P) check_ref2(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) - #define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) - #define T_Fvc(P) check_ref(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Got(P) check_ref(P, T_GOTO, __func__, __LINE__, NULL, NULL) - #define T_Hsh(P) check_ref(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table") - #define T_Int(P) check_ref(P, T_INTEGER, __func__, __LINE__, NULL, NULL) - #define T_Itr(P) check_ref(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") - #define T_Ivc(P) check_ref(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Key(P) check_ref18(P, __func__, __LINE__) /* keyword */ - #define T_Let(P) check_ref(P, T_LET, __func__, __LINE__, NULL, NULL) - #define T_Lid(P) check_ref16(P, __func__, __LINE__) /* let/nil */ - #define T_Lst(P) check_ref2(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) - #define T_Mac(P) check_ref17(P, __func__, __LINE__) /* a non-C macro */ - #define T_Met(P) check_ref9(P, __func__, __LINE__) /* anything that might contain a method */ - #define T_Nmv(P) check_ref15(P, __func__, __LINE__) /* not multiple-value, not free */ - #define T_Num(P) check_ref7(P, __func__, __LINE__) /* any number (not bignums) */ - #define T_Nvc(P) check_ref(P, T_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Obj(P) check_ref(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value") - #define T_Pair(P) check_ref(P, T_PAIR, __func__, __LINE__, NULL, NULL) - #define T_Pcs(P) check_ref2(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL) - #define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */ - #define T_Prc(P) check_ref14(P, __func__, __LINE__) /* any procedure (3-arg setters) or #f|#t */ - #define T_Prt(P) check_ref3(P, __func__, __LINE__) /* input|output_port */ - #define T_Ptr(P) check_ref(P, T_C_POINTER, __func__, __LINE__, NULL, NULL) - #define T_Ran(P) check_ref(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) - #define T_Rel(P) check_ref(P, T_REAL, __func__, __LINE__, NULL, NULL) - #define T_SVec(P) check_ref13(P, __func__, __LINE__) /* subvector */ - #define T_Seq(P) check_ref8(P, __func__, __LINE__) /* any sequence or structure */ - #define T_Sld(P) check_ref2(P, T_SLOT, T_UNDEFINED,__func__, __LINE__, NULL, NULL) - #define T_Sln(P) check_ref12(P, __func__, __LINE__) /* slot or nil */ - #define T_Slt(P) check_ref(P, T_SLOT, __func__, __LINE__, NULL, NULL) - #define T_Stk(P) check_ref(P, T_STACK, __func__, __LINE__, NULL, NULL) - #define T_Str(P) check_ref(P, T_STRING, __func__, __LINE__, "sweep", NULL) - #define T_Sym(P) check_ref(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table") - #define T_Syn(P) check_ref(P, T_SYNTAX, __func__, __LINE__, NULL, NULL) - #define T_Undf(P) check_ref(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) - #define T_Vec(P) check_ref4(P, __func__, __LINE__) /* any vector */ -#else - /* if not debugging, all those checks go away */ - #define T_App(P) P - #define T_Arg(P) P - #define T_BVc(P) P - #define T_Bgf(P) P - #define T_Bgi(P) P - #define T_Bgr(P) P - #define T_Bgz(P) P - #define T_CMac(P) P - #define T_Cat(P) P - #define T_Chr(P) P - #define T_Clo(P) P - #define T_Cmp(P) P - #define T_Con(P) P - #define T_Ctr(P) P - #define T_Dyn(P) P - #define T_Eof(P) P - #define T_Ext(P) P - #define T_Fnc(P) P - #define T_Frc(P) P - #define T_Fst(P) P - #define T_Fvc(P) P - #define T_Got(P) P - #define T_Hsh(P) P - #define T_Int(P) P - #define T_Itr(P) P - #define T_Ivc(P) P - #define T_Key(P) P - #define T_Let(P) P - #define T_Lid(P) P - #define T_Lst(P) P - #define T_Mac(P) P - #define T_Met(P) P - #define T_Nmv(P) P - #define T_Num(P) P - #define T_Nvc(P) P - #define T_Obj(P) P - #define T_Pair(P) P - #define T_Pcs(P) P - #define T_Pos(P) P - #define T_Prc(P) P - #define T_Prt(P) P - #define T_Ptr(P) P - #define T_Ran(P) P - #define T_Rel(P) P - #define T_SVec(P) P - #define T_Seq(P) P - #define T_Sld(P) P - #define T_Sln(P) P - #define T_Slt(P) P - #define T_Stk(P) P - #define T_Str(P) P - #define T_Sym(P) P - #define T_Syn(P) P - #define T_Undf(P) P - #define T_Vec(P) P - - #define unchecked_type(p) ((p)->tf.type_field) - #define type(p) ((p)->tf.type_field) - #define set_full_type(p, f) full_type(p) = f -#endif -#define signed_type(p) (p)->tf.signed_flag - -#define is_number(P) t_number_p[type(P)] -#define is_small_real(P) t_small_real_p[type(P)] -#define is_real(P) t_real_p[type(P)] -#define is_rational(P) t_rational_p[type(P)] -#define is_big_number(p) t_big_number_p[type(p)] -#define is_t_integer(p) (type(p) == T_INTEGER) -#define is_t_ratio(p) (type(p) == T_RATIO) -#define is_t_real(p) (type(p) == T_REAL) -#define is_t_complex(p) (type(p) == T_COMPLEX) -#define is_t_big_integer(p) (type(p) == T_BIG_INTEGER) -#define is_t_big_ratio(p) (type(p) == T_BIG_RATIO) -#define is_t_big_real(p) (type(p) == T_BIG_REAL) -#define is_t_big_complex(p) (type(p) == T_BIG_COMPLEX) - -#define is_boolean(p) (type(p) == T_BOOLEAN) - -#define is_free(p) (type(p) == T_FREE) -#define is_free_and_clear(p) (full_type(p) == T_FREE) -#define is_simple(P) t_simple_p[type(P)] /* eq? */ -#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_normal_vector(P)) || (!has_simple_elements(P)))) - -#define is_any_macro(P) t_any_macro_p[type(P)] -#define is_any_closure(P) t_any_closure_p[type(P)] -#define is_any_procedure(P) (type(P) >= T_CLOSURE) -#define has_closure_let(P) t_has_closure_let[type(P)] - -#define is_simple_sequence(P) (t_sequence_p[type(P)]) -#define is_sequence(P) ((t_sequence_p[type(P)]) || (has_methods(P))) -#define is_mutable_sequence(P) (((t_sequence_p[type(P)]) || (has_methods(P))) && (!is_immutable(P))) -#define is_mappable(P) (t_mappable_p[type(P)]) -#define is_applicable(P) (t_applicable_p[type(P)]) -/* this misses #() which is not applicable to anything, and "", and inapplicable c-objects like random-state */ -#define is_procedure(p) ((t_procedure_p[type(p)]) || ((is_c_object(p)) && (is_safe_procedure(p)))) -#define is_t_procedure(p) (t_procedure_p[type(p)]) - -/* the layout of these bits does matter in several cases -- don't shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR */ -#define TYPE_BITS 8 - -#define set_type_bit(p, b) full_type(p) |= (b) -#define clear_type_bit(p, b) full_type(p) &= (~(b)) -#define has_type_bit(p, b) ((full_type(p) & (b)) != 0) - -#define set_type0_bit(p, b) typesflag(p) |= (b) /* I don't think these type0's matter -- *_type_bit is the same speed */ -#define clear_type0_bit(p, b) typesflag(p) &= (~(b)) -#define has_type0_bit(p, b) ((typesflag(p) & (b)) != 0) - -#define set_type1_bit(p, b) (p)->tf.opts.high_flag |= (b) -#define clear_type1_bit(p, b) (p)->tf.opts.high_flag &= (~(b)) -#define has_type1_bit(p, b) (((p)->tf.opts.high_flag & (b)) != 0) - -#define T_SYNTACTIC (1 << (TYPE_BITS + 1)) -#define is_symbol_and_syntactic(p) (typesflag(T_Ext(p)) == (uint16_t)(T_SYMBOL | T_SYNTACTIC)) -#define is_syntactic_symbol(p) has_type0_bit(T_Sym(p), T_SYNTACTIC) -#define is_syntactic_pair(p) has_type0_bit(T_Pair(p), T_SYNTACTIC) -#define clear_syntactic(p) clear_type0_bit(T_Pair(p), T_SYNTACTIC) -#define set_syntactic_pair(p) full_type(T_Pair(p)) = (T_PAIR | T_SYNTACTIC | (full_type(p) & (0xffffffffffff0000 & ~T_OPTIMIZED))) /* used only in pair_set_syntax_op */ -/* this marks symbols that represent syntax objects, it should be in the second byte */ - -#define T_SIMPLE_ARG_DEFAULTS (1 << (TYPE_BITS + 2)) -#define lambda_has_simple_defaults(p) has_type0_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS) -#define lambda_set_simple_defaults(p) set_type0_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS) -/* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */ - -#define T_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS -#define list_is_in_use(p) has_type0_bit(T_Pair(p), T_LIST_IN_USE) -#define set_list_in_use(p) set_type0_bit(T_Pair(p), T_LIST_IN_USE) -#define clear_list_in_use(p) do {clear_type0_bit(T_Pair(p), T_LIST_IN_USE); sc->current_safe_list = 0;} while (0) -/* since the safe lists are not in the heap, if the list_in_use bit is off, the list won't be GC-protected even if - * it is gc_marked explicitly. This happens, for example, in copy_proper_list where we try to protect the original list - * by sc->temp5 = lst; then in the GC, gc_mark(sc->temp5); but the safe_list probably is already marked, so its contents are not protected. - */ - -#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS -#define set_closure_has_one_form(p) set_type0_bit(T_Clo(p), T_ONE_FORM) -#define T_MULTIFORM (1 << (TYPE_BITS + 0)) -#define set_closure_has_multiform(p) set_type0_bit(T_Clo(p), T_MULTIFORM) -#define T_ONE_FORM_FX_ARG (T_ONE_FORM | T_MULTIFORM) -#define set_closure_one_form_fx_arg(p) set_type0_bit(T_Clo(p), T_ONE_FORM_FX_ARG) -/* can't use T_HAS_FX here because closure_is_ok wants to examine typesflag */ - -#define T_OPTIMIZED (1 << (TYPE_BITS + 3)) -#define set_optimized(p) set_type0_bit(T_Pair(p), T_OPTIMIZED) -#define clear_optimized(p) clear_type0_bit(T_Pair(p), T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN) -#define is_optimized(p) (typesflag(T_Ext(p)) == (uint16_t)(T_PAIR | T_OPTIMIZED)) -/* optimizer flag for an expression that has optimization info, it should be in the second byte */ - -#define T_SCOPE_SAFE T_OPTIMIZED -#define is_scope_safe(p) has_type0_bit(T_Fnc(p), T_SCOPE_SAFE) -#define set_scope_safe(p) set_type0_bit(T_Fnc(p), T_SCOPE_SAFE) - -#define T_SAFE_CLOSURE (1 << (TYPE_BITS + 4)) -#define is_safe_closure(p) has_type0_bit(T_Clo(p), T_SAFE_CLOSURE) -#define set_safe_closure(p) set_type0_bit(T_Clo(p), T_SAFE_CLOSURE) -#define is_safe_closure_body(p) has_type0_bit(T_Pair(p), T_SAFE_CLOSURE) -#define set_safe_closure_body(p) set_type0_bit(T_Pair(p), T_SAFE_CLOSURE) -#define clear_safe_closure_body(p) clear_type0_bit(T_Pair(p), T_SAFE_CLOSURE) - -/* optimizer flag for a closure body that is completely simple (every expression is safe) - * set_safe_closure happens in define_funchcecked letrec_setup_closures etc, clear only in procedure_source, bits only here - * this has to be separate from T_SAFE_PROCEDURE, and should be in the second byte (closure_is_ok_1 checks typesflag). - * define -> optimize_lambda sets safe -> define_funchecked -> make_funclet for the let - * similarly, named let -> optimize_lambda, then let creates the let if safe - * thereafter, optimizer uses OP_SAFE_CLOSURE* which calls update_let* - */ - -#define T_DONT_EVAL_ARGS (1 << (TYPE_BITS + 5)) -#define dont_eval_args(p) has_type0_bit(T_Ext(p), T_DONT_EVAL_ARGS) -/* this marks things that don't evaluate their arguments */ - -#define T_EXPANSION (1 << (TYPE_BITS + 6)) -#define is_expansion(p) has_type0_bit(T_Pos(p), T_EXPANSION) -#define clear_expansion(p) clear_type0_bit(T_Sym(p), T_EXPANSION) -/* this marks the symbol and its run-time macro value, distinguishing it from an ordinary macro */ - -#define T_MULTIPLE_VALUE (1 << (TYPE_BITS + 7)) -#define is_multiple_value(p) has_type0_bit(T_Pos(p), T_MULTIPLE_VALUE) /* not T_Ext -- can be a slot */ -#if S7_DEBUGGING -#define set_multiple_value(p) do {if (!in_heap(p)) {fprintf(stderr, "%s[%d]: mv\n", __func__, __LINE__); abort();} set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE);} while (0) -#else -#define set_multiple_value(p) set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE) -#endif -#define clear_multiple_value(p) clear_type0_bit(T_Pair(p), T_MULTIPLE_VALUE) -#define multiple_value(p) p -/* this bit marks a list (from "values") that is waiting for a chance to be spliced into its caller's argument list */ - -#define T_MATCHED T_MULTIPLE_VALUE -#define is_matched_pair(p) has_type0_bit(T_Pair(p), T_MATCHED) -#define clear_match_pair(p) clear_type0_bit(T_Pair(p), T_MATCHED) -#define set_match_pair(p) set_type0_bit(T_Pair(p), T_MATCHED) -#define set_match_symbol(p) set_type0_bit(T_Sym(p), T_MATCHED) -#define is_matched_symbol(p) has_type0_bit(T_Sym(p), T_MATCHED) -#define clear_match_symbol(p) clear_type0_bit(T_Sym(p), T_MATCHED) - -#define T_GLOBAL (1 << (TYPE_BITS + 8)) -#define T_LOCAL (1 << (TYPE_BITS + 12)) -#define is_global(p) has_type_bit(T_Sym(p), T_GLOBAL) -#define set_global(p) do {if ((full_type(T_Sym(p)) & T_LOCAL) == 0) full_type(p) |= T_GLOBAL;} while (0) -/* T_LOCAL marks a symbol that has been used locally */ -/* T_GLOBAL marks something defined (bound) at the top-level, and never defined locally */ - -#define REPORT_ROOTLET_REDEF 0 -#if REPORT_ROOTLET_REDEF - /* to find who is stomping on our symbols: */ - static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line); - #define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__) -#else - #define set_local(p) full_type(T_Sym(p)) = ((full_type(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)) -#endif - -#define T_LOW_COUNT T_LOCAL -#define has_low_count(p) has_type_bit(T_Pair(p), T_LOW_COUNT) -#define set_has_low_count(p) set_type_bit(T_Pair(p), T_LOW_COUNT) - -#define T_TC T_LOCAL -#define has_tc(p) has_type_bit(T_Pair(p), T_TC) -#define set_has_tc(p) set_type_bit(T_Pair(p), T_TC) - -#define T_UNSAFE_DO T_GLOBAL -#define is_unsafe_do(p) has_type_bit(T_Pair(p), T_UNSAFE_DO) -#define set_unsafe_do(p) set_type_bit(T_Pair(p), T_UNSAFE_DO) -/* marks do-loops that resist optimization */ - -#define T_DOX_SLOT1 T_GLOBAL -#define has_dox_slot1(p) has_type_bit(T_Let(p), T_DOX_SLOT1) -#define set_has_dox_slot1(p) set_type_bit(T_Let(p), T_DOX_SLOT1) -/* marks a let that includes the dox_slot1 */ - -#define T_COLLECTED (1 << (TYPE_BITS + 9)) -#define is_collected(p) has_type_bit(T_Seq(p), T_COLLECTED) -#define is_collected_unchecked(p) has_type_bit(p, T_COLLECTED) -#define set_collected(p) set_type_bit(T_Seq(p), T_COLLECTED) -/* #define clear_collected(p) clear_type_bit(T_Seq(p), T_COLLECTED) */ -/* this is a transient flag used by the printer to catch cycles. It affects only objects that have structure. - * We can't use a low bit (bit 7 for example), because collect_shared_info inspects the object's type. - */ - -#define T_LOCATION (1 << (TYPE_BITS + 10)) -#define has_location(p) has_type_bit(T_Pair(p), T_LOCATION) -#define set_has_location(p) set_type_bit(T_Pair(p), T_LOCATION) -/* pair in question has line/file/position info added during read, or the environment has function placement info - * this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it. - */ - -#define T_LOADER_PORT T_LOCATION -#define is_loader_port(p) has_type_bit(T_Prt(p), T_LOADER_PORT) -#define set_loader_port(p) set_type_bit(T_Prt(p), T_LOADER_PORT) -#define clear_loader_port(p) clear_type_bit(T_Prt(p), T_LOADER_PORT) -/* this bit marks a port used by the loader so that random load-time reads do not screw up the load process */ - -#define T_HAS_SETTER T_LOCATION -#define slot_has_setter(p) has_type_bit(T_Slt(p), T_HAS_SETTER) -#define slot_set_has_setter(p) set_type_bit(T_Slt(p), T_HAS_SETTER) -/* marks a slot that has a setter or symbol that might have a setter */ - -#define T_WITH_LET_LET T_LOCATION -#define is_with_let_let(p) has_type_bit(T_Let(p), T_WITH_LET_LET) -#define set_with_let_let(p) set_type_bit(T_Let(p), T_WITH_LET_LET) -/* marks a let that is the argument to with-let */ - -#define T_SIMPLE_DEFAULTS T_LOCATION -#define c_func_has_simple_defaults(p) has_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) -#define c_func_set_simple_defaults(p) set_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) -#define c_func_clear_simple_defaults(p) clear_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) -/* flag c_func_star arg defaults that need GC protection */ - -#define T_NO_SETTER T_LOCATION -#define closure_no_setter(p) has_type_bit(T_Clo(p), T_NO_SETTER) -#define closure_set_no_setter(p) set_type_bit(T_Clo(p), T_NO_SETTER) - -#define T_SHARED (1 << (TYPE_BITS + 11)) -#define is_shared(p) has_type_bit(T_Seq(p), T_SHARED) -#define set_shared(p) set_type_bit(T_Seq(p), T_SHARED) -#define is_collected_or_shared(p) has_type_bit(p, T_COLLECTED | T_SHARED) -#define clear_collected_and_shared(p) clear_type_bit(p, T_COLLECTED | T_SHARED) /* this can clear free cells = calloc */ -/* T_LOCAL is bit 12 */ - -#define T_SAFE_PROCEDURE (1 << (TYPE_BITS + 13)) -#define is_safe_procedure(p) has_type_bit(T_App(p), T_SAFE_PROCEDURE) /* was T_Pos 19-Apr-21 */ -#define is_safe_or_scope_safe_procedure(p) ((full_type(T_Fnc(p)) & (T_SCOPE_SAFE | T_SAFE_PROCEDURE)) != 0) -/* applicable objects that do not return or modify their arg list directly (no :rest arg in particular), - * and that can't call themselves either directly or via s7_call, and that don't mess with the stack. - */ - -#define T_CHECKED (1 << (TYPE_BITS + 14)) -#define set_checked(p) set_type_bit(T_Pair(p), T_CHECKED) -#define is_checked(p) has_type_bit(T_Pair(p), T_CHECKED) -#define clear_checked(p) clear_type_bit(T_Pair(p), T_CHECKED) -#define set_checked_slot(p) set_type_bit(T_Slt(p), T_CHECKED) -#define is_checked_slot(p) has_type_bit(T_Slt(p), T_CHECKED) -#define clear_checked_slot(p) clear_type_bit(T_Slt(p), T_CHECKED) - -#define T_ALL_INTEGER T_CHECKED -#define is_all_integer(p) has_type_bit(T_Sym(p), T_ALL_INTEGER) -#define set_all_integer(p) set_type_bit(T_Sym(p), T_ALL_INTEGER) - -#define T_UNSAFE (1 << (TYPE_BITS + 15)) -#define set_unsafe(p) set_type_bit(T_Pair(p), T_UNSAFE) -#define set_unsafely_optimized(p) full_type(T_Pair(p)) = (full_type(p) | T_UNSAFE | T_OPTIMIZED) -#define is_unsafe(p) has_type_bit(T_Pair(p), T_UNSAFE) -#define clear_unsafe(p) clear_type_bit(T_Pair(p), T_UNSAFE) -#define is_safely_optimized(p) ((full_type(T_Pair(p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED) /* was T_Pos 30-Jan-21 */ -/* optimizer flag saying "this expression is not completely self-contained. It might involve the stack, etc" */ - -#define T_CLEAN_SYMBOL T_UNSAFE -#define is_clean_symbol(p) has_type_bit(T_Sym(p), T_CLEAN_SYMBOL) -#define set_clean_symbol(p) set_type_bit(T_Sym(p), T_CLEAN_SYMBOL) -/* set if we know the symbol name can be printed without quotes (slashification) */ - -#define T_HAS_STEPPER T_UNSAFE -#define has_stepper(p) has_type_bit(T_Slt(p), T_HAS_STEPPER) -#define set_has_stepper(p) set_type_bit(T_Slt(p), T_HAS_STEPPER) - -#define T_DOX_SLOT2 T_UNSAFE -#define has_dox_slot2(p) has_type_bit(T_Let(p), T_DOX_SLOT2) -#define set_has_dox_slot2(p) set_type_bit(T_Let(p), T_DOX_SLOT2) -/* marks a let that includes the dox_slot2 */ - -#define T_IMMUTABLE (1 << (TYPE_BITS + 16)) -#define is_immutable(p) has_type_bit(T_Pos(p), T_IMMUTABLE) -#define set_immutable(p) set_type_bit(T_Pos(p), T_IMMUTABLE) -#define set_immutable_let(p) set_type_bit(T_Lid(p), T_IMMUTABLE) -#define set_immutable_slot(p) set_type_bit(T_Slt(p), T_IMMUTABLE) -#define is_immutable_port(p) has_type_bit(T_Prt(p), T_IMMUTABLE) -#define is_immutable_symbol(p) has_type_bit(T_Sym(p), T_IMMUTABLE) -#define is_immutable_slot(p) has_type_bit(T_Slt(p), T_IMMUTABLE) -#define is_immutable_pair(p) has_type_bit(T_Pair(p), T_IMMUTABLE) -#define is_immutable_vector(p) has_type_bit(T_Vec(p), T_IMMUTABLE) -#define is_immutable_string(p) has_type_bit(T_Str(p), T_IMMUTABLE) -/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for locally mutable numbers */ - -#define T_SETTER (1 << (TYPE_BITS + 17)) -#define set_is_setter(p) set_type_bit(T_Sym(p), T_SETTER) -#define is_setter(p) has_type_bit(T_Sym(p), T_SETTER) -/* optimizer flag for a procedure that sets some variable (set-car! for example) */ - -#define T_ALLOW_OTHER_KEYS T_SETTER -#define set_allow_other_keys(p) set_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) -#define allows_other_keys(p) has_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) -#define c_function_set_allow_other_keys(p) set_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) -#define c_function_allows_other_keys(p) has_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) -/* marks arglist (or c_function*) that allows keyword args other than those in the parameter list; - * we can't allow (define* (f :allow-other-keys)...) because there's only one nil, and besides, it does say "other". - */ - -#define T_LET_REMOVED T_SETTER -#define let_set_removed(p) set_type_bit(T_Let(p), T_LET_REMOVED) -#define let_removed(p) has_type_bit(T_Let(p), T_LET_REMOVED) -/* mark lets that have been removed from the heap or checked for that possibility */ - -#define T_HAS_EXPRESSION T_SETTER -#define slot_set_has_expression(p) set_type_bit(T_Slt(p), T_HAS_EXPRESSION) -#define slot_has_expression(p) has_type_bit(T_Slt(p), T_HAS_EXPRESSION) - -#define T_MUTABLE (1 << (TYPE_BITS + 18)) -#define is_mutable_number(p) has_type_bit(T_Num(p), T_MUTABLE) -#define is_mutable_integer(p) has_type_bit(T_Int(p), T_MUTABLE) -#define clear_mutable_number(p) clear_type_bit(T_Num(p), T_MUTABLE) -#define clear_mutable_integer(p) clear_type_bit(T_Int(p), T_MUTABLE) -/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) */ - -#define T_HAS_KEYWORD T_MUTABLE -#define has_keyword(p) has_type_bit(T_Sym(p), T_HAS_KEYWORD) -#define set_has_keyword(p) set_type_bit(T_Sym(p), T_HAS_KEYWORD) - -#define T_MARK_SEQ T_MUTABLE -#define is_mark_seq(p) has_type_bit(T_Itr(p), T_MARK_SEQ) -#define set_mark_seq(p) set_type_bit(T_Itr(p), T_MARK_SEQ) -/* used in iterators for GC mark of sequence */ - -#define T_STEP_END T_MUTABLE -#define is_step_end(p) has_type_bit(T_Slt(p), T_STEP_END) -#define step_end_fits(Slot, Len) ((is_step_end(Slot)) && (denominator(slot_value(Slot)) <= Len)) -#define set_step_end(p) set_type_bit(T_Slt(p), T_STEP_END) -/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */ - -#define T_NO_CELL_OPT T_MUTABLE -#define set_no_cell_opt(p) set_type_bit(T_Pair(p), T_NO_CELL_OPT) -#define no_cell_opt(p) has_type_bit(T_Pair(p), T_NO_CELL_OPT) - -#define T_IS_ELIST T_MUTABLE -#define set_is_elist(p) set_type_bit(T_Lst(p), T_IS_ELIST) -#define is_elist(p) has_type_bit(T_Lst(p), T_IS_ELIST) - -#define T_NO_INT_OPT T_SETTER -#define set_no_int_opt(p) set_type_bit(T_Pair(p), T_NO_INT_OPT) -#define no_int_opt(p) has_type_bit(T_Pair(p), T_NO_INT_OPT) - -#define T_NO_FLOAT_OPT T_UNSAFE -#define set_no_float_opt(p) set_type_bit(T_Pair(p), T_NO_FLOAT_OPT) -#define no_float_opt(p) has_type_bit(T_Pair(p), T_NO_FLOAT_OPT) - -#define T_NO_BOOL_OPT T_SAFE_STEPPER -#define set_no_bool_opt(p) set_type_bit(T_Pair(p), T_NO_BOOL_OPT) -#define no_bool_opt(p) has_type_bit(T_Pair(p), T_NO_BOOL_OPT) - -#define T_INTEGER_KEYS T_SETTER -#define set_has_integer_keys(p) set_type_bit(T_Pair(p), T_INTEGER_KEYS) -#define has_integer_keys(p) has_type_bit(T_Pair(p), T_INTEGER_KEYS) - -#define T_SAFE_STEPPER (1 << (TYPE_BITS + 19)) -#define is_safe_stepper(p) has_type_bit(T_Slt(p), T_SAFE_STEPPER) -#define set_safe_stepper(p) set_type_bit(T_Slt(p), T_SAFE_STEPPER) -#define clear_safe_stepper(p) clear_type_bit(T_Slt(p), T_SAFE_STEPPER) -#define is_safe_stepper_expr(p) has_type_bit(T_Pair(p), T_SAFE_STEPPER) -#define set_safe_stepper_expr(p) set_type_bit(T_Pair(p), T_SAFE_STEPPER) - -#define T_NUMBER_NAME T_SAFE_STEPPER -#define has_number_name(p) has_type_bit(T_Num(p), T_NUMBER_NAME) -#define set_has_number_name(p) set_type_bit(T_Num(p), T_NUMBER_NAME) -/* marks numbers that have a saved version of their string representation; this only matters in teq.scm, maybe tread.scm */ - -#define T_MAYBE_SAFE T_SAFE_STEPPER -#define is_maybe_safe(p) has_type_bit(T_Fnc(p), T_MAYBE_SAFE) -#define set_maybe_safe(p) set_type_bit(T_Fnc(p), T_MAYBE_SAFE) - -#define T_PAIR_MACRO T_SAFE_STEPPER -#define has_pair_macro(p) has_type_bit(T_Mac(p), T_PAIR_MACRO) -#define set_has_pair_macro(p) set_type_bit(T_Mac(p), T_PAIR_MACRO) - -#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER -#define T_HAS_LET_REF_FALLBACK T_MUTABLE -#define has_let_ref_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) -#define has_let_set_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) -#define set_has_let_ref_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_REF_FALLBACK) -#define set_has_let_set_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_SET_FALLBACK) -#define has_let_fallback(p) has_type_bit(T_Lid(p), (T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK)) -#define set_all_methods(p, e) full_type(T_Let(p)) |= (full_type(e) & (T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK)) - -#define T_WEAK_HASH T_SAFE_STEPPER -#define set_weak_hash_table(p) set_type_bit(T_Hsh(p), T_WEAK_HASH) -#define is_weak_hash_table(p) has_type_bit(T_Hsh(p), T_WEAK_HASH) - -#define T_ALL_FLOAT T_SAFE_STEPPER -#define is_all_float(p) has_type_bit(T_Sym(p), T_ALL_FLOAT) -#define set_all_float(p) set_type_bit(T_Sym(p), T_ALL_FLOAT) -#define set_all_integer_and_float(p) set_type_bit(T_Sym(p), (T_ALL_INTEGER | T_ALL_FLOAT)) - -#define T_COPY_ARGS (1 << (TYPE_BITS + 20)) -#define needs_copied_args(p) has_type_bit(T_Ext(p), T_COPY_ARGS) /* set via explicit T_COPY_ARGS, on T_Pos see s7_apply_function */ -#define set_needs_copied_args(p) set_type_bit(T_Pair(p), T_COPY_ARGS) -#define clear_needs_copied_args(p) clear_type_bit(T_Pair(p), T_COPY_ARGS) -/* this marks something that might mess with its argument list, it should not be in the second byte */ - -#define T_GENSYM (1 << (TYPE_BITS + 21)) -#define is_gensym(p) has_type_bit(T_Sym(p), T_GENSYM) -/* symbol is from gensym (GC-able etc) */ - -#define T_FUNCLET T_GENSYM -#define is_funclet(p) has_type_bit(T_Let(p), T_FUNCLET) -#define set_funclet(p) set_type_bit(T_Let(p), T_FUNCLET) -/* this marks a funclet */ - -#define T_HASH_CHOSEN T_GENSYM -#define hash_chosen(p) has_type_bit(T_Hsh(p), T_HASH_CHOSEN) -#define hash_set_chosen(p) set_type_bit(T_Hsh(p), T_HASH_CHOSEN) -#define hash_clear_chosen(p) clear_type_bit(T_Hsh(p), T_HASH_CHOSEN) - -#define T_DOCUMENTED T_GENSYM -#define is_documented(p) has_type_bit(T_Str(p), T_DOCUMENTED) -#define set_documented(p) set_type_bit(T_Str(p), T_DOCUMENTED) -/* this marks a symbol that has documentation (bit is set on name cell) */ - -#define T_FX_TREED T_GENSYM -#define is_fx_treed(p) has_type_bit(T_Pair(p), T_FX_TREED) -#define set_fx_treed(p) set_type_bit(T_Pair(p), T_FX_TREED) - -#define T_SUBVECTOR T_GENSYM -#define is_subvector(p) has_type_bit(T_Vec(p), T_SUBVECTOR) - -#define T_HAS_PENDING_VALUE T_GENSYM -#define slot_set_has_pending_value(p) set_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) -#define slot_has_pending_value(p) has_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) -#define slot_clear_has_pending_value(p) clear_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) - -#define T_HAS_METHODS (1 << (TYPE_BITS + 22)) -#define has_methods(p) has_type_bit(T_Pos(p), T_HAS_METHODS) /* display slot hits T_Ext here */ -#define is_openlet(p) has_type_bit(T_Let(p), T_HAS_METHODS) -#define has_active_methods(sc, p) ((has_type_bit(T_Ext(p), T_HAS_METHODS)) && (sc->has_openlets)) /* g_char # */ -#define set_has_methods(p) set_type_bit(T_Met(p), T_HAS_METHODS) -#define clear_has_methods(p) clear_type_bit(T_Met(p), T_HAS_METHODS) -/* this marks an environment or closure that is "open" for generic functions etc, don't reuse this bit */ - -#define T_ITER_OK (1LL << (TYPE_BITS + 23)) -#define iter_ok(p) has_type_bit(T_Itr(p), T_ITER_OK) /* was T_Pos 15-Apr-21 */ -#define clear_iter_ok(p) clear_type_bit(T_Itr(p), T_ITER_OK) - -#define T_STEP_END_OK T_ITER_OK -#define step_end_ok(p) has_type_bit(T_Pair(p), T_STEP_END_OK) -#define set_step_end_ok(p) set_type_bit(T_Pair(p), T_STEP_END_OK) - -#define T_IN_ROOTLET T_ITER_OK -#define in_rootlet(p) has_type_bit(T_Slt(p), T_IN_ROOTLET) -#define set_in_rootlet(p) set_type_bit(T_Slt(p), T_IN_ROOTLET) - -#define T_BOOL_FUNCTION T_ITER_OK -#define is_bool_function(p) has_type_bit(T_Prc(p), T_BOOL_FUNCTION) -#define set_is_bool_function(p) set_type_bit(T_Fnc(p), T_BOOL_FUNCTION) - -#define T_SYMBOL_FROM_SYMBOL T_ITER_OK -#define is_symbol_from_symbol(p) has_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) -#define set_is_symbol_from_symbol(p) set_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) -#define clear_symbol_from_symbol(p) clear_type1_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) - -/* it's faster here to use the high_flag bits rather than typeflag bits */ -#define BIT_ROOM 16 -#define T_FULL_SYMCONS (1LL << (TYPE_BITS + BIT_ROOM + 24)) -#define T_SYMCONS (1 << 0) -#define is_possibly_constant(p) has_type1_bit(T_Sym(p), T_SYMCONS) -#define set_possibly_constant(p) set_type1_bit(T_Sym(p), T_SYMCONS) -#define is_probably_constant(p) has_type_bit(T_Sym(p), (T_FULL_SYMCONS | T_IMMUTABLE)) - -#define T_HAS_LET_ARG T_SYMCONS -#define has_let_arg(p) has_type1_bit(T_Prc(p), T_HAS_LET_ARG) -#define set_has_let_arg(p) set_type1_bit(T_Prc(p), T_HAS_LET_ARG) -/* p is a setter procedure, "let arg" refers to the setter's optional third (let) argument */ - -#define T_HASH_VALUE_TYPE T_SYMCONS -#define has_hash_value_type(p) has_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE) -#define set_has_hash_value_type(p) set_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE) - -#define T_INT_OPTABLE T_SYMCONS -#define is_int_optable(p) has_type1_bit(T_Pair(p), T_INT_OPTABLE) -#define set_is_int_optable(p) set_type1_bit(T_Pair(p), T_INT_OPTABLE) - -/* symbol free here */ -#define T_FULL_HAS_LET_FILE (1LL << (TYPE_BITS + BIT_ROOM + 25)) -#define T_HAS_LET_FILE (1 << 1) -#define has_let_file(p) has_type1_bit(T_Let(p), T_HAS_LET_FILE) -#define set_has_let_file(p) set_type1_bit(T_Let(p), T_HAS_LET_FILE) -#define clear_has_let_file(p) clear_type1_bit(T_Let(p), T_HAS_LET_FILE) - -#define T_TYPED_VECTOR T_HAS_LET_FILE -#define is_typed_vector(p) has_type1_bit(T_Vec(p), T_TYPED_VECTOR) -#define set_typed_vector(p) set_type1_bit(T_Vec(p), T_TYPED_VECTOR) -#define clear_typed_vector(p) clear_type1_bit(T_Vec(p), T_TYPED_VECTOR) - -#define T_TYPED_HASH_TABLE T_HAS_LET_FILE -#define is_typed_hash_table(p) has_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE) -#define set_is_typed_hash_table(p) set_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE) - -#define T_BOOL_SETTER T_HAS_LET_FILE -#define c_function_has_bool_setter(p) has_type1_bit(T_Fnc(p), T_BOOL_SETTER) -#define c_function_set_has_bool_setter(p) set_type1_bit(T_Fnc(p), T_BOOL_SETTER) - -#define T_REST_SLOT T_HAS_LET_FILE -#define is_rest_slot(p) has_type1_bit(T_Slt(p), T_REST_SLOT) -#define set_is_rest_slot(p) set_type1_bit(T_Slt(p), T_REST_SLOT) - -#define T_NO_DEFAULTS T_HAS_LET_FILE -#define T_FULL_NO_DEFAULTS T_FULL_HAS_LET_FILE -#define has_no_defaults(p) has_type1_bit(T_Pcs(p), T_NO_DEFAULTS) -#define set_has_no_defaults(p) set_type1_bit(T_Pcs(p), T_NO_DEFAULTS) -/* pair=closure* body, transferred to closure* */ - -#define T_FULL_DEFINER (1LL << (TYPE_BITS + BIT_ROOM + 26)) -#define T_DEFINER (1 << 2) -#define is_definer(p) has_type1_bit(T_Sym(p), T_DEFINER) -#define set_is_definer(p) set_type1_bit(T_Sym(p), T_DEFINER) -#define is_func_definer(p) has_type1_bit(T_Fnc(p), T_DEFINER) -#define set_func_is_definer(p) do {set_type1_bit(T_Fnc(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) -#define is_syntax_definer(p) has_type1_bit(T_Syn(p), T_DEFINER) -#define set_syntax_is_definer(p) do {set_type1_bit(T_Syn(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) -/* this marks "definers" like define and define-macro */ - -#define T_MACLET T_DEFINER -#define is_maclet(p) has_type1_bit(T_Let(p), T_MACLET) -#define set_maclet(p) set_type1_bit(T_Let(p), T_MACLET) -/* this marks a maclet */ - -#define T_HAS_FX T_DEFINER -#define set_has_fx(p) set_type1_bit(T_Pair(p), T_HAS_FX) -#define has_fx(p) has_type1_bit(T_Pair(p), T_HAS_FX) -#define clear_has_fx(p) clear_type1_bit(T_Pair(p), T_HAS_FX) - -#define T_SLOT_DEFAULTS T_DEFINER -#define slot_defaults(p) has_type1_bit(T_Slt(p), T_SLOT_DEFAULTS) -#define set_slot_defaults(p) set_type1_bit(T_Slt(p), T_SLOT_DEFAULTS) - -#define T_WEAK_HASH_ITERATOR T_DEFINER -#define is_weak_hash_iterator(p) has_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) -#define set_weak_hash_iterator(p) set_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) -#define clear_weak_hash_iterator(p) clear_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) - -#define T_HASH_KEY_TYPE T_DEFINER -#define has_hash_key_type(p) has_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE) -#define set_has_hash_key_type(p) set_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE) - -#define T_FULL_BINDER (1LL << (TYPE_BITS + BIT_ROOM + 27)) -#define T_BINDER (1 << 3) -#define set_syntax_is_binder(p) do {set_type1_bit(T_Syn(initial_value(p)), T_BINDER); set_type1_bit(T_Sym(p), T_BINDER);} while (0) -#define is_definer_or_binder(p) has_type1_bit(T_Sym(p), T_DEFINER | T_BINDER) -/* this marks "binders" like let */ - -#define T_SEMISAFE T_BINDER -#define is_semisafe(p) has_type1_bit(T_Fnc(p), T_SEMISAFE) -#define set_is_semisafe(p) set_type1_bit(T_Fnc(p), T_SEMISAFE) - -/* #define T_TREE_COLLECTED T_FULL_BINDER */ -#define T_SHORT_TREE_COLLECTED T_BINDER -#define tree_is_collected(p) has_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) -#define tree_set_collected(p) set_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) -#define tree_clear_collected(p) clear_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) - -#define T_SIMPLE_VALUES T_BINDER -#define has_simple_values(p) has_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) -#define set_has_simple_values(p) set_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) -#define clear_has_simple_values(p) clear_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) - -#define T_VERY_SAFE_CLOSURE (1LL << (TYPE_BITS + BIT_ROOM + 28)) -#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4) -#define is_very_safe_closure(p) has_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) -#define set_very_safe_closure(p) set_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) -#define closure_bits(p) (full_type(T_Pair(p)) & (T_SAFE_CLOSURE | T_VERY_SAFE_CLOSURE | T_FULL_NO_DEFAULTS)) -#define is_very_safe_closure_body(p) has_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) -#define set_very_safe_closure_body(p) set_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) - -#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE -#define is_baffle_let(p) has_type1_bit(T_Let(p), T_BAFFLE_LET) -#define set_baffle_let(p) set_type1_bit(T_Let(p), T_BAFFLE_LET) - -#define T_CYCLIC (1LL << (TYPE_BITS + BIT_ROOM + 29)) -#define T_SHORT_CYCLIC (1 << 5) -#define is_cyclic(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC) -#define set_cyclic(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC) - -#define T_CYCLIC_SET (1LL << (TYPE_BITS + BIT_ROOM + 30)) -#define T_SHORT_CYCLIC_SET (1 << 6) -#define is_cyclic_set(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) /* was T_Pos 30-Jan-21 */ -#define set_cyclic_set(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) -#define clear_cyclic_bits(p) clear_type_bit(p, T_COLLECTED | T_SHARED | T_CYCLIC | T_CYCLIC_SET) - -#define T_KEYWORD (1LL << (TYPE_BITS + BIT_ROOM + 31)) -#define T_SHORT_KEYWORD (1 << 7) -#define is_keyword(p) has_type1_bit(T_Sym(p), T_SHORT_KEYWORD) -#define is_symbol_and_keyword(p) ((is_symbol(p)) && (is_keyword(p))) -/* this bit distinguishes a symbol from a symbol that is also a keyword */ - -#define T_FX_TREEABLE T_SHORT_KEYWORD -#define is_fx_treeable(p) has_type1_bit(T_Pair(p), T_FX_TREEABLE) -#define set_is_fx_treeable(p) set_type1_bit(T_Pair(p), T_FX_TREEABLE) - -#define T_FULL_SIMPLE_ELEMENTS (1LL << (TYPE_BITS + BIT_ROOM + 32)) -#define T_SIMPLE_ELEMENTS (1 << 8) -#define has_simple_elements(p) has_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) -#define set_has_simple_elements(p) set_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) -#define c_function_has_simple_elements(p) has_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS) -#define c_function_set_has_simple_elements(p) set_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS) -/* c_func case here refers to boolean? et al -- structure element type declaration that ensures a simple object */ - -#define T_SIMPLE_KEYS T_SIMPLE_ELEMENTS -#define has_simple_keys(p) has_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) -#define set_has_simple_keys(p) set_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) -#define clear_has_simple_keys(p) clear_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) - -#define T_SAFE_SETTER T_SIMPLE_ELEMENTS -#define is_safe_setter(p) has_type1_bit(T_Sym(p), T_SAFE_SETTER) -#define set_is_safe_setter(p) set_type1_bit(T_Sym(p), T_SAFE_SETTER) - -#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS -#define is_float_optable(p) has_type1_bit(T_Pair(p), T_FLOAT_OPTABLE) -#define set_is_float_optable(p) set_type1_bit(T_Pair(p), T_FLOAT_OPTABLE) - -#define T_FULL_CASE_KEY (1LL << (TYPE_BITS + BIT_ROOM + 33)) -#define T_CASE_KEY (1 << 9) -#define is_case_key(p) has_type1_bit(T_Ext(p), T_CASE_KEY) -#define set_case_key(p) set_type1_bit(T_Sym(p), T_CASE_KEY) - -#define T_OPT1_FUNC_LISTED T_CASE_KEY -#define opt1_func_listed(p) has_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED) -#define set_opt1_func_listed(p) set_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED) - -#define T_FULL_HAS_GX (1LL << (TYPE_BITS + BIT_ROOM + 34)) -#define T_HAS_GX (1 << 10) -#define has_gx(p) has_type1_bit(T_Pair(p), T_HAS_GX) -#define set_has_gx(p) set_type1_bit(T_Pair(p), T_HAS_GX) - -#define T_FULL_UNKNOPT (1LL << (TYPE_BITS + BIT_ROOM + 35)) -#define T_UNKNOPT (1 << 11) -#define is_unknopt(p) has_type1_bit(T_Pair(p), T_UNKNOPT) -#define set_is_unknopt(p) set_type1_bit(T_Pair(p), T_UNKNOPT) - -#define T_MAC_OK T_UNKNOPT -#define mac_is_ok(p) has_type1_bit(T_Pair(p), T_MAC_OK) -#define set_mac_is_ok(p) set_type1_bit(T_Pair(p), T_MAC_OK) -/* marks a macro (via (macro...)) that has been checked -- easier (and slower) than making 4 or 5 more ops, op_macro_unchecked and so on */ - -#define T_FULL_SAFETY_CHECKED (1LL << (TYPE_BITS + BIT_ROOM + 36)) -#define T_SAFETY_CHECKED (1 << 12) -#define is_safety_checked(p) has_type1_bit(T_Pair(p), T_SAFETY_CHECKED) -#define set_safety_checked(p) do {if (in_heap(p)) set_type1_bit(T_Pair(p), T_SAFETY_CHECKED);} while (0) - -#define T_FULL_HAS_FN (1LL << (TYPE_BITS + BIT_ROOM + 37)) -#define T_HAS_FN (1 << 13) -#define set_has_fn(p) set_type1_bit(T_Pair(p), T_HAS_FN) -#define has_fn(p) has_type1_bit(T_Pair(p), T_HAS_FN) - -#define T_GC_MARK 0x8000000000000000 -#define is_marked(p) has_type_bit(p, T_GC_MARK) -#define set_mark(p) set_type_bit(T_Pos(p), T_GC_MARK) -#define clear_mark(p) clear_type_bit(p, T_GC_MARK) -/* using the sign bit, bit 23 (or 55) == 31 (or 63) for this makes a big difference in the GC */ - -#define T_UNHEAP 0x4000000000000000 -#define T_SHORT_UNHEAP (1 << 14) -#define in_heap(p) (((T_Pos(p))->tf.opts.high_flag & T_SHORT_UNHEAP) == 0) -#define unheap(sc, p) set_type1_bit(T_Pos(p), T_SHORT_UNHEAP) - -#define is_eof(p) ((T_Ext(p)) == eof_object) -#define is_true(Sc, p) ((T_Ext(p)) != Sc->F) -#define is_false(Sc, p) ((T_Ext(p)) == Sc->F) - -#ifdef _MSC_VER - static s7_pointer make_boolean(s7_scheme *sc, bool val) {if (val) return(sc->T); return(sc->F);} -#else - #define make_boolean(sc, Val) ((Val) ? sc->T : sc->F) -#endif - -#define is_pair(p) (type(p) == T_PAIR) -#define is_mutable_pair(p) ((is_pair(p)) && (!is_immutable(p))) /* same speed: ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_PAIR) */ -#define is_null(p) ((T_Pos(p)) == sc->nil) /* can be a slot */ -#define is_not_null(p) ((T_Pos(p)) != sc->nil) -#define is_list(p) ((is_pair(p)) || (type(p) == T_NIL)) -#define is_quoted_pair(p) ((is_pair(p)) && (car(p) == sc->quote_symbol)) -#define is_unquoted_pair(p) ((is_pair(p)) && (car(p) != sc->quote_symbol)) -#define is_quoted_symbol(p) ((is_pair(p)) && (car(p) == sc->quote_symbol) && (is_symbol(cadr(p)))) - - -/* pair line/file/position */ -#define PAIR_LINE_BITS 24 -#define PAIR_FILE_BITS 12 -#define PAIR_POSITION_BITS 28 -#define PAIR_LINE_OFFSET 0 -#define PAIR_FILE_OFFSET PAIR_LINE_BITS -#define PAIR_POSITION_OFFSET (PAIR_LINE_BITS + PAIR_FILE_BITS) -#define PAIR_LINE_MASK ((1 << PAIR_LINE_BITS) - 1) -#define PAIR_FILE_MASK ((1 << PAIR_FILE_BITS) - 1) -#define PAIR_POSITION_MASK ((1 << PAIR_POSITION_BITS) - 1) - -#define port_location(Pt) (((port_line_number(Pt) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \ - ((port_file_number(Pt) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \ - ((port_position(Pt) & PAIR_POSITION_MASK) << PAIR_POSITION_OFFSET)) - -#define location_to_line(Loc) ((Loc >> PAIR_LINE_OFFSET) & PAIR_LINE_MASK) -#define location_to_file(Loc) ((Loc >> PAIR_FILE_OFFSET) & PAIR_FILE_MASK) -#define location_to_position(Loc) ((Loc >> PAIR_POSITION_OFFSET) & PAIR_POSITION_MASK) - -#define pair_line_number(p) location_to_line(pair_location(p)) -#define pair_file_number(p) location_to_file(pair_location(p)) -#define pair_position(p) location_to_position(pair_location(p)) - -#if (!S7_DEBUGGING) -#define pair_location(p) (p)->object.sym_cons.location -#define pair_set_location(p, X) (p)->object.sym_cons.location = X -#define pair_raw_hash(p) (p)->object.sym_cons.hash -#define pair_set_raw_hash(p, X) (p)->object.sym_cons.hash = X -#define pair_raw_len(p) (p)->object.sym_cons.location -#define pair_set_raw_len(p, X) (p)->object.sym_cons.location = X -#define pair_raw_name(p) (p)->object.sym_cons.fstr -#define pair_set_raw_name(p, X) (p)->object.sym_cons.fstr = X -/* opt1 == raw_hash, opt2 == raw_name, opt3 == line|ctr + len, but hash/name/len only apply to the symbol table so there's no collision */ - -#define opt1(p, r) ((p)->object.cons.opt1) -#define set_opt1(p, x, r) (p)->object.cons.opt1 = x -#define opt2(p, r) ((p)->object.cons.o2.opt2) -#define set_opt2(p, x, r) (p)->object.cons.o2.opt2 = (s7_pointer)(x) -#define opt2_n(p, r) ((p)->object.cons.o2.n) -#define set_opt2_n(p, x, r) (p)->object.cons.o2.n = x -#define opt3(p, r) ((p)->object.cons.o3.opt3) -#define set_opt3(p, x, r) do {(p)->object.cons.o3.opt3 = x; clear_type_bit(p, T_LOCATION);} while (0) -#define opt3_n(p, r) ((p)->object.cons.o3.n) -#define set_opt3_n(p, x, r) do {(p)->object.cons.o3.n = x; clear_type_bit(p, T_LOCATION);} while (0) - -#else - -/* the 3 opt fields hold most of the varigated optimizer info, so they are used in many conflicting ways. - * the bits and funcs here try to track each such use, and report any cross-talk or collisions. - * all of this machinery vanishes if debugging is turned off. - */ -#define OPT1_SET (1 << 0) -#define OPT2_SET (1 << 1) -#define OPT3_SET (1 << 2) - -#define OPT1_FAST (1 << 3) /* fast list in member/assoc circular list check */ -#define OPT1_CFUNC (1 << 4) /* c-function */ -#define OPT1_CLAUSE (1 << 5) /* case clause */ -#define OPT1_LAMBDA (1 << 6) /* lambda(*) */ -#define OPT1_SYM (1 << 7) /* symbol */ -#define OPT1_PAIR (1 << 8) /* pair */ -#define OPT1_CON (1 << 9) /* constant from eval's point of view */ /* 10 was opt1_goto, unused */ -#define OPT1_ANY (1 << 11) /* anything -- deliberate unchecked case */ -#define OPT1_HASH (1 << 12) /* hash code used in the symbol table (pair_raw_hash) */ -#define OPT1_MASK (OPT1_FAST | OPT1_CFUNC | OPT1_CLAUSE | OPT1_LAMBDA | OPT1_SYM | OPT1_PAIR | OPT1_CON | OPT1_ANY | OPT1_HASH) - -#define opt1_is_set(p) (((T_Pair(p))->debugger_bits & OPT1_SET) != 0) -#define set_opt1_is_set(p) (T_Pair(p))->debugger_bits |= OPT1_SET -#define opt1_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT1_MASK) == Role) -#define set_opt1_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT1_MASK)) -#define opt1(p, Role) opt1_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt1(p, x, Role) set_opt1_1(T_Pair(p), x, Role, __func__, __LINE__) - -#define OPT2_KEY (1 << 13) /* case key */ -#define OPT2_SLOW (1 << 14) /* slow list in member/assoc circular list check */ -#define OPT2_SYM (1 << 15) /* symbol */ -#define OPT2_PAIR (1 << 16) /* pair */ -#define OPT2_CON (1 << 17) /* constant as above */ -#define OPT2_FX (1 << 18) /* fx (fx_*) func (sc, form) */ -#define OPT2_FN (1 << 19) /* fn (s7_function) func (sc, arglist) */ -#define OPT2_LAMBDA (1 << 20) /* lambda form */ -#define OPT2_NAME (1 << 21) /* named used by symbol table (pair_raw_name) */ -#define OPT2_DIRECT (1LL << 32) -#define OPT2_INT (1LL << 33) -#define OPT2_MASK (OPT2_KEY | OPT2_SLOW | OPT2_SYM | OPT2_PAIR | OPT2_CON | OPT2_FX | \ - OPT2_FN | OPT2_LAMBDA | OPT2_DIRECT | OPT2_NAME | OPT2_INT) - -#define opt2_is_set(p) (((T_Pair(p))->debugger_bits & OPT2_SET) != 0) -#define set_opt2_is_set(p) (T_Pair(p))->debugger_bits |= OPT2_SET -#define opt2_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT2_MASK) == Role) -#define set_opt2_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT2_MASK)) -#define opt2(p, Role) opt2_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__) -#define opt2_n(p, Role) opt2_n_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt2_n(p, x, Role) set_opt2_n_1(sc, T_Pair(p), x, Role, __func__, __LINE__) - -#define OPT3_ARGLEN (1 << 22) /* arglist length */ -#define OPT3_SYM (1 << 23) /* expression symbol access */ -#define OPT3_AND (1 << 24) /* and second clause */ -#define OPT3_DIRECT (1 << 25) /* direct call info */ -#define OPT3_ANY (1 << 26) -#define OPT3_LET (1 << 27) /* let or #f */ -#define OPT3_CON (1 << 28) -#define OPT3_LOCATION (1 << 29) -#define OPT3_LEN (1 << 30) -#define OPT3_BYTE (1LL << 31) -#define OPT3_INT (1LL << 34) -#define OPT3_MASK (OPT3_ARGLEN | OPT3_SYM | OPT3_AND | OPT3_ANY | OPT3_LET | OPT3_BYTE | \ - OPT3_LOCATION | OPT3_LEN | OPT3_DIRECT | OPT3_CON | OPT3_INT) - -#define opt3_is_set(p) (((T_Pair(p))->debugger_bits & OPT3_SET) != 0) -#define set_opt3_is_set(p) (T_Pair(p))->debugger_bits |= OPT3_SET -#define opt3_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT3_MASK) == Role) -#define set_opt3_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT3_MASK)) -#define opt3(p, Role) opt3_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt3(p, x, Role) set_opt3_1(T_Pair(p), x, Role) -#define opt3_n(p, Role) opt3_n_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt3_n(p, x, Role) set_opt3_n_1(T_Pair(p), x, Role) - -#define pair_location(p) opt3_location_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_location(p, X) set_opt3_location_1(T_Pair(p), X) -#define pair_raw_hash(p) opt1_hash_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_raw_hash(p, X) set_opt1_hash_1(T_Pair(p), X) -#define pair_raw_len(p) opt3_len_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_raw_len(p, X) set_opt3_len_1(T_Pair(p), X) -#define pair_raw_name(p) opt2_name_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_raw_name(p, X) set_opt2_name_1(T_Pair(p), X) - -#define L_HIT (1LL << 40) /* "L_SET" is taken */ -#define L_FUNC (1LL << 41) -#define L_DOX (1LL << 42) -#define L_MASK (L_FUNC | L_DOX) -#endif - -#define opt1_fast(P) T_Lst(opt1(P, OPT1_FAST)) -#define set_opt1_fast(P, X) set_opt1(P, T_Pair(X), OPT1_FAST) -#define opt1_cfunc(P) T_Pos(opt1(P, OPT1_CFUNC)) -#define set_opt1_cfunc(P, X) set_opt1(P, T_Fnc(X), OPT1_CFUNC) -#define opt1_lambda_unchecked(P) opt1(P, OPT1_LAMBDA) /* can be free/null? from s7_call? */ -#define opt1_lambda(P) T_Clo(opt1(P, OPT1_LAMBDA)) -#define set_opt1_lambda(P, X) set_opt1(P, T_Clo(X), OPT1_LAMBDA) -#define set_opt1_lambda_add(P, X) do {set_opt1(P, T_Clo(X), OPT1_LAMBDA); add_opt1_func(sc, P);} while (0) -#define opt1_clause(P) T_Pos(opt1(P, OPT1_CLAUSE)) -#define set_opt1_clause(P, X) set_opt1(P, T_Pos(X), OPT1_CLAUSE) -#define opt1_sym(P) T_Sym(opt1(P, OPT1_SYM)) -#define set_opt1_sym(P, X) set_opt1(P, T_Sym(X), OPT1_SYM) -#define opt1_pair(P) T_Lst(opt1(P, OPT1_PAIR)) -#define set_opt1_pair(P, X) set_opt1(P, T_Lst(X), OPT1_PAIR) -#define opt1_con(P) T_Pos(opt1(P, OPT1_CON)) -#define set_opt1_con(P, X) set_opt1(P, T_Pos(X), OPT1_CON) /* can be # */ -#define opt1_any(P) opt1(P, OPT1_ANY) /* can be free in closure_is_ok */ -#define set_opt1_any(P, X) set_opt1(P, X, OPT1_ANY) - -#define opt2_any(P) opt2(P, OPT2_KEY) -#define set_opt2_any(P, X) set_opt2(P, X, OPT2_KEY) -#define opt2_int(P) opt2_n(P, OPT2_INT) -#define set_opt2_int(P, X) set_opt2_n(P, X, OPT2_INT) -#define opt2_slow(P) T_Lst(opt2(P, OPT2_SLOW)) -#define set_opt2_slow(P, X) set_opt2(P, T_Pair(X), OPT2_SLOW) -#define opt2_sym(P) T_Sym(opt2(P, OPT2_SYM)) -#define set_opt2_sym(P, X) set_opt2(P, T_Sym(X), OPT2_SYM) -#define opt2_pair(P) T_Lst(opt2(P, OPT2_PAIR)) -#define set_opt2_pair(P, X) set_opt2(P, T_Lst(X), OPT2_PAIR) -#define opt2_con(P) T_Pos(opt2(P, OPT2_CON)) -#define set_opt2_con(P, X) set_opt2(P, T_Pos(X), OPT2_CON) -#define opt2_lambda(P) T_Pair(opt2(P, OPT2_LAMBDA)) -#define set_opt2_lambda(P, X) set_opt2(P, T_Pair(X), OPT2_LAMBDA) -#define opt2_direct(P) opt2(P, OPT2_DIRECT) -#define set_opt2_direct(P, X) set_opt2(P, (s7_pointer)(X), OPT2_DIRECT) - -#define opt3_arglen(P) opt3_n(P, OPT3_ARGLEN) -#define set_opt3_arglen(P, X) set_opt3_n(P, X, OPT3_ARGLEN) -#define opt3_int(P) opt3_n(P, OPT3_INT) -#define set_opt3_int(P, X) set_opt3_n(P, X, OPT3_INT) -#define opt3_sym(P) T_Sym(opt3(P, OPT3_SYM)) -#define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), OPT3_SYM) -#define opt3_con(P) T_Pos(opt3(P, OPT3_CON)) -#define set_opt3_con(P, X) set_opt3(P, T_Pos(X), OPT3_CON) -#define opt3_pair(P) T_Pair(opt3(P, OPT3_AND)) -#define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), OPT3_AND) -#define opt3_any(P) opt3(P, OPT3_ANY) -#define set_opt3_any(P, X) set_opt3(P, X, OPT3_ANY) -#define opt3_let(P) T_Lid(opt3(P, OPT3_LET)) -#define set_opt3_let(P, X) set_opt3(P, T_Lid(X), OPT3_LET) -#define opt3_direct(P) opt3(P, OPT3_DIRECT) -#define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), OPT3_DIRECT) - -#if S7_DEBUGGING -#define opt3_byte(p) opt3_byte_1(sc, T_Pair(p), OPT3_BYTE, __func__, __LINE__) -#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, OPT3_BYTE, __func__, __LINE__) -#else -#define opt3_byte(P) T_Pair(P)->object.cons.o3.opt_type /* op_if_is_type, opt_type == opt3 in cons */ -#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons.o3.opt_type = X; clear_type_bit(P, T_LOCATION);} while (0) -#endif - -#define pair_macro(P) opt2_sym(P) -#define set_pair_macro(P, Name) set_opt2_sym(P, Name) - -#define fn_proc(f) ((s7_function)(opt2(f, OPT2_FN))) -#define fx_proc(f) ((s7_function)(opt2(f, OPT2_FX))) -#define fn_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2)) -#define fx_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2)) /* unused */ - -#define set_fx(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FX); if (X) set_has_fx(f); else clear_has_fx(f);} while (0) -#define set_fx_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FX); set_has_fx(f);} while (0) -#define set_fn(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FN); if (X) set_has_fn(f); else clear_has_fx(f);} while (0) -#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0) - -#if WITH_GCC -#define fx_call(Sc, F) ({s7_pointer _P_; _P_ = F; fx_proc(_P_)(Sc, car(_P_));}) -#define fc_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) -#define fn_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) -#else -#define fx_call(Sc, F) fx_proc(F)(Sc, car(F)) -#define fc_call(Sc, F) fn_proc(F)(Sc, cdr(F)) -#define fn_call(Sc, F) fn_proc(F)(Sc, cdr(F)) -#endif -/* fx_call can affect the stack and sc->value */ - -#define car(p) (T_Pair(p))->object.cons.car -#define set_car(p, Val) car(p) = T_Pos(Val) /* can be a slot or # */ -#define cdr(p) (T_Pair(p))->object.cons.cdr -#define set_cdr(p, Val) cdr(p) = T_Pos(Val) -#define unchecked_car(p) (T_Pos(p))->object.cons.car -#define unchecked_cdr(p) (T_Pos(p))->object.cons.cdr - -#define caar(p) car(car(p)) -#define cadr(p) car(cdr(p)) -#define set_cadr(p, Val) car(cdr(p)) = T_Pos(Val) -#define cdar(p) cdr(car(p)) -#define set_cdar(p, Val) cdr(car(p)) = T_Pos(Val) -#define cddr(p) cdr(cdr(p)) - -#define caaar(p) car(car(car(p))) -#define cadar(p) car(cdr(car(p))) -#define cdadr(p) cdr(car(cdr(p))) -#define caddr(p) car(cdr(cdr(p))) -#define set_caddr(p, Val) car(cdr(cdr(p))) = T_Pos(Val) -#define caadr(p) car(car(cdr(p))) -#define cdaar(p) cdr(car(car(p))) -#define cdddr(p) cdr(cdr(cdr(p))) -#define set_cdddr(p, Val) cdr(cdr(cdr(p))) = T_Pos(Val) -#define cddar(p) cdr(cdr(car(p))) - -#define caaadr(p) car(car(car(cdr(p)))) -#define caadar(p) car(car(cdr(car(p)))) -#define cadaar(p) car(cdr(car(car(p)))) -#define cadddr(p) car(cdr(cdr(cdr(p)))) -#define caaddr(p) car(car(cdr(cdr(p)))) -#define cddddr(p) cdr(cdr(cdr(cdr(p)))) -#define caddar(p) car(cdr(cdr(car(p)))) -#define cdadar(p) cdr(car(cdr(car(p)))) -#define cdaddr(p) cdr(car(cdr(cdr(p)))) -#define caaaar(p) car(car(car(car(p)))) -#define cadadr(p) car(cdr(car(cdr(p)))) -#define cdaadr(p) cdr(car(car(cdr(p)))) -#define cdaaar(p) cdr(car(car(car(p)))) -#define cdddar(p) cdr(cdr(cdr(car(p)))) -#define cddadr(p) cdr(cdr(car(cdr(p)))) -#define cddaar(p) cdr(cdr(car(car(p)))) - -#define cadaddr(p) cadr(caddr(p)) -#define caddadr(p) caddr(cadr(p)) -#define caddaddr(p) caddr(caddr(p)) - -#if WITH_GCC - /* slightly tricky because cons can be called recursively, macro here is faster than inline function */ - #define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;}) -#else - #define cons(Sc, A, B) s7_cons(Sc, A, B) -#endif - -#define list_1(Sc, A) cons(Sc, A, Sc->nil) -#define list_1_unchecked(Sc, A) cons_unchecked(Sc, A, Sc->nil) -#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, Sc->nil)) -#define list_2_unchecked(Sc, A, B) cons_unchecked(Sc, A, cons_unchecked(Sc, B, Sc->nil)) -#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, Sc->nil))) -#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, Sc->nil)))) -#define with_list_t1(A) (set_car(sc->t1_1, A), sc->t1_1) /* this is slower than explicit code, esp t3, procedures are same as this */ -#define with_list_t2(A, B) (set_car(sc->t2_1, A), set_car(sc->t2_2, B), sc->t2_1) -#define with_list_t3(A, B, C) (set_car(sc->t3_1, A), set_car(sc->t3_2, B), set_car(sc->t3_3, C), sc->t3_1) -#define with_list_t4(A, B, C, D) (set_car(sc->t4_1, A), set_car(sc->t3_1, B), set_car(sc->t3_2, C), set_car(sc->t3_3, D), sc->t4_1) - -#define is_string(p) (type(p) == T_STRING) -#define is_mutable_string(p) ((full_type(T_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_STRING) -#define string_value(p) (T_Str(p))->object.string.svalue -#define string_length(p) (T_Str(p))->object.string.length -#define string_hash(p) (T_Str(p))->object.string.hash -#define string_block(p) (T_Str(p))->object.string.block -#define unchecked_string_block(p) p->object.string.block - -#define character(p) (T_Chr(p))->object.chr.c -#define is_character(p) (type(p) == T_CHARACTER) -#define upper_character(p) (T_Chr(p))->object.chr.up_c -#define is_char_alphabetic(p) (T_Chr(p))->object.chr.alpha_c -#define is_char_numeric(p) (T_Chr(p))->object.chr.digit_c -#define is_char_whitespace(p) (T_Chr(p))->object.chr.space_c -#define is_char_uppercase(p) (T_Chr(p))->object.chr.upper_c -#define is_char_lowercase(p) (T_Chr(p))->object.chr.lower_c -#define character_name(p) (T_Chr(p))->object.chr.c_name -#define character_name_length(p) (T_Chr(p))->object.chr.length - -#define optimize_op(P) (T_Ext(P))->tf.opts.opt_choice -#define set_optimize_op(P, Op) (T_Ext(P))->tf.opts.opt_choice = (Op) /* not T_Pair -- needs legit cur_sc in init_chars|strings */ -#define OP_HOP_MASK 0xfffe -#define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & OP_HOP_MASK) == (Q))) -#define op_no_hop(P) (optimize_op(P) & OP_HOP_MASK) -#define op_has_hop(P) ((optimize_op(P) & 1) != 0) -#define clear_optimize_op(P) set_optimize_op(P, OP_UNOPT) -#define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0) -#define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0) - -#define is_symbol(p) (type(p) == T_SYMBOL) -#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) -#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(lookup_slot_from(p, sc->curlet)))) -#define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name) -#define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S) -#define symbol_name(p) string_value(symbol_name_cell(p)) -#define symbol_name_length(p) string_length(symbol_name_cell(p)) -#define gensym_block(p) symbol_name_cell(p)->object.string.gensym_block -#define pointer_map(p) (s7_int)((intptr_t)(p) >> 8) -#define symbol_id(p) (T_Sym(p))->object.sym.id -#define symbol_set_id_unchecked(p, X) (T_Sym(p))->object.sym.id = X -#if S7_DEBUGGING -static void symbol_set_id(s7_pointer p, s7_int id) -{ - if (id < symbol_id(p)) - { - fprintf(stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", __func__, __LINE__, symbol_name(p), symbol_id(p), id); - abort(); - } - (T_Sym(p))->object.sym.id = id; -} -#else -#define symbol_set_id(p, X) (T_Sym(p))->object.sym.id = X -#endif -/* we need 64-bits here, since we don't want this thing to wrap around, and lets are created at a great rate - * callgrind says this is faster than a uint32_t! - */ -#define symbol_info(p) (symbol_name_cell(p))->object.string.block -#define symbol_type(p) (block_size(symbol_info(p)) & 0xff) /* boolean function bool type */ -#define symbol_set_type(p, Type) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff) | ((Type) & 0xff)) -#define symbol_clear_type(p) block_size(symbol_info(p)) = 0 -#define s7_starlet_symbol(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* id */ -#define s7_starlet_symbol_set(p, F) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | (((F) & 0xff) << 8)) - -#define initial_slot(p) T_Sld(symbol_info(p)->ex.ex_ptr) -#define set_initial_slot(p, Val) symbol_info(p)->ex.ex_ptr = T_Sld(Val) -#define global_slot(p) T_Sld((T_Sym(p))->object.sym.global_slot) -#define set_global_slot(p, Val) (T_Sym(p))->object.sym.global_slot = T_Sld(Val) -#define local_slot(p) T_Sln((T_Sym(p))->object.sym.local_slot) -#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val) - -#define initial_value(p) slot_value(initial_slot(T_Sym(p))) -#define local_value(p) slot_value(local_slot(T_Sym(p))) -#define unchecked_local_value(p) local_slot(p)->object.slt.val -#define global_value(p) slot_value(global_slot(T_Sym(p))) - -#define keyword_symbol(p) symbol_info(T_Key(p))->nx.ksym /* keyword only, so does not collide with documentation */ -#define keyword_symbol_unchecked(p) symbol_info(p)->nx.ksym -#define keyword_set_symbol(p, Val) symbol_info(T_Key(p))->nx.ksym = T_Sym(Val) -#define symbol_help(p) symbol_info(p)->nx.documentation -#define symbol_set_help(p, Doc) symbol_info(p)->nx.documentation = Doc -#define symbol_tag(p) (T_Sym(p))->object.sym.tag -#define symbol_set_tag(p, Val) (T_Sym(p))->object.sym.tag = Val -#define symbol_ctr(p) (T_Sym(p))->object.sym.ctr /* needs to be in the symbol object (not symbol_info) for speed */ -#define symbol_clear_ctr(p) (T_Sym(p))->object.sym.ctr = 0 -#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ -#define symbol_tag2(p) symbol_info(p)->ln.tag -#define symbol_set_tag2(p, Val) symbol_info(p)->ln.tag = Val -#define symbol_has_help(p) (is_documented(symbol_name_cell(p))) -#define symbol_set_has_help(p) set_documented(symbol_name_cell(p)) -/* symbol_info->dx is free */ - -#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \ - do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) -#define symbol_set_local_slot_unchecked_and_unincremented(Symbol, Id, Slot) \ - do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id);} while (0) -#define symbol_set_local_slot(Symbol, Id, Slot) \ - do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) -#define symbol_set_local_slot_unincremented(Symbol, Id, Slot) \ - do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0) -/* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */ - -#define is_slot(p) (type(p) == T_SLOT) -#define slot_symbol(p) T_Sym((T_Slt(p))->object.slt.sym) -#define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym) -#define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val) -#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val) -#define slot_set_symbol_and_value(Slot, Symbol, Value) do {slot_set_symbol(Slot, Symbol); slot_set_value(Slot, Value);} while (0) -#define slot_set_value_with_hook(Slot, Value) \ - do {if (hook_has_functions(sc->rootlet_redefinition_hook)) slot_set_value_with_hook_1(sc, Slot, T_Nmv(Value)); else slot_set_value(Slot, T_Nmv(Value));} while (0) -#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt) -#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val) -#define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Nmv(Val); slot_set_has_pending_value(p);} while (0) -#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Nmv(Val) -#if S7_DEBUGGING -static s7_pointer slot_pending_value(s7_pointer p) \ - {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "%s[%d]: slot: no pending value\n", __func__, __LINE__); abort(); return(NULL);} -static s7_pointer slot_expression(s7_pointer p) \ - {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "%s[%d]: slot: no expression\n", __func__, __LINE__); abort(); return(NULL);} -#else -#define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value -#define slot_expression(p) (T_Slt(p))->object.slt.expr -#endif -#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Ext(Val); slot_set_has_expression(p);} while (0) -#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Ext(Val) -#define slot_setter(p) T_Prc(T_Slt(p)->object.slt.pending_value) -#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.pending_value = T_Prc(Val) -#if S7_DEBUGGING -#define tis_slot(p) ((p) && (T_Slt(p))) -#else -#define tis_slot(p) (p) /* used for loop through let slots which end in nil, not for general slot recognition */ -#endif -#define slot_end(sc) NULL -#define is_slot_end(p) (!(p)) - -#define is_syntax(p) (type(p) == T_SYNTAX) -#define syntax_symbol(p) T_Sym((T_Syn(p))->object.syn.symbol) -#define syntax_set_symbol(p, Sym) (T_Syn(p))->object.syn.symbol = T_Sym(Sym) -#define syntax_opcode(p) (T_Syn(p))->object.syn.op -#define syntax_min_args(p) (T_Syn(p))->object.syn.min_args -#define syntax_max_args(p) (T_Syn(p))->object.syn.max_args -#define syntax_documentation(p) (T_Syn(p))->object.syn.documentation -#define pair_set_syntax_op(p, X) do {set_optimize_op(p, X); set_syntactic_pair(p);} while (0) -#define symbol_syntax_op_checked(p) ((is_syntactic_pair(p)) ? optimize_op(p) : symbol_syntax_op(car(p))) -#define symbol_syntax_op(p) syntax_opcode(global_value(p)) -#define is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == initial_value(sc->quasiquote_symbol))) - -#define INITIAL_ROOTLET_SIZE 512 -#define let_id(p) (T_Lid(p))->object.envr.id -#define let_set_id(p, Id) (T_Lid(p))->object.envr.id = Id -#define is_let(p) (type(p) == T_LET) -#define is_let_unchecked(p) (unchecked_type(p) == T_LET) -#define let_slots(p) T_Sln((T_Let(p))->object.envr.slots) -#define let_outlet(p) T_Lid((T_Let(p))->object.envr.nxt) -#define let_set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Lid(ol) -#if S7_DEBUGGING - #define let_set_slots(p, Slot) do {if ((!in_heap(p)) && (Slot) && (in_heap(Slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", __func__, __LINE__); \ - T_Let(p)->object.envr.slots = T_Sln(Slot);} while (0) - #define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__) - #define S_Let(p, role) check_let_set(p, role, __func__, __LINE__) -#else - #define let_set_slots(p, Slot) (T_Let(p))->object.envr.slots = T_Sln(Slot) - #define C_Let(p, role) p - #define S_Let(p, role) p -#endif -#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.envr.edat.efnc.function) -#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.function = T_Sym(F) -#define set_curlet(Sc, P) Sc->curlet = T_Lid(P) - -#define let_baffle_key(p) (T_Let(p))->object.envr.edat.key -#define set_let_baffle_key(p, K) (T_Let(p))->object.envr.edat.key = K - -#define let_line(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.line -#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.envr.edat.efnc.line = L -#define let_file(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.file -#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.file = F - -#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.envr.edat.dox.dox1) -#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox1 = T_Slt(S); set_has_dox_slot1(p);} while (0) -#define let_dox_slot2(p) T_Sld((C_Let(p, L_DOX))->object.envr.edat.dox.dox2) -#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox2 = T_Slt(S); set_has_dox_slot2(p);} while (0) -#define let_dox_slot2_unchecked(p) T_Sld(C_Let(p, L_DOX)->object.envr.edat.dox.dox2) -#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.envr.edat.dox.dox2 = T_Sld(S); set_has_dox_slot2(p);} while (0) -#define let_dox1_value(p) slot_value(let_dox_slot1(p)) -#define let_dox2_value(p) slot_value(let_dox_slot2(p)) - -#define unique_name(p) (p)->object.unq.name /* not T_Uniq(p) here -- see make_unique */ -#define unique_name_length(p) (p)->object.unq.len -#define is_unspecified(p) (type(p) == T_UNSPECIFIED) -#define unique_car(p) (p)->object.unq.car -#define unique_cdr(p) (p)->object.unq.cdr - -#define is_undefined(p) (type(p) == T_UNDEFINED) -#define undefined_name(p) (T_Undf(p))->object.undef.name -#define undefined_name_length(p) (T_Undf(p))->object.undef.len -#define undefined_set_name_length(p, L) (T_Undf(p))->object.undef.len = L -#define eof_name(p) (T_Eof(p))->object.eof.name -#define eof_name_length(p) (T_Eof(p))->object.eof.len - -#define is_any_vector(p) t_vector_p[type(p)] -#define is_normal_vector(p) (type(p) == T_VECTOR) -#define vector_length(p) (p)->object.vector.length -#define unchecked_vector_elements(p) (p)->object.vector.elements.objects -#define unchecked_vector_element(p, i) ((p)->object.vector.elements.objects[i]) -#define vector_element(p, i) ((T_Nvc(p))->object.vector.elements.objects[i]) -#define vector_elements(p) (T_Nvc(p))->object.vector.elements.objects -#define any_vector_elements(p) (T_Vec(p))->object.vector.elements.objects -#define vector_getter(p) (T_Vec(p))->object.vector.vget -#define vector_setter(p) (T_Vec(p))->object.vector.setv.vset -#define vector_block(p) (T_Vec(p))->object.vector.block -#define unchecked_vector_block(p) p->object.vector.block - -#define typed_vector_typer(p) T_Prc((T_Vec(p))->object.vector.setv.fset) -#define typed_vector_set_typer(p, Fnc) (T_Vec(p))->object.vector.setv.fset = T_Prc(Fnc) -#define typed_vector_gc_mark(p) ((is_c_function(typed_vector_typer(p))) ? c_function_marker(typed_vector_typer(p)) : mark_typed_vector_1) -#define typed_vector_typer_call(sc, p, Args) \ - ((is_c_function(typed_vector_typer(p))) ? c_function_call(typed_vector_typer(p))(sc, Args) : s7_apply_function(sc, typed_vector_typer(p), Args)) - -#define is_int_vector(p) (type(p) == T_INT_VECTOR) -#define int_vector(p, i) ((T_Ivc(p))->object.vector.elements.ints[i]) -#define int_vector_ints(p) (T_Ivc(p))->object.vector.elements.ints - -#define is_float_vector(p) (type(p) == T_FLOAT_VECTOR) -#define float_vector(p, i) ((T_Fvc(p))->object.vector.elements.floats[i]) -#define float_vector_floats(p) (T_Fvc(p))->object.vector.elements.floats - -#define is_byte_vector(p) (type(p) == T_BYTE_VECTOR) -#define byte_vector_length(p) (T_BVc(p))->object.vector.length -#define byte_vector_bytes(p) (T_BVc(p))->object.vector.elements.bytes -#define byte_vector(p, i) ((T_BVc(p))->object.vector.elements.bytes[i]) -#define is_string_or_byte_vector(p) ((type(p) == T_STRING) || (type(p) == T_BYTE_VECTOR)) - -#define vector_dimension_info(p) ((vdims_t *)(T_Vec(p))->object.vector.block->ex.ex_info) -#define vector_set_dimension_info(p, d) (T_Vec(p))->object.vector.block->ex.ex_info = (void *)d -#define vector_ndims(p) vdims_rank(vector_dimension_info(p)) -#define vector_dimension(p, i) vdims_dims(vector_dimension_info(p))[i] -#define vector_dimensions(p) vdims_dims(vector_dimension_info(p)) -#define vector_offset(p, i) vdims_offsets(vector_dimension_info(p))[i] -#define vector_offsets(p) vdims_offsets(vector_dimension_info(p)) -#define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1) -#define vector_has_dimension_info(p) (vector_dimension_info(p)) - -#define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym)) -#define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect) - -#define rootlet_element(p, i) unchecked_vector_element(p, i) -#define rootlet_elements(p) unchecked_vector_elements(p) -#define rootlet_block(p) unchecked_vector_block(p) - -#define stack_element(p, i) unchecked_vector_element(T_Stk(p), i) -#define stack_elements(p) unchecked_vector_elements(T_Stk(p)) -#define stack_block(p) unchecked_vector_block(T_Stk(p)) -#define current_stack_top(Sc) ((Sc)->stack_end - (Sc)->stack_start) -#define temp_stack_top(p) (T_Stk(p))->object.stk.top -/* #define stack_flags(p) (T_Stk(p))->object.stk.flags */ -#define stack_clear_flags(p) (T_Stk(p))->object.stk.flags = 0 -#define stack_has_pairs(p) (((T_Stk(p))->object.stk.flags & 1) != 0) -#define stack_set_has_pairs(p) (T_Stk(p))->object.stk.flags |= 1 -#define stack_has_counters(p) (((T_Stk(p))->object.stk.flags & 2) != 0) -#define stack_set_has_counters(p) (T_Stk(p))->object.stk.flags |= 2 - -#define is_hash_table(p) (type(p) == T_HASH_TABLE) -#define is_mutable_hash_table(p) ((full_type(T_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE) -#define hash_table_mask(p) (T_Hsh(p))->object.hasher.mask -#define hash_table_block(p) (T_Hsh(p))->object.hasher.block -#define unchecked_hash_table_block(p) p->object.hasher.block -#define hash_table_set_block(p, b) (T_Hsh(p))->object.hasher.block = b -#define hash_table_element(p, i) (T_Hsh(p))->object.hasher.elements[i] -#define hash_table_elements(p) (T_Hsh(p))->object.hasher.elements /* block data (dx) */ -#define hash_table_entries(p) hash_table_block(p)->nx.nx_int -#define hash_table_checker(p) (T_Hsh(p))->object.hasher.hash_func -#define hash_table_mapper(p) (T_Hsh(p))->object.hasher.loc -#define hash_table_procedures(p) T_Lst(hash_table_block(p)->ex.ex_ptr) -#define hash_table_set_procedures(p, Lst) hash_table_block(p)->ex.ex_ptr = T_Lst(Lst) /* both the checker/mapper: car/cdr, and the two typers (opt/opt2) */ -#define hash_table_procedures_checker(p) car(hash_table_procedures(p)) -#define hash_table_procedures_mapper(p) cdr(hash_table_procedures(p)) -#define hash_table_set_procedures_checker(p, f) set_car(hash_table_procedures(p), f) -#define hash_table_set_procedures_mapper(p, f) set_cdr(hash_table_procedures(p), f) -#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p))) -#define hash_table_key_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.opt1 -#define hash_table_set_key_typer(p, Fnc) set_opt1_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc)) -#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p))) -#define hash_table_value_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.o2.opt2 -#define hash_table_set_value_typer(p, Fnc) set_opt2_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc)) -#define weak_hash_iters(p) hash_table_block(p)->ln.tag - -#if S7_DEBUGGING -#define T_Itr_Pos(p) titr_pos(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Len(p) titr_len(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Hash(p) titr_hash(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Let(p) titr_let(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Pair(p) titr_pair(sc, T_Itr(p), __func__, __LINE__) -#else -#define T_Itr_Pos(p) p -#define T_Itr_Len(p) p -#define T_Itr_Hash(p) p -#define T_Itr_Let(p) p -#define T_Itr_Pair(p) p -#endif - -#define is_iterator(p) (type(p) == T_ITERATOR) -#define iterator_sequence(p) (T_Itr(p))->object.iter.obj -#define iterator_position(p) (T_Itr_Pos(p))->object.iter.lc.loc -#define iterator_length(p) (T_Itr_Len(p))->object.iter.lw.len -#define iterator_next(p) (T_Itr(p))->object.iter.next -#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ -#define iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow) -#define iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val) -#define iterator_hash_current(p) (T_Itr_Hash(p))->object.iter.lw.hcur -#define iterator_current(p) (T_Itr(p))->object.iter.cur -#define iterator_current_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.lcur) -#define iterator_set_current_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.lcur = T_Sln(Val) -#define iterator_let_cons(p) (T_Itr_Let(p))->object.iter.cur - -#define ITERATOR_END eof_object -#define ITERATOR_END_NAME "#" - -#define is_input_port(p) (type(p) == T_INPUT_PORT) -#define is_output_port(p) (type(p) == T_OUTPUT_PORT) -#define port_port(p) (T_Prt(p))->object.prt.port -#define is_string_port(p) (port_type(p) == STRING_PORT) -#define is_file_port(p) (port_type(p) == FILE_PORT) -#define is_function_port(p) (port_type(p) == FUNCTION_PORT) -#define port_filename_block(p) port_port(p)->filename_block -#define port_filename(p) port_port(p)->filename -#define port_filename_length(p) port_port(p)->filename_length -#define port_file(p) port_port(p)->file -#define port_data_block(p) port_port(p)->block -#define unchecked_port_data_block(p) p->object.prt.port->block -#define port_line_number(p) port_port(p)->line_number -#define port_file_number(p) port_port(p)->file_number -#define port_data(p) (T_Prt(p))->object.prt.data -#define port_data_size(p) (T_Prt(p))->object.prt.size -#define port_position(p) (T_Prt(p))->object.prt.point -#define port_block(p) (T_Prt(p))->object.prt.block -#define port_type(p) port_port(p)->ptype -#define port_is_closed(p) port_port(p)->is_closed -#define port_set_closed(p, Val) port_port(p)->is_closed = Val /* this can't be a type bit because sweep checks it after the type has been cleared */ -#define port_needs_free(p) port_port(p)->needs_free -#define port_next(p) port_block(p)->nx.next -#define port_output_function(p) port_port(p)->output_function /* these two are for function ports */ -#define port_input_function(p) port_port(p)->input_function -#define port_string_or_function(p) port_port(p)->orig_str -#define port_set_string_or_function(p, S) port_port(p)->orig_str = S - -#define current_input_port(Sc) Sc->input_port -#define set_current_input_port(Sc, P) Sc->input_port = P -#define current_output_port(Sc) Sc->output_port -#define set_current_output_port(Sc, P) Sc->output_port = P - -#define port_read_character(p) port_port(p)->pf->read_character -#define port_read_line(p) port_port(p)->pf->read_line -#define port_display(p) port_port(p)->pf->displayer -#define port_write_character(p) port_port(p)->pf->write_character -#define port_write_string(p) port_port(p)->pf->write_string -#define port_read_semicolon(p) port_port(p)->pf->read_semicolon -#define port_read_white_space(p) port_port(p)->pf->read_white_space -#define port_read_name(p) port_port(p)->pf->read_name -#define port_read_sharp(p) port_port(p)->pf->read_sharp -#define port_close(p) port_port(p)->pf->close_port - -#define is_c_function(f) (type(f) >= T_C_FUNCTION) -#define is_c_function_star(f) (type(f) == T_C_FUNCTION_STAR) -#define is_any_c_function(f) (type(f) >= T_C_FUNCTION_STAR) -#define is_safe_c_function(f) ((is_c_function(f)) && (is_safe_procedure(f))) -#define c_function_data(f) (T_Fnc(f))->object.fnc.c_proc -#define c_function_call(f) (T_Fnc(f))->object.fnc.ff -#define c_function_min_args(f) (T_Fnc(f))->object.fnc.required_args -#define c_function_optional_args(f) (T_Fnc(f))->object.fnc.optional_args -#define c_function_max_args(f) (T_Fnc(f))->object.fnc.all_args -#define c_function_is_aritable(f, N) ((c_function_min_args(f) <= N) && (c_function_max_args(f) >= N)) -#define c_function_name(f) c_function_data(f)->name -#define c_function_name_length(f) c_function_data(f)->name_length -#define c_function_documentation(f) c_function_data(f)->doc -#define c_function_signature(f) c_function_data(f)->signature -#define c_function_setter(f) T_Prc(c_function_data(f)->setter) -#define c_function_set_setter(f, Val) c_function_data(f)->setter = T_Prc(Val) -#define c_function_class(f) c_function_data(f)->id -#define c_function_chooser(f) c_function_data(f)->chooser -#define c_function_base(f) T_Fnc(c_function_data(f)->generic_ff) -#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_Fnc(Val) -#define c_function_marker(f) c_function_data(f)->cam.marker /* the mark function for the vector (mark_vector_1 etc) */ -#define c_function_set_marker(f, Val) c_function_data(f)->cam.marker = Val -#define c_function_symbol(f) c_function_data(f)->sam.c_sym - -#define c_function_bool_setter(f) c_function_data(f)->dam.bool_setter -#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = Val - -#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults -#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args -#define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names - -#define set_c_function(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0) -#define c_function_opt_data(f) c_function_data(f)->opt_data - -#define is_c_macro(p) (type(p) == T_C_MACRO) -#define c_macro_data(f) (T_CMac(f))->object.fnc.c_proc -#define c_macro_call(f) (T_CMac(f))->object.fnc.ff -#define c_macro_name(f) c_macro_data(f)->name -#define c_macro_name_length(f) c_macro_data(f)->name_length -#define c_macro_min_args(f) (T_CMac(f))->object.fnc.required_args -#define c_macro_max_args(f) (T_CMac(f))->object.fnc.all_args -#define c_macro_setter(f) T_Prc(c_macro_data(f)->setter) -#define c_macro_set_setter(f, Val) c_macro_data(f)->setter = T_Prc(Val) -#define could_be_macro_setter(Obj) t_macro_setter_p[type(Obj)] - -#define is_random_state(p) (type(p) == T_RANDOM_STATE) -#define random_gmp_state(p) (p)->object.rng.state /* sweep sees free cell in big_random_state gc_list and needs to call gmprandclear on its value */ -#define random_seed(p) (T_Ran(p))->object.rng.seed -#define random_carry(p) (T_Ran(p))->object.rng.carry - -#define continuation_block(p) (T_Con(p))->object.cwcc.block -#define continuation_stack(p) T_Stk(T_Con(p)->object.cwcc.stack) -#define continuation_set_stack(p, Val) (T_Con(p))->object.cwcc.stack = T_Stk(Val) -#define continuation_stack_end(p) (T_Con(p))->object.cwcc.stack_end -#define continuation_stack_start(p) (T_Con(p))->object.cwcc.stack_start -#define continuation_stack_top(p) (continuation_stack_end(p) - continuation_stack_start(p)) -#define continuation_op_stack(p) (T_Con(p))->object.cwcc.op_stack -#define continuation_stack_size(p) continuation_block(p)->nx.ix.i1 -#define continuation_op_loc(p) continuation_block(p)->nx.ix.i2 -#define continuation_op_size(p) continuation_block(p)->ln.tag -#define continuation_key(p) continuation_block(p)->ex.ckey -/* this can overflow int32_t -- baffle_key is s7_int, so ckey should be also */ -#define continuation_name(p) continuation_block(p)->dx.d_ptr - -#define call_exit_goto_loc(p) (T_Got(p))->object.rexit.goto_loc -#define call_exit_op_loc(p) (T_Got(p))->object.rexit.op_stack_loc -#define call_exit_active(p) (T_Got(p))->object.rexit.active -#define call_exit_name(p) (T_Got(p))->object.rexit.name - -#define is_continuation(p) (type(p) == T_CONTINUATION) -#define is_goto(p) (type(p) == T_GOTO) -#define is_macro(p) (type(p) == T_MACRO) -#define is_macro_star(p) (type(p) == T_MACRO_STAR) -#define is_bacro(p) (type(p) == T_BACRO) -#define is_bacro_star(p) (type(p) == T_BACRO_STAR) -#define is_either_macro(p) ((is_macro(p)) || (is_macro_star(p))) -#define is_either_bacro(p) ((type(p) == T_BACRO) || (type(p) == T_BACRO_STAR)) - -#define is_closure(p) (type(p) == T_CLOSURE) -#define is_closure_star(p) (type(p) == T_CLOSURE_STAR) -#define closure_args(p) T_Arg((T_Clo(p))->object.func.args) -#define closure_set_args(p, Val) (T_Clo(p))->object.func.args = T_Arg(Val) -#define closure_body(p) (T_Pair((T_Clo(p))->object.func.body)) -#define closure_set_body(p, Val) (T_Clo(p))->object.func.body = T_Pair(Val) -#define closure_let(p) T_Lid((T_Clo(p))->object.func.env) -#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Lid(L) -#define closure_arity(p) (T_Clo(p))->object.func.arity -#define closure_set_arity(p, A) (T_Clo(p))->object.func.arity = A - -#define closure_setter(p) (T_Prc((T_Clo(p))->object.func.setter)) -#define closure_set_setter(p, Val) (T_Clo(p))->object.func.setter = T_Prc(Val) -#define closure_map_list(p) (T_Pair((T_Clo(p))->object.func.setter)) -#define closure_set_map_list(p, Val) (T_Clo(p))->object.func.setter = T_Pair(Val) -#define closure_setter_or_map_list(p) (T_Clo(p)->object.func.setter) -/* closure_map_list refers to a cyclic list detector in map; since in this case map makes a new closure for its own use, - * closure_map_list doesn't collide with closure_setter. - */ - -#define CLOSURE_ARITY_NOT_SET 0x40000000 -#define MAX_ARITY 0x20000000 -#define closure_arity_unknown(p) (closure_arity(p) == CLOSURE_ARITY_NOT_SET) -#define is_thunk(Sc, Fnc) ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0))) - -#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, T_Clo(p)))) - -#define catch_tag(p) (T_Cat(p))->object.rcatch.tag -#define catch_goto_loc(p) (T_Cat(p))->object.rcatch.goto_loc -#define catch_op_loc(p) (T_Cat(p))->object.rcatch.op_stack_loc -#define catch_cstack(p) (T_Cat(p))->object.rcatch.cstack -#define catch_handler(p) T_Ext((T_Cat(p))->object.rcatch.handler) -#define catch_set_handler(p, val) (T_Cat(p))->object.rcatch.handler = T_Ext(val) - -#define dynamic_wind_state(p) (T_Dyn(p))->object.winder.state -#define dynamic_wind_in(p) (T_Dyn(p))->object.winder.in -#define dynamic_wind_out(p) (T_Dyn(p))->object.winder.out -#define dynamic_wind_body(p) (T_Dyn(p))->object.winder.body - -#define is_c_object(p) (type(p) == T_C_OBJECT) -#define c_object_value(p) (T_Obj(p))->object.c_obj.value -#define c_object_type(p) (T_Obj(p))->object.c_obj.type -#define c_object_let(p) T_Lid((T_Obj(p))->object.c_obj.e) -#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Lid(L) -#define c_object_s7(p) (T_Obj(p))->object.c_obj.sc - -#define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))] -#define c_object_free(Sc, p) c_object_info(Sc, p)->free -#define c_object_mark(Sc, p) c_object_info(Sc, p)->mark -#define c_object_gc_mark(Sc, p) c_object_info(Sc, p)->gc_mark -#define c_object_gc_free(Sc, p) c_object_info(Sc, p)->gc_free -#define c_object_ref(Sc, p) c_object_info(Sc, p)->ref -#define c_object_getf(Sc, p) c_object_info(Sc, p)->getter -#define c_object_set(Sc, p) c_object_info(Sc, p)->set -#define c_object_setf(Sc, p) c_object_info(Sc, p)->setter -#if (!DISABLE_DEPRECATED) - #define c_object_print(Sc, p) c_object_info(Sc, p)->print -#endif -#define c_object_len(Sc, p) c_object_info(Sc, p)->length -#define c_object_eql(Sc, p) c_object_info(Sc, p)->eql -#define c_object_equal(Sc, p) c_object_info(Sc, p)->equal -#define c_object_equivalent(Sc, p) c_object_info(Sc, p)->equivalent -#define c_object_fill(Sc, p) c_object_info(Sc, p)->fill -#define c_object_copy(Sc, p) c_object_info(Sc, p)->copy -#define c_object_reverse(Sc, p) c_object_info(Sc, p)->reverse -#define c_object_to_list(Sc, p) c_object_info(Sc, p)->to_list -#define c_object_to_string(Sc, p) c_object_info(Sc, p)->to_string -#define c_object_scheme_name(Sc, p) T_Str(c_object_info(Sc, p)->scheme_name) - -#define c_pointer(p) (T_Ptr(p))->object.cptr.c_pointer -#define c_pointer_type(p) (T_Ptr(p))->object.cptr.c_type -#define c_pointer_info(p) (T_Ptr(p))->object.cptr.info -#define c_pointer_weak1(p) (T_Ptr(p))->object.cptr.weak1 -#define c_pointer_weak2(p) (T_Ptr(p))->object.cptr.weak2 -#define c_pointer_set_weak1(p, q) (T_Ptr(p))->object.cptr.weak1 = T_Ext(q) -#define c_pointer_set_weak2(p, q) (T_Ptr(p))->object.cptr.weak2 = T_Ext(q) -#define is_c_pointer(p) (type(p) == T_C_POINTER) - -#define is_counter(p) (type(p) == T_COUNTER) -#define counter_result(p) (T_Ctr(p))->object.ctr.result -#define counter_set_result(p, Val) (T_Ctr(p))->object.ctr.result = T_Ext(Val) -#define counter_list(p) (T_Ctr(p))->object.ctr.list -#define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Ext(Val) -#define counter_capture(p) (T_Ctr(p))->object.ctr.cap -#define counter_set_capture(p, Val) (T_Ctr(p))->object.ctr.cap = Val -#define counter_let(p) T_Lid((T_Ctr(p))->object.ctr.env) -#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Lid(L) -#define counter_slots(p) T_Sln(T_Ctr(p)->object.ctr.slots) -#define counter_set_slots(p, Val) (T_Ctr(p))->object.ctr.slots = T_Sln(Val) - -#if S7_DEBUGGING -#define init_temp(p, Val) do {if (p != sc->unused) fprintf(stderr, "%s[%d]: temp %s\n", __func__, __LINE__, display(p)); p = T_Ext(Val);} while (0) -#else -#define init_temp(p, Val) p = Val -#endif - -#if __cplusplus && HAVE_COMPLEX_NUMBERS - using namespace std; /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */ - typedef complex s7_complex; - static s7_double Real(complex x) {return(real(x));} /* protect the C++ name */ - static s7_double Imag(complex x) {return(imag(x));} -#endif - -#define integer(p) (T_Int(p))->object.number.integer_value -#define set_integer(p, x) integer(p) = x -#define real(p) (T_Rel(p))->object.number.real_value -#define set_real(p, x) real(p) = x -#define numerator(p) (T_Frc(p))->object.number.fraction_value.numerator -#define denominator(p) (T_Frc(p))->object.number.fraction_value.denominator -#define fraction(p) (((long_double)numerator(p)) / ((long_double)denominator(p))) -#define inverted_fraction(p) (((long_double)denominator(p)) / ((long_double)numerator(p))) -#define real_part(p) (T_Cmp(p))->object.number.complex_value.rl -#define set_real_part(p, x) real_part(p) = x -#define imag_part(p) (T_Cmp(p))->object.number.complex_value.im -#define set_imag_part(p, x) imag_part(p) = x -#if HAVE_COMPLEX_NUMBERS - #define to_c_complex(p) CMPLX(real_part(p), imag_part(p)) -#endif - -#if WITH_GMP -#define big_integer(p) ((T_Bgi(p))->object.number.bgi->n) -#define big_integer_nxt(p) (p)->object.number.bgi->nxt -#define big_integer_bgi(p) (p)->object.number.bgi -#define big_ratio(p) ((T_Bgf(p))->object.number.bgr->q) -#define big_ratio_nxt(p) (p)->object.number.bgr->nxt -#define big_ratio_bgr(p) (p)->object.number.bgr -#define big_real(p) ((T_Bgr(p))->object.number.bgf->x) -#define big_real_nxt(p) (p)->object.number.bgf->nxt -#define big_real_bgf(p) (p)->object.number.bgf -#define big_complex(p) ((T_Bgz(p))->object.number.bgc->z) -#define big_complex_nxt(p) (p)->object.number.bgc->nxt -#define big_complex_bgc(p) (p)->object.number.bgc -#endif - -#if S7_DEBUGGING -const char *display(s7_pointer obj) -{ - const char *res; - if (!has_methods(obj)) - return(string_value(s7_object_to_string(cur_sc, obj, false))); - clear_type_bit(obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref9 */ - res = string_value(s7_object_to_string(cur_sc, obj, false)); - set_type_bit(obj, T_HAS_METHODS); /* same for set_has_methods */ - return(res); -} -#else -#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) -#endif -#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80)) - -#if S7_DEBUGGING -static void set_type_1(s7_pointer p, uint64_t f, const char *func, int32_t line) -{ - p->alloc_line = line; - p->alloc_func = func; - p->alloc_type = f; - p->explicit_free_line = 0; - p->uses++; - if (((f) & TYPE_MASK) == T_FREE) - fprintf(stderr, "%d: set free, %p type to %" PRIx64 "\n", __LINE__, p, (int64_t)(f)); - else - if (((f) & TYPE_MASK) >= NUM_TYPES) - fprintf(stderr, "%d: set invalid type, %p type to %" PRIx64 "\n", __LINE__, p, (int64_t)(f)); - else - { - if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (uint64_t)(f)))) - { - fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, unchecked_type(p), (int64_t)(f)); - abort(); - } - if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0)) - fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", __func__, __LINE__); - } - full_type(p) = f; -} -#endif - -#define number_name(p) (char *)((T_Num(p))->object.number_name.name + 1) -#define number_name_length(p) (T_Num(p))->object.number_name.name[0] - -static void set_number_name(s7_pointer p, const char *name, int32_t len) -{ - /* if no number name: teq +110 tread +30 tform +90 */ - if ((len >= 0) && (len < NUMBER_NAME_SIZE) && (!is_mutable_number(p))) - { - set_has_number_name(p); - number_name_length(p) = (uint8_t)len; - memcpy((void *)number_name(p), (void *)name, len); - (number_name(p))[len] = 0; - } -} - -static s7_int s7_int_min = 0; -static int32_t s7_int_digits_by_radix[17]; - -#define S7_INT_BITS 63 - -#define S7_INT64_MAX 9223372036854775807LL -#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL) - -#define S7_INT32_MAX 2147483647LL -#define S7_INT32_MIN (-S7_INT32_MAX - 1LL) - -static void init_int_limits(void) -{ -#if WITH_GMP - #define S7_LOG_INT64_MAX 36.736800 -#else - /* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) (using 63 and 31 bits) */ - #define S7_LOG_INT64_MAX 43.668274 -#endif - s7_int_min = S7_INT64_MIN; /* see comment in s7_make_ratio -- we're trying to hack around a gcc bug (9.2.1 Ubuntu) */ - s7_int_digits_by_radix[0] = 0; - s7_int_digits_by_radix[1] = 0; - for (int32_t i = 2; i < 17; i++) - s7_int_digits_by_radix[i] = (int32_t)(floor(S7_LOG_INT64_MAX / log((double)i))); -} - -static s7_pointer make_permanent_integer(s7_int i) -{ - s7_pointer p = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* Calloc to clear name */ - full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; - integer(p) = i; - return(p); -} - -#define NUM_CHARS 256 -#ifndef NUM_SMALL_INTS - #define NUM_SMALL_INTS 8192 - /* 65536: tshoot -6, tvect -50, dup -26, trclo -27, tmap -48, tsort -14, tlet -16, trec -58, thash -40 */ -#else -#if (NUM_SMALL_INTS < NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS, as does the byte_vector stuff (256) */ - #error NUM_SMALL_INTS is less than NUM_CHARS which will not work -#endif -#endif - -static bool t_number_separator_p[NUM_CHARS]; -static s7_pointer *small_ints = NULL; -#define small_int(Val) small_ints[Val] -#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ - -static s7_pointer real_zero, real_NaN, complex_NaN, real_pi, real_one, arity_not_set, max_arity, real_infinity, real_minus_infinity; -static s7_pointer int_zero, int_one, int_two, int_three, minus_one, minus_two, mostfix, leastfix; - -static void init_small_ints(void) -{ - const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"}; - s7_cell *cells = (s7_cell *)Malloc(NUM_SMALL_INTS * sizeof(s7_cell)); /* was calloc 14-Apr-22 */ - small_ints = (s7_pointer *)Malloc(NUM_SMALL_INTS * sizeof(s7_pointer)); - for (int32_t i = 0; i < NUM_SMALL_INTS; i++) - { - s7_pointer p; - small_ints[i] = &cells[i]; - p = small_ints[i]; - full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; - integer(p) = i; - } - for (int32_t i = 0; i < 10; i++) - set_number_name(small_ints[i], ones[i], 1); - - /* setup a few other numbers while we're here */ - #define EXTRA_NUMBERS 11 - cells = (s7_cell *)Calloc(EXTRA_NUMBERS, sizeof(s7_cell)); - - #define init_integer(Ptr, Num, Name, Name_Len) \ - do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0) - #define init_integer_no_name(Ptr, Num) \ - do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num);} while (0) - - #define init_real(Ptr, Num, Name, Name_Len) \ - do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0) - #define init_real_no_name(Ptr, Num) \ - do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num);} while (0) - - #define init_complex(Ptr, Real, Imag, Name, Name_Len) \ - do {set_full_type(Ptr, T_COMPLEX | T_IMMUTABLE | T_UNHEAP); set_real_part(Ptr, Real); set_imag_part(Ptr, Imag); set_number_name(Ptr, Name, Name_Len);} while (0) - - real_zero = &cells[0]; init_real(real_zero, 0.0, "0.0", 3); - real_one = &cells[1]; init_real(real_one, 1.0, "1.0", 3); - real_NaN = &cells[2]; init_real(real_NaN, NAN, "+nan.0", 6); - complex_NaN = &cells[10]; init_complex(complex_NaN, NAN, NAN, "+nan.0+nan.0i", 13); - real_infinity = &cells[3]; init_real(real_infinity, INFINITY, "+inf.0", 6); - real_minus_infinity = &cells[4]; init_real(real_minus_infinity, -INFINITY, "-inf.0", 6); - real_pi = &cells[5]; init_real_no_name(real_pi, 3.1415926535897932384626433832795029L); - - arity_not_set = &cells[6]; init_integer_no_name(arity_not_set, CLOSURE_ARITY_NOT_SET); - max_arity = &cells[7]; init_integer_no_name(max_arity, MAX_ARITY); - minus_one = &cells[8]; init_integer(minus_one, -1, "-1", 2); - minus_two = &cells[9]; init_integer(minus_two, -2, "-2", 2); - int_zero = small_ints[0]; - int_one = small_ints[1]; - int_two = small_ints[2]; - int_three = small_ints[3]; - - mostfix = make_permanent_integer(S7_INT64_MAX); - leastfix = make_permanent_integer(s7_int_min); - set_number_name(mostfix, "9223372036854775807", 19); - set_number_name(leastfix, "-9223372036854775808", 20); - - for (int32_t i = 0; i < NUM_CHARS; i++) t_number_separator_p[i] = true; - t_number_separator_p[(uint8_t)'i'] = false; - t_number_separator_p[(uint8_t)'+'] = false; - t_number_separator_p[(uint8_t)'-'] = false; - t_number_separator_p[(uint8_t)'/'] = false; - t_number_separator_p[(uint8_t)'@'] = false; - t_number_separator_p[(uint8_t)'.'] = false; - t_number_separator_p[(uint8_t)'e'] = false; - t_number_separator_p[(uint8_t)'E'] = false; -} - -#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len)) - - -/* -------------------------------------------------------------------------------- */ -#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__)) - static inline s7_int my_clock(void) - { - struct timespec ts; - clock_gettime(CLOCK_MONOTONIC, &ts); - /* coarse: 0.057u 0.007s, monotonic: 0.083u 0.007s, clock(): 0.624u 0.372s -- coarse since Linux 2.6.32, glibc > 2.17 - * FreeBSD has CLOCK_MONOTONIC_FAST in place of COARSE, OpenBSD and netBSD have neither - * clock_getres places 1 in tv_nsec in linux, so I assume I divide billion/tv_nsec - * MacOSX has clock_get_time, and after Sierra 10.12 has clock_gettime - * apparently we include /usr/include/AvailabilityMacros.h, then #if MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_12 - * Windows has QueryPerformanceCounter or something - * maybe just check for POSIX compatibility? - */ - return(ts.tv_sec * 1000000000 + ts.tv_nsec); /* accumulated into s7_int so this should be ok: s7.h gives it 64 bits */ - } - - static s7_int ticks_per_second(void) - { - struct timespec ts; - clock_getres(CLOCK_MONOTONIC, &ts); - return((ts.tv_nsec == 0) ? 1000000000 : (1000000000 / ts.tv_nsec)); - } -#else - #define my_clock clock /* but this is cpu time? */ - #define ticks_per_second() CLOCKS_PER_SEC -#endif - -#ifndef GC_TRIGGER_SIZE - #define GC_TRIGGER_SIZE 64 -#endif - -#if S7_DEBUGGING -static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line); -#define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__) -#else -static void try_to_call_gc(s7_scheme *sc); -#endif - -#define GC_STATS 1 -#define HEAP_STATS 2 -#define STACK_STATS 4 -#define PROTECTED_OBJECTS_STATS 8 - -#define show_gc_stats(Sc) ((Sc->gc_stats & GC_STATS) != 0) -#define show_stack_stats(Sc) ((Sc->gc_stats & STACK_STATS) != 0) -#define show_heap_stats(Sc) ((Sc->gc_stats & HEAP_STATS) != 0) -#define show_protected_objects_stats(Sc) ((Sc->gc_stats & PROTECTED_OBJECTS_STATS) != 0) - - -/* new_cell has to include the new cell's type. In the free list, it is 0 (T_FREE). If we remove it here, - * but then hit some error before setting the type, the GC sweep thinks it is a free cell already and - * does not return it to the free list: a memory leak. - */ -#if (!S7_DEBUGGING) -#define new_cell(Sc, Obj, Type) \ - do { \ - if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ - Obj = (*(--(Sc->free_heap_top))); \ - set_full_type(Obj, Type); \ - } while (0) - -#define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_full_type(Obj, Type);} while (0) - /* since sc->free_heap_trigger is GC_TRIGGER_SIZE above the free heap base, we don't need - * to check it repeatedly after the first such check. - */ -#else - -#define new_cell(Sc, Obj, Type) \ - do { \ - if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ - Obj = (*(--(Sc->free_heap_top))); \ - Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ - set_full_type(Obj, Type); \ - } while (0) - -#define new_cell_no_check(Sc, Obj, Type) \ - do { \ - Obj = (*(--(Sc->free_heap_top))); \ - if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "%s[%d]: free heap exhausted\n", __func__, __LINE__); abort();}\ - Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ - set_full_type(Obj, Type); \ - } while (0) -#endif - -/* #define gc_if_at_trigger(Sc) if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc) */ - -#if WITH_GCC -#define make_integer(Sc, N) \ - ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) -#define make_integer_unchecked(Sc, N) \ - ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell_no_check(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) - -#define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) -#define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) - -#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;}) -#define make_complex(Sc, R, I) \ - ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real(Sc, R) : \ - ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); }) - -#define real_to_double(Sc, X, Caller) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_REAL) ? real(_x_) : s7_number_to_real_with_caller(Sc, _x_, Caller)); }) -#define rational_to_double(Sc, X) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_INTEGER) ? (s7_double)integer(_x_) : fraction(_x_)); }) - -#else - -#define make_integer(Sc, N) s7_make_integer(Sc, N) -#define make_integer_unchecked(Sc, N) s7_make_integer(Sc, N) -#define make_real(Sc, X) s7_make_real(Sc, X) -#define make_real_unchecked(Sc, X) s7_make_real(Sc, X) -#define make_complex(Sc, R, I) s7_make_complex(Sc, R, I) -#define make_complex_not_0i(Sc, R, I) s7_make_complex(Sc, R, I) -#define real_to_double(Sc, X, Caller) s7_number_to_real_with_caller(Sc, X, Caller) -#define rational_to_double(Sc, X) s7_number_to_real(Sc, X) -#endif - -static s7_pointer wrap_integer(s7_scheme *sc, s7_int x) -{ - s7_pointer p; - if (is_small_int(x)) return(small_int(x)); - p = car(sc->integer_wrappers); - integer(p) = x; - sc->integer_wrappers = cdr(sc->integer_wrappers); - return(p); -} - -static s7_pointer wrap_real(s7_scheme *sc, s7_double x) -{ - s7_pointer p = car(sc->real_wrappers); - real(p) = x; - sc->real_wrappers = cdr(sc->real_wrappers); - return(p); -} - - -/* -------------------------------------------------------------------------------- - * local versions of some standard C library functions - * timing tests involving these are very hard to interpret, local_memset is faster using int64_t than int32_t - */ - -static void local_memset(void *s, uint8_t val, size_t n) -{ - uint8_t *s2; -#if S7_ALIGNED - s2 = (uint8_t *)s; -#else -#if (defined(__x86_64__) || defined(__i386__)) - if (n >= 8) - { - int64_t *s1 = (int64_t *)s; - size_t n8 = n >> 3; - int64_t ival = val | (val << 8) | (val << 16) | (((uint64_t)val) << 24); /* uint64_t casts make gcc/clang/fsanitize happy */ - ival = (((uint64_t)ival) << 32) | ival; - if ((n8 & 0x3) == 0) - while (n8 > 0) {LOOP_4(*s1++ = ival); n8 -= 4;} - else do {*s1++ = ival;} while (--n8 > 0); - n &= 7; - s2 = (uint8_t *)s1; - } - else s2 = (uint8_t *)s; -#else - s2 = (uint8_t *)s; -#endif -#endif - while (n > 0) - { - *s2++ = val; - n--; - } -} - -static inline s7_int safe_strlen(const char *str) /* this is safer than strlen, and slightly faster */ -{ - const char *tmp = str; - if ((!tmp) || (!(*tmp))) return(0); - for (; *tmp; ++tmp); - return(tmp - str); -} - -static char *copy_string_with_length(const char *str, s7_int len) -{ - char *newstr; - if ((S7_DEBUGGING) && ((len <= 0) || (!str))) fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, __LINE__, len, str); - if (len > (1LL << 48)) return(NULL); /* squelch an idiotic warning */ - newstr = (char *)Malloc(len + 1); - memcpy((void *)newstr, (void *)str, len); /* we check len != 0 above -- 24-Jan-22 */ - newstr[len] = '\0'; - return(newstr); -} - -static char *copy_string(const char *str) {return(copy_string_with_length(str, safe_strlen(str)));} - -#if 0 -static bool local_strcmp(const char *s1, const char *s2) -{ - while (true) - { - if (*s1 != *s2++) return(false); - if (*s1++ == 0) return(true); - } - return(true); -} -#else -#define local_strcmp(S1, S2) (strcmp(S1, S2) == 0) -/* I think libc strcmp is much faster than it used to be, and beats the code above */ -#endif - -#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) -/* scheme strings can have embedded nulls */ - -static bool safe_strcmp(const char *s1, const char *s2) -{ - if ((!s1) || (!s2)) return(s1 == s2); - return(local_strcmp(s1, s2)); -} - -static bool local_strncmp(const char *s1, const char *s2, size_t n) /* not strncmp because scheme strings can have embedded nulls */ -{ -#if ((!S7_ALIGNED) && (defined(__x86_64__) || defined(__i386__))) /* unaligned accesses are safe on i386 hardware, sez everyone */ - if (n >= 8) - { - size_t n8 = n >> 3; - int64_t *is1 = (int64_t *)s1, *is2 = (int64_t *)s2; - do {if (*is1++ != *is2++) return(false);} while (--n8 > 0); /* in tbig LOOP_4 is slower? */ - s1 = (const char *)is1; - s2 = (const char *)is2; - n &= 7; - } -#endif - while (n > 0) - { - if (*s1++ != *s2++) return(false); - n--; - } - return(true); -} - -#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len)) - -static Sentinel size_t catstrs(char *dst, size_t len, ...) /* NULL-terminated arg list */ -{ - const char *dend = (const char *)(dst + len - 1); /* -1 for null at end? */ - char *d = dst; - va_list ap; - while ((*d) && (d < dend)) d++; /* stop at NULL or end-of-buffer */ - va_start(ap, len); - for (const char *s = va_arg(ap, const char *); s != NULL; s = va_arg(ap, const char *)) - while ((*s) && (d < dend)) {*d++ = *s++;} - *d = '\0'; - va_end (ap); - return(d - dst); -} - -static Sentinel size_t catstrs_direct(char *dst, const char *s1, ...) -{ /* NULL-terminated arg list, dst is destination only (assumed empty), all args known to fit in dst */ - char *d = dst; - va_list ap; - va_start(ap, s1); - for (const char *s = s1; s != NULL; s = va_arg(ap, const char *)) - while (*s) {*d++ = *s++;} - *d = '\0'; - va_end (ap); - return(d - dst); -} - -static char *pos_int_to_str(s7_scheme *sc, s7_int num, s7_int *len, char endc) -{ - char *p = (char *)(sc->int_to_str3 + INT_TO_STR_SIZE - 1); - char *op = p; - *p-- = '\0'; - if (endc != '\0') *p-- = endc; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - (*len) = op - p; /* this includes the trailing #\null */ - return((char *)(p + 1)); -} - -static char *pos_int_to_str_direct(s7_scheme *sc, s7_int num) -{ - char *p = (char *)(sc->int_to_str4 + INT_TO_STR_SIZE - 1); - *p-- = '\0'; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - return((char *)(p + 1)); -} - -static char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num) -{ - char *p = (char *)(sc->int_to_str5 + INT_TO_STR_SIZE - 1); - *p-- = '\0'; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - return((char *)(p + 1)); -} - -#if WITH_GCC - #if S7_DEBUGGING - static s7_pointer lookup_1(s7_scheme *sc, s7_pointer symbol); - #define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, Sym), Sym, __LINE__, __func__) - static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func); - #define lookup_unexamined(Sc, Sym) lookup_1(Sc, Sym) - #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) - #else - static inline s7_pointer lookup(s7_scheme *sc, s7_pointer symbol); - #define lookup_unexamined(Sc, Sym) lookup(Sc, Sym) - #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) - #endif -#else - #define lookup_unexamined(Sc, Sym) s7_symbol_value(Sc, Sym) /* changed 3-Nov-22 -- we're using lookup_unexamined below to avoid the unbound_variable check */ - #define lookup_checked(Sc, Sym) lookup(Sc, Sym) -#endif - - -/* ---------------- evaluator ops ---------------- */ -/* C=constant, S=symbol, A=fx-callable, Q=quote, N=any number of next >= 1, FX=list of A's, P=parlous?, O=one form, M=multiform */ -enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as lower boundary marker */ - - OP_SAFE_C_NC, HOP_SAFE_C_NC, OP_SAFE_C_S, HOP_SAFE_C_S, - OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS, HOP_SAFE_C_CS, OP_SAFE_C_CQ, HOP_SAFE_C_CQ, - OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS, OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS, - OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC, OP_SAFE_C_CCS, HOP_SAFE_C_CCS, - OP_SAFE_C_NS, HOP_SAFE_C_NS, OP_SAFE_C_opNCq, HOP_SAFE_C_opNCq, OP_SAFE_C_opSq, HOP_SAFE_C_opSq, - OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq, - OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq, - OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq, - OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C, - OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq, - OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq, - OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq, HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq, - OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, - OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq, - OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS, - - OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_SA, HOP_SAFE_C_SA, OP_SAFE_C_AS, HOP_SAFE_C_AS, - OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC, OP_SAFE_C_AAA, HOP_SAFE_C_AAA, OP_SAFE_C_4A, HOP_SAFE_C_4A, - OP_SAFE_C_NA, HOP_SAFE_C_NA, OP_SAFE_C_ALL_CA, HOP_SAFE_C_ALL_CA, - OP_SAFE_C_SSA, HOP_SAFE_C_SSA, OP_SAFE_C_SAS, HOP_SAFE_C_SAS, OP_SAFE_C_SAA, HOP_SAFE_C_SAA, - OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA, OP_SAFE_C_ASS, HOP_SAFE_C_ASS, - OP_SAFE_C_CAC, HOP_SAFE_C_CAC, OP_SAFE_C_AGG, HOP_SAFE_C_AGG, - OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq, OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq, - OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_opAq_S, HOP_SAFE_C_opAq_S, OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, - OP_SAFE_C_STAR, HOP_SAFE_C_STAR, OP_SAFE_C_STAR_A, HOP_SAFE_C_STAR_A, - OP_SAFE_C_STAR_AA, HOP_SAFE_C_STAR_AA, OP_SAFE_C_STAR_NA, HOP_SAFE_C_STAR_NA, - - OP_SAFE_C_P, HOP_SAFE_C_P, OP_SAFE_C_PP, HOP_SAFE_C_PP, OP_SAFE_C_FF, HOP_SAFE_C_FF, OP_SAFE_C_SP, HOP_SAFE_C_SP, - OP_SAFE_C_CP, HOP_SAFE_C_CP, OP_SAFE_C_AP, HOP_SAFE_C_AP, OP_SAFE_C_PA, HOP_SAFE_C_PA, OP_SAFE_C_PS, HOP_SAFE_C_PS, - OP_SAFE_C_PC, HOP_SAFE_C_PC, OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_ANY_C_NP, HOP_ANY_C_NP, OP_SAFE_C_3P, HOP_SAFE_C_3P, - - OP_THUNK, HOP_THUNK, OP_THUNK_O, HOP_THUNK_O, OP_THUNK_ANY, HOP_THUNK_ANY, - OP_SAFE_THUNK, HOP_SAFE_THUNK, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A, OP_SAFE_THUNK_ANY, HOP_SAFE_THUNK_ANY, - - OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_O, HOP_CLOSURE_S_O, - OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_O, HOP_CLOSURE_A_O, OP_CLOSURE_P, HOP_CLOSURE_P, - OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, OP_CLOSURE_PP, HOP_CLOSURE_PP, - OP_CLOSURE_FA, HOP_CLOSURE_FA, OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SS_O, HOP_CLOSURE_SS_O, - OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_SC_O, HOP_CLOSURE_SC_O, - OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_3S_O, HOP_CLOSURE_3S_O, OP_CLOSURE_4S, HOP_CLOSURE_4S, OP_CLOSURE_4S_O, HOP_CLOSURE_4S_O, - OP_CLOSURE_AA, HOP_CLOSURE_AA, OP_CLOSURE_AA_O, HOP_CLOSURE_AA_O, OP_CLOSURE_3A, HOP_CLOSURE_3A, OP_CLOSURE_4A, HOP_CLOSURE_4A, - OP_CLOSURE_NA, HOP_CLOSURE_NA, OP_CLOSURE_ASS, HOP_CLOSURE_ASS, OP_CLOSURE_SAS, HOP_CLOSURE_SAS ,OP_CLOSURE_AAS, HOP_CLOSURE_AAS, - OP_CLOSURE_SAA, HOP_CLOSURE_SAA, OP_CLOSURE_ASA, HOP_CLOSURE_ASA, OP_CLOSURE_NS, HOP_CLOSURE_NS, - - OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_O, HOP_SAFE_CLOSURE_S_O, - OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC, - OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, OP_SAFE_CLOSURE_P_A, HOP_SAFE_CLOSURE_P_A, - OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP, - OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_O, HOP_SAFE_CLOSURE_A_O, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A, - OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC, - OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_O, HOP_SAFE_CLOSURE_SS_O, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A, - OP_SAFE_CLOSURE_SC, HOP_SAFE_CLOSURE_SC, OP_SAFE_CLOSURE_SC_O, HOP_SAFE_CLOSURE_SC_O, - OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA, OP_SAFE_CLOSURE_AA_O, HOP_SAFE_CLOSURE_AA_O, OP_SAFE_CLOSURE_AA_A, HOP_SAFE_CLOSURE_AA_A, - OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_SSA, HOP_SAFE_CLOSURE_SSA, - OP_SAFE_CLOSURE_AGG, HOP_SAFE_CLOSURE_AGG, OP_SAFE_CLOSURE_3A, HOP_SAFE_CLOSURE_3A, OP_SAFE_CLOSURE_NA, HOP_SAFE_CLOSURE_NA, - OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_NS, HOP_SAFE_CLOSURE_NS, /* safe_closure_4s gained very little */ - OP_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A, - /* ssa|saa|ns|na|3s|agg|3a|sc|ap|pa|pp_a ? thunk_o? op_closure_ns? */ - - OP_ANY_CLOSURE_3P, HOP_ANY_CLOSURE_3P, OP_ANY_CLOSURE_4P, HOP_ANY_CLOSURE_4P, OP_ANY_CLOSURE_NP, HOP_ANY_CLOSURE_NP, - OP_ANY_CLOSURE_SYM, HOP_ANY_CLOSURE_SYM, OP_ANY_CLOSURE_A_SYM, HOP_ANY_CLOSURE_A_SYM, - - OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_NA, HOP_CLOSURE_STAR_NA, - OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA, - OP_SAFE_CLOSURE_STAR_AA_O, HOP_SAFE_CLOSURE_STAR_AA_O, OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1, - OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA, HOP_CLOSURE_STAR_KA, OP_SAFE_CLOSURE_STAR_3A, HOP_SAFE_CLOSURE_STAR_3A, - OP_SAFE_CLOSURE_STAR_NA, HOP_SAFE_CLOSURE_STAR_NA, OP_SAFE_CLOSURE_STAR_NA_0, HOP_SAFE_CLOSURE_STAR_NA_0, - OP_SAFE_CLOSURE_STAR_NA_1, HOP_SAFE_CLOSURE_STAR_NA_1, OP_SAFE_CLOSURE_STAR_NA_2, HOP_SAFE_CLOSURE_STAR_NA_2, - - OP_C_SS, HOP_C_SS, OP_C_S, HOP_C_S, OP_READ_S, HOP_READ_S, OP_C_P, HOP_C_P, OP_C_AP, HOP_C_AP, - OP_C_A, HOP_C_A, OP_C_AA, HOP_C_AA, OP_C, HOP_C, OP_C_NA, HOP_C_NA, - - OP_CL_S, HOP_CL_S, OP_CL_SS, HOP_CL_SS, OP_CL_A, HOP_CL_A, OP_CL_AA, HOP_CL_AA, - OP_CL_NA, HOP_CL_NA, OP_CL_FA, HOP_CL_FA, OP_CL_SAS, HOP_CL_SAS, - /* end of h_opts */ - - OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_MACRO_D, OP_MACRO_STAR_D, - OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C, OP_CALL_WITH_OUTPUT_STRING, - OP_S, OP_S_G, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, - OP_F, OP_F_A, OP_F_AA, OP_F_NP, OP_F_NP_1, - - OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_ITERATE, - OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4, - OP_IMPLICIT_STRING_REF_A, OP_IMPLICIT_C_OBJECT_REF_A, OP_IMPLICIT_PAIR_REF_A, OP_IMPLICIT_PAIR_REF_AA, - OP_IMPLICIT_HASH_TABLE_REF_A, OP_IMPLICIT_HASH_TABLE_REF_AA, - OP_IMPLICIT_LET_REF_C, OP_IMPLICIT_LET_REF_A, OP_IMPLICIT_S7_STARLET_REF_S, OP_IMPLICIT_S7_STARLET_SET, - OP_UNKNOWN, OP_UNKNOWN_NS, OP_UNKNOWN_NA, OP_UNKNOWN_S, OP_UNKNOWN_GG, OP_UNKNOWN_A, OP_UNKNOWN_AA, OP_UNKNOWN_NP, - - OP_SYMBOL, OP_CONSTANT, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, HOP_HASH_TABLE_INCREMENT, OP_CLEAR_OPTS, - - OP_READ_INTERNAL, OP_EVAL, OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, OP_EVAL_ARGS4, OP_EVAL_ARGS5, - OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_QUOTE_UNCHECKED, OP_MACROEXPAND, OP_CALL_CC, OP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_O, - OP_C_CATCH, OP_C_CATCH_ALL, OP_C_CATCH_ALL_O, OP_C_CATCH_ALL_A, - - OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_HOOK, OP_BEGIN_NO_HOOK, OP_BEGIN_UNCHECKED, OP_BEGIN_2_UNCHECKED, OP_BEGIN_NA, OP_BEGIN_AA, - OP_IF, OP_IF1, OP_WHEN, OP_UNLESS, OP_SET, OP_SET1, OP_SET2, - OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2, OP_LET_STAR_SHADOWED, - OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, - OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1, OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1, - OP_LET_TEMP_S7, OP_LET_TEMP_NA, OP_LET_TEMP_A, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND, - OP_LET_TEMP_A_A, OP_LET_TEMP_S7_DIRECT, OP_LET_TEMP_S7_DIRECT_UNWIND, - OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_O, OP_COND1_SIMPLE_O, - OP_AND, OP_OR, - OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, OP_DEFINE_EXPANSION_STAR, OP_MACRO, OP_MACRO_STAR, - OP_CASE, - OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE, - OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES, - OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_INT_VECTOR, OP_READ_FLOAT_VECTOR, OP_READ_DONE, - OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE, OP_SPLICE_VALUES, OP_NO_VALUES, - OP_CATCH, OP_DYNAMIC_WIND, OP_DYNAMIC_UNWIND, OP_DYNAMIC_UNWIND_PROFILE, OP_PROFILE_IN, - OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1, - OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT, - OP_DEFINE_STAR, OP_LAMBDA_STAR, OP_LAMBDA_STAR_DEFAULT, OP_ERROR_QUIT, OP_UNWIND_INPUT, OP_UNWIND_OUTPUT, OP_ERROR_HOOK_QUIT, - OP_WITH_LET, OP_WITH_LET1, OP_WITH_LET_UNCHECKED, OP_WITH_LET_S, - OP_WITH_BAFFLE, OP_WITH_BAFFLE_UNCHECKED, OP_EXPANSION, - OP_FOR_EACH, OP_FOR_EACH_1, OP_FOR_EACH_2, OP_FOR_EACH_3, - OP_MAP, OP_MAP_1, OP_MAP_2, OP_MAP_GATHER, OP_MAP_GATHER_1, OP_MAP_GATHER_2, OP_MAP_GATHER_3, OP_MAP_UNWIND, - OP_BARRIER, OP_DEACTIVATE_GOTO, - OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR, OP_BACRO, OP_BACRO_STAR, - OP_GET_OUTPUT_STRING, - OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT_PAIR_END, OP_SORT_VECTOR_END, OP_SORT_STRING_END, - OP_EVAL_STRING, - OP_MEMBER_IF, OP_ASSOC_IF, OP_MEMBER_IF1, OP_ASSOC_IF1, - OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CATCH_1, OP_CATCH_2, OP_CATCH_ALL, - - OP_SET_UNCHECKED, OP_SET_S_C, OP_SET_S_S, OP_SET_S_P, OP_SET_S_A, - OP_SET_NORMAL, OP_SET_opSq_A, OP_SET_opSAq_A, OP_SET_opSAq_P, OP_SET_opSAq_P_1, OP_SET_opSAAq_A, OP_SET_opSAAq_P, OP_SET_opSAAq_P_1, - OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_SAFE, - OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_INCREMENT_SA, OP_INCREMENT_SAA, OP_SET_CONS, - - OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED, - OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED, OP_DEFINE_CONSTANT_UNCHECKED, - OP_DEFINE_WITH_SETTER, - - OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_A, OP_NAMED_LET_AA, OP_NAMED_LET_NA, OP_NAMED_LET_STAR, - OP_LET_NA_OLD, OP_LET_NA_NEW, OP_LET_2A_OLD, OP_LET_2A_NEW, OP_LET_3A_OLD, OP_LET_3A_NEW, - OP_LET_opaSSq_OLD, OP_LET_opaSSq_NEW, OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW, - OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1, OP_LET_ONE_P_NEW_1, - OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW, - OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_NA_OLD, OP_LET_A_NA_NEW, OP_LET_A_OLD_2, OP_LET_A_NEW_2, - OP_LET_STAR_NA, OP_LET_STAR_NA_A, - - OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G, OP_CASE_A_G_G, OP_CASE_A_S_G, - OP_CASE_P_E_S, OP_CASE_P_I_S, OP_CASE_P_G_S, OP_CASE_P_E_G, OP_CASE_P_G_G, - OP_CASE_E_S, OP_CASE_I_S, OP_CASE_G_S, OP_CASE_E_G, OP_CASE_G_G, - OP_CASE_A_I_S_A, OP_CASE_A_E_S_A, OP_CASE_A_G_S_A, OP_CASE_A_S_G_A, - - OP_IF_UNCHECKED, OP_AND_P, OP_AND_P1, OP_AND_AP, OP_AND_PAIR_P, - OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST, OP_AND_2A, OP_AND_3A, OP_AND_N, OP_AND_S_2, - OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_2A, OP_OR_3A, OP_OR_N, OP_OR_S_2, OP_OR_S_TYPE_2, - OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2A, OP_WHEN_AND_3A, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P, - - OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, OP_IF_NOT_A_A, OP_IF_NOT_A_A_A, - OP_IF_B_A, OP_IF_B_P, OP_IF_B_R, OP_IF_B_A_P, OP_IF_B_P_A, OP_IF_B_P_P, OP_IF_B_N_N, - OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_S_A_P, OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, - OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, OP_IF_opSq_N_N, - OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N, OP_IF_IS_TYPE_S_P_A, OP_IF_IS_TYPE_S_A_A, OP_IF_IS_TYPE_S_A_P, - OP_IF_A_P, OP_IF_A_P_P, OP_IF_A_R, OP_IF_A_N, OP_IF_A_N_N, - OP_IF_AND2_P, OP_IF_AND2_P_P, OP_IF_AND2_R, OP_IF_AND2_N, OP_IF_AND2_N_N, - OP_IF_AND3_P, OP_IF_AND3_P_P, OP_IF_AND3_R, OP_IF_AND3_N, OP_IF_AND3_N_N, /* or3 got few hits */ - OP_IF_P_P, OP_IF_P_P_P, OP_IF_P_R, OP_IF_P_N, OP_IF_P_N_N, - OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ANDP_R, OP_IF_ANDP_N, OP_IF_ANDP_N_N, - OP_IF_ORP_P, OP_IF_ORP_P_P, OP_IF_ORP_R, OP_IF_ORP_N, OP_IF_ORP_N_N, - OP_IF_OR2_P, OP_IF_OR2_P_P, OP_IF_OR2_R, OP_IF_OR2_N, OP_IF_OR2_N_N, - OP_IF_PP, OP_IF_PPP, OP_IF_PN, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP, - - OP_COND_NA_NA, OP_COND_NA_NP, OP_COND_NA_NP_1, OP_COND_NA_2E, OP_COND_NA_3E, OP_COND_NA_NP_O, - OP_COND_FEED, OP_COND_FEED_1, - - OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_O, - OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_O, OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT, - OP_DOTIMES_P, OP_DOTIMES_STEP_O, - OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1, - OP_DO_NO_BODY_NA_VARS, OP_DO_NO_BODY_NA_VARS_STEP, OP_DO_NO_BODY_NA_VARS_STEP_1, - - OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_3_MV, OP_SAFE_C_PP_5, OP_SAFE_C_PP_6_MV, - OP_SAFE_C_3P_1, OP_SAFE_C_3P_2, OP_SAFE_C_3P_3, OP_SAFE_C_3P_1_MV, OP_SAFE_C_3P_2_MV, OP_SAFE_C_3P_3_MV, - OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, - OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, OP_SAFE_C_PS_MV, OP_SAFE_C_PC_MV, - OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA, - OP_ANY_C_NP_1, OP_ANY_C_NP_MV, OP_SAFE_C_SSP_1, OP_SAFE_C_SSP_MV, - OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_ANY_C_NP_2, OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, - OP_SET_WITH_LET_1, OP_SET_WITH_LET_2, - - OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_CLOSURE_P_1, - OP_SAFE_CLOSURE_P_1, OP_SAFE_CLOSURE_P_A_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1, - OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, OP_ANY_CLOSURE_NP_1, OP_ANY_CLOSURE_NP_MV, - OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3, OP_ANY_CLOSURE_4P_4, OP_ANY_CLOSURE_NP_2, - - OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_AND_A_OR_A_L3A, OP_TC_OR_A_AND_A_L3A, - OP_TC_OR_A_A_AND_A_A_LA, OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA, OP_TC_OR_A_AND_A_A_LA, - OP_TC_WHEN_LA, OP_TC_WHEN_LAA, OP_TC_WHEN_L3A, OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA, - OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_Z, OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND, - OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, - OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A, - OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, OP_TC_COND_A_Z_LA, OP_TC_COND_A_LA_Z, OP_TC_COND_A_Z_LAA, OP_TC_COND_A_LAA_Z, - OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA, - OP_TC_CASE_LA, OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z, - - OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_opA_LAq_A, OP_RECUR_IF_A_A_opLA_Aq, OP_RECUR_IF_A_opLA_Aq_A, - OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A, - OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A, - OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq, - OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, OP_RECUR_IF_A_A_opA_L3Aq, - OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA, - OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */ - OP_RECUR_COND_A_A_opA_LAq, OP_RECUR_COND_A_A_opA_LAAq, - OP_RECUR_COND_A_A_A_A_opLA_LAq, OP_RECUR_COND_A_A_A_A_opLAA_LAAq, OP_RECUR_COND_A_A_A_A_opA_LAAq, - OP_RECUR_COND_A_A_A_LAA_LopA_LAAq, OP_RECUR_COND_A_A_A_LAA_opA_LAAq, - OP_RECUR_AND_A_OR_A_LAA_LAA, - - NUM_OPS}; - -#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA)) - -typedef enum{E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, E_C_PS} combine_op_t; - -static const char* op_names[NUM_OPS] = - { - "unopt", "gc_protect", - - "safe_c_nc", "h_safe_c_nc", "safe_c_s", "h_safe_c_s", - "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs", "safe_c_cq", "h_safe_c_cq", - "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css", - "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", "safe_c_ccs", "h_safe_c_ccs", - "safe_c_ns", "h_safe_c_ns", "safe_c_opncq", "h_safe_c_opncq", "safe_c_opsq", "h_safe_c_opsq", - "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq", - "safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq", - "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq", - "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c", - "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq", - "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq", - "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq", - "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c", - "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq", "h_safe_c_op_opsqq", - "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs", - - "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa", "h_safe_c_sa", "safe_c_as", "h_safe_c_as", - "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", "safe_c_aaa", "h_safe_c_aaa", "safe_c_4a", "h_safe_c_4a", - "safe_c_na", "h_safe_c_na", "safe_c_all_ca", "h_safe_c_all_ca", - "safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas", "safe_c_saa", "h_safe_c_saa", - "safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca", "safe_c_ass", "h_safe_c_ass", - "safe_c_cac", "h_safe_c_cac", "safe_c_agg", "h_safe_c_agg", - "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", "safe_c_opaaaq", "h_safe_c_opaaaq", - "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s", "safe_c_s_opaaq", "h_safe_c_s_opaaq", - "safe_c*", "h_safe_c*", "safe_c*_a", "h_safe_c*_a", "safe_c*_aa", "h_safe_c*_aa", "safe_c*_na", "h_safe_c*_na", - - "safe_c_p", "h_safe_c_p", "safe_c_pp", "h_safe_c_pp", "safe_c_ff", "h_safe_c_ff", "safe_c_sp", "h_safe_c_sp", - "safe_c_cp", "h_safe_c_cp", "safe_c_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa", "safe_c_ps", "h_safe_c_ps", - "safe_c_pc", "h_safe_c_pc", "safe_c_ssp", "h_safe_c_ssp", "any_c_np", "h_any_c_np", "safe_c_3p", "h_safe_c_3p", - - "thunk", "h_thunk", "thunk_o", "h_thunk_o", "thunk_any", "h_thunk_any", - "safe_thunk", "h_safe_thunk", "safe_thunk_a", "h_safe_thunk_a", "safe_thunk_any", "h_safe_thunk_any", - - "closure_s", "h_closure_s", "closure_s_o", "h_closure_s_o", - "closure_a", "h_closure_a", "closure_a_o", "h_closure_a_o", "closure_p", "h_closure_p", - "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", "closure_pp", "h_closure_pp", - "closure_fa", "h_closure_fa", "closure_ss", "h_closure_ss", "closure_ss_o", "h_closure_ss_o", - "closure_sc", "h_closure_sc", "closure_sc_o", "h_closure_sc_o", - "closure_3s", "h_closure_3s", "closure_3s_o", "h_closure_3s_o", "closure_4s", "h_closure_4s", "closure_4s_o", "h_closure_4s_o", - "closure_aa", "h_closure_aa", "closure_aa_o", "h_closure_aa_o", "closure_3a", "h_closure_3a", "closure_4a", "h_closure_4a", - "closure_na", "h_closure_na", "closure_ass", "h_closure_ass", "closure_sas", "h_closure_sas ","closure_aas", "h_closure_aas", - "closure_saa", "h_closure_saa", "closure_asa", "h_closure_asa", "closure_ns", "h_closure_ns", - - "safe_closure_s", "h_safe_closure_s", "safe_closure_s_o", "h_safe_closure_s_o", - "safe_closure_s_a", "h_safe_closure_s_a", "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc", - "safe_closure_p", "h_safe_closure_p", "safe_closure_p_a", "h_safe_closure_p_a", - "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp", - "safe_closure_a", "h_safe_closure_a", "safe_closure_a_o", "h_safe_closure_a_o", "safe_closure_a_a", "h_safe_closure_a_a", - "safe_closure_a_to_sc", "h_safe_closure_a_to_sc", - "safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_o", "h_safe_closure_ss_o", "safe_closure_ss_a", "h_safe_closure_ss_a", - "safe_closure_sc", "h_safe_closure_sc", "safe_closure_sc_o", "h_safe_closure_sc_o", - "safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_o", "h_safe_closure_aa_o", "safe_closure_aa_a", "h_safe_closure_aa_a", - "safe_closure_saa", "h_safe_closure_saa", "safe_closure_ssa", "h_safe_closure_ssa", - "safe_closure_agg", "h_safe_closure_agg", "safe_closure_3a", "h_safe_closure_3a", "safe_closure_na", "h_safe_closure_na", - "safe_closure_3s", "h_safe_closure_3s", "safe_closure_ns", "h_safe_closure_ns", - "safe_closure_3s_a", "h_safe_closure_3s_a", - - "any_closure_3p", "h_any_closure_3p", "any_closure_4p", "h_any_closure_4p", "any_closure_np", "h_any_closure_np", - "any_closure_sym", "h_any_closure_sym", "any_closure_a_sym", "h_any_closure_a_sym", - - "closure*_a", "h_closure*_a", "closure*_na", "h_closure*_na", - "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa", - "safe_closure*_aa_o", "h_safe_closure*_aa_o", "safe_closure*_a1", "h_safe_closure*_a1", - "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", "h_closure*_ka", "safe_closure*_3a", "h_safe_closure*_3a", - "safe_closure*_na", "h_safe_closure*_na", "safe_closure*_na_0", "h_safe_closure*_na_0", - "safe_closure*_na_1", "h_safe_closure*_na_1", "safe_closure*_na_2", "h_safe_closure*_na_2", - - "c_ss", "h_c_ss", "c_s", "h_c_s", "read_s", "h_read_s", "c_p", "h_c_p", "c_ap", "h_c_ap", - "c_a", "h_c_a", "c_aa", "h_c_aa", "c", "h_c", "c_na", "h_c_na", - - "cl_s", "h_cl_s", "cl_ss", "h_cl_ss", "cl_a", "h_cl_a", "cl_aa", "h_cl_aa", - "cl_na", "h_cl_na", "cl_fa", "h_cl_fa", "cl_sas", "h_cl_sas", - - "apply_ss", "apply_sa", "apply_sl", "macro_d", "macro*_d", - "with_input_from_string", "with_input_from_string_1", "with_output_to_string", "with_input_from_string_c", "call_with_output_string", - "s", "s_g", "s_a", "s_aa", "a_a", "a_aa", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa", - "f", "f_a", "f_aa", "f_np", "f_np_1", - - "implicit_goto", "implicit_goto_a", "implicit_continuation_a","implicit_iterate", - "implicit_vector_ref_a", "implicit_vector_ref_aa", "implicit_vector_set_3", "implicit_vector_set_4", - "implicit_string_ref_a", "implicit_c_object_ref_a", "implicit_pair_ref_a", "implicit_pair_ref_aa", - "implicit_hash_table_ref_a", "implicit_hash_table_ref_aa", - "implicit_let_ref_c", "implicit_let_ref_a", "implicit_*s7*_ref_s", "implicit_*s7*_set", - "unknown_thunk", "unknown_ns", "unknown_na", "unknown_s", "unknown_gg", "unknown_a", "unknown_aa", "unknown_np", - - "symbol", "constant", "pair_sym", "pair_pair", "pair_any", "h_hash_table_increment", "clear_opts", - - "read_internal", "eval", "eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", "eval_args5", - "apply", "eval_macro", "lambda", "quote", "quote_unchecked", "macroexpand", "call/cc", "call_with_exit", "call_with_exit_o", - "c_catch", "c_catch_all", "c_catch_all_o", "c_catch_all_a", - - "define", "define1", "begin", "begin_hook", "begin_no_hook", "begin_unchecked", "begin_2_unchecked", "begin_na", "begin_aa", - "if", "if1", "when", "unless", "set", "set1", "set2", - "let", "let1", "let*", "let*1", "let*2", "let*-shadowed", - "letrec", "letrec1", "letrec*", "letrec*1", - "let_temporarily", "let_temp_unchecked", "let_temp_init1", "let_temp_init2", "let_temp_done", "let_temp_done1", - "let_temp_s7", "let_temp_na", "let_temp_a", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind", - "let_temp_a_a", "let_temp_s7_direct", "let_temp_s7_direct_unwind", - "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_o", "cond1_simple_o", - "and", "or", - "define_macro", "define_macro*", "define_expansion", "define_expansion*", "macro", "macro*", - "case", "read_list", "read_next", "read_dot", "read_quote", - "read_quasiquote", "read_unquote", "read_apply_values", - "read_vector", "read_byte_vector", "read_int_vector", "read_float_vector", "read_done", - "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", "splice_values", "no_values", - "catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile", "profile_in", - "define_constant", "define_constant1", - "do", "do_end", "do_end1", "do_step", "do_step2", "do_init", - "define*", "lambda*", "lambda*_default", "error_quit", "unwind_input", "unwind_output", "error_hook_quit", - "with_let", "with_let1", "with_let_unchecked", "with_let_s", - "with_baffle", "with_baffle_unchecked", "expansion", - "for_each", "for_each_1", "for_each_2", "for_each_3", - "map", "map_1", "map_2", "map_gather", "map_gather_1", "map_gather_2", "map_gather_3", "map_unwind", - "barrier", "deactivate_goto", - "define_bacro", "define_bacro*", "bacro", "bacro*", - "get_output_string", - "sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end", "sort_string_end", - "eval_string", - "member_if", "assoc_if", "member_if1", "assoc_if1", - "lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all", - "set_unchecked", "set_s_c", "set_s_s", "set_s_p", "set_a", - "set_normal", "set_opsq_a", "set_opsaq_a", "set_opsaq_p", "set_opsaq_p_1", "set_opsaaq_a", "set_opsaaq_p", "set_opsaaq_p_1", - "set_from_setter", "set_from_let_temp", "set_safe", - "increment_1", "decrement_1", "increment_sa", "increment_saa", "set_cons", - "letrec_unchecked", "letrec*_unchecked", "cond_unchecked", - "lambda*_unchecked", "do_unchecked", "define_unchecked", "define*_unchecked", "define_funchecked", "define_constant_unchecked", - "define_with_setter", - - "let_no_vars", "named_let", "named_let_no_vars", "named_let_a", "named_let_aa", "named_let_na", "named_let*", - "let_na_old", "let_na_new", "let_2a_old", "let_2a_new", "let_3a_old", "let_3a_new", - "let_opassq_old", "let_opassq_new", "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new", - "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1", - "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new", - "let_a_a_old", "let_a_a_new", "let_a_na_old", "let_a_na_new", "let_a_old_2", "let_a_new_2", - "let*_na", "let*_na_a", - - "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", "case_a_s_g", - "case_p_e_s", "case_p_i_s", "case_p_g_s", "case_p_e_g", "case_p_g_g", - "case_e_s", "case_i_s", "case_g_s", "case_e_g", "case_g_g", - "case_a_i_s_a", "case_a_e_s_a", "case_a_g_s_a", "case_a_s_g_a", - - "if_unchecked", "and_p", "and_p1", "and_ap", "and_pair_p", - "and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest", "and_2a", "and_3a", "and_n", "and_s_2", - "or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2", "or_s_type_2", - "when_s", "when_a", "when_p", "when_and_ap", "when_and_2a", "when_and_3a", "unless_s", "unless_a", "unless_p", - - "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a", - "if_b_a", "if_b_p", "if_b_r", "if_b_a_p", "if_b_p_a", "if_b_p_p", "if_b_n_n", - "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_s_a_p", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", - "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n", - "if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r", "if_is_type_s_n", "if_is_type_s_n_n", "if_is_type_s_p_a", "if_is_type_s_a_a", "if_is_type_s_a_p", - "if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n", - "if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n", - "if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n", - "if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n", - "if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n", - "if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n", - "if_or2_p", "if_or2_p_p", "if_or2_r", "if_or2_n", "if_or2_n_n", - "if_pp", "if_ppp", "if_pn", "if_pr", "if_prr", "when_pp", "unless_pp", - - "cond_na_na", "cond_na_np", "cond_na_np_1", "cond_na_2e", "cond_na_3e", "cond_na_np_o", - "cond_feed", "cond_feed_1", - - "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_o", - "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o", "dox_no_body", "dox_pending_no_body", "dox_init", - "dotimes_p", "dotimes_step_o", - "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1", - "do_no_body_na_vars", "do_no_body_na_vars_step", "do_no_body_na_vars_step_1", - - "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5", "safe_c_pp_6_mv", - "safe_c_3p_1", "safe_c_3p_2", "safe_c_3p_3", "safe_c_3p_1_mv", "safe_c_3p_2_mv", "safe_c_3p_3_mv", - "safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", - "safe_c_ps_1", "safe_c_pc_1", "safe_c_ps_mv", "safe_c_pc_mv", - "eval_macro_mv", "macroexpand_1", "apply_lambda", - "any_c_np_1", "any_c_np_mv", "safe_c_ssp_1", "safe_c_ssp_mv", - "c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "any_c_np_2", "safe_c_pa_1", "safe_c_pa_mv", - "set_with_let_1", "set_with_let_2", - - "closure_ap_1", "closure_pa_1", "closure_pp_1", "closure_p_1", - "safe_closure_p_1", "safe_closure_p_a_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_pp_1", - "any_closure_3p_1", "any_closure_3p_2", "any_closure_3p_3", "any_closure_np_1", "any_closure_np_mv", - "any_closure_4p_1", "any_closure_4p_2", "any_closure_4p_3", "any_closure_4p_4", "any_closure_np_2", - - "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_and_a_or_a_l3a", "tc_or_a_and_a_l3a", - "tc_or_a_a_and_a_a_la", "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_or_a_and_a_a_la", - "tc_when_la", "tc_when_laa", "tc_when_l3a", "tc_let_when_laa", "tc_let_unless_laa", - "tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_z", "tc_cond_a_z_a_laa_laa", "tc_let_cond", - "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", "tc_if_a_la_z", "tc_if_a_laa_z", - "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a", - "tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", "tc_cond_a_z_la", "tc_cond_a_la_z", "tc_cond_a_z_laa", "tc_cond_a_laa_z", - "tc_let_if_a_z_la", "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa", - "tc_case_la", "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z", - - "recur_if_a_a_opa_laq", "recur_if_a_opa_laq_a", "recur_if_a_a_opla_aq", "recur_if_a_opla_aq_a", - "recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a", - "recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a", - "recur_if_a_a_opla_la_laq", "recur_if_a_a_if_a_a_opla_laq", "recur_if_a_a_if_a_a_oplaa_laaq", - "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", "recur_if_a_a_opa_l3aq", - "recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa", - "recur_if_a_a_if_a_laa_opa_laaq", - "recur_cond_a_a_op_a_laq", "recur_cond_a_a_op_a_laaq", - "recur_cond_a_a_a_a_opla_laq", "recur_cond_a_a_a_a_oplaa_laaq", "recur_cond_a_a_a_a_opa_laaq", - "recur_cond_a_a_a_laa_lopa_laaq", "recur_cond_a_a_a_laa_opa_laaq", - "recur_and_a_or_a_laa_laa", -}; - -#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK)) -#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP)) -#define is_h_safe_c_nc(P) (optimize_op(P) == HOP_SAFE_C_NC) -#define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S)) -#define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S) -#define FIRST_UNHOPPABLE_OP OP_APPLY_SS - -static bool is_h_optimized(s7_pointer p) -{ - return((is_optimized(p)) && - (op_has_hop(p)) && - (optimize_op(p) < FIRST_UNHOPPABLE_OP) && /* was OP_S? */ - (optimize_op(p) > OP_GC_PROTECT)); -} - -static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e); -static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len); -static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); -static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym); -static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article); - -/* if this changes, remember to change lint.scm */ -typedef enum {SL_NO_FIELD=0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS, SL_HEAP_SIZE, SL_FREE_HEAP_SIZE, - SL_GC_FREED, SL_GC_PROTECTED_OBJECTS, SL_GC_TOTAL_FREED, SL_GC_INFO, SL_FILE_NAMES, SL_FILENAMES, SL_ROOTLET_SIZE, SL_C_TYPES, - SL_SAFETY, SL_UNDEFINED_IDENTIFIER_WARNINGS, SL_UNDEFINED_CONSTANT_WARNINGS, SL_GC_STATS, SL_MAX_HEAP_SIZE, - SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES, SL_STACK, SL_MAJOR_VERSION, SL_MINOR_VERSION, - SL_MAX_STRING_LENGTH, SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH, SL_MAX_VECTOR_DIMENSIONS, - SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, SL_DEFAULT_RATIONALIZE_ERROR, - SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, - SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, SL_HISTORY, SL_HISTORY_ENABLED, - SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_PROFILE_PREFIX, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, - SL_MUFFLE_WARNINGS, SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_OUTPUT_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, - SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION, SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS, - SL_NUMBER_SEPARATOR, SL_NUM_FIELDS} s7_starlet_t; - -static const char *s7_starlet_names[SL_NUM_FIELDS] = - {"no-field", "stack-top", "stack-size", "stacktrace-defaults", "heap-size", "free-heap-size", - "gc-freed", "gc-protected-objects", "gc-total-freed", "gc-info", "file-names", "filenames", "rootlet-size", "c-types", - "safety", "undefined-identifier-warnings", "undefined-constant-warnings", "gc-stats", "max-heap-size", - "max-port-data-size", "max-stack-size", "cpu-time", "catches", "stack", "major-version", "minor-version", - "max-string-length", "max-format-length", "max-list-length", "max-vector-length", "max-vector-dimensions", - "default-hash-table-length", "initial-string-port-length", "default-rationalize-error", - "default-random-state", "equivalent-float-epsilon", "hash-table-float-epsilon", "print-length", - "bignum-precision", "memory-usage", "float-format-precision", "history", "history-enabled", - "history-size", "profile", "profile-info", "profile-prefix", "autoloading?", "accept-all-keyword-arguments", - "muffle-warnings?", "most-positive-fixnum", "most-negative-fixnum", "output-port-data-size", "debug", "version", - "gc-temps-size", "gc-resize-heap-fraction", "gc-resize-heap-by-4-fraction", "openlets", "expansions?", - "number-separator"}; - - -/* -------------------------------- internal debugging apparatus -------------------------------- */ -static int64_t heap_location(s7_scheme *sc, s7_pointer p) -{ - for (heap_block_t *hp = sc->heap_blocks; hp; hp = hp->next) - if (((intptr_t)p >= hp->start) && ((intptr_t)p < hp->end)) - return(hp->offset + (((intptr_t)p - hp->start) / sizeof(s7_cell))); - return(((s7_big_pointer)p)->big_hloc); -} - -#if TRAP_SEGFAULT -#include -static Jmp_Buf senv; /* global here is not a problem -- it is used only to protect s7_is_valid */ -static volatile sig_atomic_t can_jump = 0; -static void segv(int32_t unused) {if (can_jump) LongJmp(senv, 1);} -#endif - -bool s7_is_valid(s7_scheme *sc, s7_pointer arg) -{ - bool result = false; - if (!arg) return(false); - { - s7_pointer heap0 = *(sc->heap); - s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); - if ((arg >= heap0) && (arg < heap1)) return(true); - } -#if TRAP_SEGFAULT - if (SetJmp(senv, 1) == 0) - { - void (*old_segv)(int32_t sig); - can_jump = 1; - old_segv = signal(SIGSEGV, segv); -#endif - if ((unchecked_type(arg) > T_FREE) && - (unchecked_type(arg) < NUM_TYPES)) - { - if (!in_heap(arg)) - result = true; - else - { - int64_t loc = heap_location(sc, arg); - if ((loc >= 0) && (loc < sc->heap_size)) - result = (sc->heap[loc] == arg); - }} -#if TRAP_SEGFAULT - signal(SIGSEGV, old_segv); - } - else result = false; - can_jump = 0; -#endif - return(result); -} - -#define safe_print(Code) \ - do { \ - bool old_open = sc->has_openlets, old_stop = sc->stop_at_error; \ - sc->has_openlets = false; \ - sc->stop_at_error = false; \ - Code; \ - sc->stop_at_error = old_stop; \ - sc->has_openlets = old_open; \ - } while (0) - -void s7_show_history(s7_scheme *sc) -{ -#if WITH_HISTORY - if (sc->cur_code == sc->history_sink) - fprintf(stderr, "history diabled\n"); - else - { - int32_t size = sc->history_size; - s7_pointer p = cdr(sc->cur_code); - fprintf(stderr, "history:\n"); - for (int32_t i = 0; i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */ - safe_print(fprintf(stderr, "%d: %s\n", i, display_80(car(p)))); - fprintf(stderr, "\n"); - } -#else - fprintf(stderr, "%s\n", display(sc->cur_code)); -#endif -} - -#define stack_code(Stack, Loc) stack_element(Stack, Loc - 3) -#define stack_let(Stack, Loc) stack_element(Stack, Loc - 2) -#define stack_args(Stack, Loc) stack_element(Stack, Loc - 1) -#define stack_op(Stack, Loc) ((opcode_t)(stack_element(Stack, Loc))) - -void s7_show_stack(s7_scheme *sc) -{ - fprintf(stderr, "stack:\n"); - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]); -} - -#if S7_DEBUGGING -#define UNUSED_BITS 0xfc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type */ - -static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S7_DEBUGGING in display_fallback (for display_functions) */ -{ - uint64_t full_typ = full_type(obj); - uint8_t typ = unchecked_type(obj); - char *buf; - char str[900]; - - str[0] = '\0'; - catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ - /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ - ((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? - (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" : " closure-multiform") : - " ?0?") : "", - /* bit 9 */ - ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? - " syntactic" : - " ?1?") : "", - /* bit 10 */ - ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" : - ((is_any_closure(obj)) ? " closure-one-form" : - " ?2?")) : "", - /* bit 11 */ - ((full_typ & T_OPTIMIZED) != 0) ? ((is_c_function(obj)) ? " scope-safe" : - ((is_pair(obj)) ? " optimized" : - " ?3?")) : "", - /* bit 12 */ - ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" : " ?4?") : "", - /* bit 13 */ - ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" : " ?5?") : "", - /* bit 14 */ - ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_either_macro(obj))) ? " expansion" : " ?6?") : "", - /* bit 15 */ - ((full_typ & T_MULTIPLE_VALUE) != 0) ? ((is_symbol(obj)) ? " matched" : - ((is_pair(obj)) ? " values|matched" : - " ?7?")) : "", - /* bit 16 */ - ((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" : - (((is_symbol(obj)) || (is_syntax(obj))) ? " global" : - ((is_let(obj)) ? " dox_slot1" : - " ?8?"))) : "", - /* bit 17 */ - ((full_typ & T_COLLECTED) != 0) ? " collected" : "", - /* bit 18 */ - ((full_typ & T_LOCATION) != 0) ? ((is_pair(obj)) ? " line-number" : - ((is_input_port(obj)) ? " loader-port" : - ((is_let(obj)) ? " with-let" : - ((is_any_procedure(obj)) ? " simple-defaults" : - ((is_slot(obj)) ? " has-setter" : - " ?10?"))))) : "", - /* bit 19 */ - ((full_typ & T_SHARED) != 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", - /* bit 20 */ - ((full_typ & T_LOCAL) != 0) ? ((is_normal_symbol(obj)) ? " local" : - ((is_pair(obj)) ? " high-c" : - " ?12?")) : "", - /* bit 21 */ - ((full_typ & T_SAFE_PROCEDURE) != 0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") : "", - /* bit 22 */ - ((full_typ & T_CHECKED) != 0) ? (((is_pair(obj)) || (is_slot(obj))) ? " checked" : - ((is_symbol(obj)) ? " all-integer" : - " ?14?")) : "", - /* bit 23 */ - ((full_typ & T_UNSAFE) != 0) ? ((is_symbol(obj)) ? " clean-symbol" : - ((is_slot(obj)) ? " has-stepper" : - ((is_pair(obj)) ? " unsafely-opt|no-float-opt" : - ((is_let(obj)) ? " dox-slot2" : - " ?15?")))) : "", - /* bit 24 */ - ((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "", - /* bit 25 */ - ((full_typ & T_SETTER) != 0) ? ((is_normal_symbol(obj)) ? " setter" : - ((is_pair(obj)) ? " allow-other-keys|no-int-opt" : - ((is_slot(obj)) ? " has-expression" : - ((is_c_function_star(obj)) ? " allow-other-keys" : - " ?17?")))) : "", - /* bit 26 */ - ((full_typ & T_MUTABLE) != 0) ? ((is_number(obj)) ? " mutable" : - ((is_symbol(obj)) ? " has-keyword" : - ((is_let(obj)) ? " ref-fallback" : - ((is_iterator(obj)) ? " mark-sequence" : - ((is_slot(obj)) ? " step-end" : - ((is_pair(obj)) ? " no-opt" : - " ?18?")))))) : "", - /* bit 27 */ - ((full_typ & T_SAFE_STEPPER) != 0) ? ((is_let(obj)) ? " set-fallback" : - ((is_slot(obj)) ? " safe-stepper" : - ((is_c_function(obj)) ? " maybe-safe" : - ((is_number(obj)) ? " print-name" : - ((is_pair(obj)) ? " direct-opt" : - ((is_hash_table(obj)) ? " weak-hash" : - ((is_any_macro(obj)) ? " pair-macro-set" : - ((is_symbol(obj)) ? " all-float" : - " ?19?")))))))) : "", - /* bit 28, for c_function case see sc->apply */ - ((full_typ & T_COPY_ARGS) != 0) ? (((is_pair(obj)) || (is_any_macro(obj)) || (is_syntax(obj)) || - (is_any_closure(obj)) || (is_c_function(obj))) ? " copy-args" : - " ?20?") : "", - /* bit 29 */ - ((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" : - ((is_normal_symbol(obj)) ? " gensym" : - ((is_string(obj)) ? " documented-symbol" : - ((is_hash_table(obj)) ? " hash-chosen" : - ((is_pair(obj)) ? " fx-treed" : - ((is_any_vector(obj)) ? " subvector" : - ((is_slot(obj)) ? " has-pending-value" : - ((is_any_closure(obj)) ? " unknopt" : - " ?21?")))))))) : "", - /* bit 30 */ - ((full_typ & T_HAS_METHODS) != 0) ? (((is_let(obj)) || (is_c_object(obj)) || (is_any_closure(obj)) || - (is_any_macro(obj)) || (is_c_pointer(obj))) ? " has-methods" : " ?22?") : "", - /* bit 31 */ - ((full_typ & T_ITER_OK) != 0) ? ((is_iterator(obj)) ? " iter-ok" : - ((is_pair(obj)) ? " step-end-ok" : - ((is_slot(obj)) ? " in-rootlet" : - ((is_c_function(obj)) ? " bool-function" : - ((is_symbol(obj)) ? " symbol-from-symbol" : - " ?23?"))))) : "", - /* bit 24+24 */ - ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : - ((is_any_procedure(obj)) ? " has-let-arg" : - ((is_hash_table(obj)) ? " has-value-type" : - ((is_pair(obj)) ? " int-optable" : - " ?24?")))) : "", - /* bit 25+24 */ - ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : - ((is_any_vector(obj)) ? " typed-vector" : - ((is_hash_table(obj)) ? " typed-hash-table" : - ((is_c_function(obj)) ? " has-bool-setter" : - ((is_slot(obj)) ? " rest-slot" : - (((is_pair(obj)) || (is_closure_star(obj))) ? " no-defaults" : - " ?25?")))))) : "", - /* bit 26+24 */ - ((full_typ & T_FULL_DEFINER) != 0) ? ((is_normal_symbol(obj)) ? " definer" : - ((is_pair(obj)) ? " has-fx" : - ((is_slot(obj)) ? " slot-defaults" : - ((is_iterator(obj)) ? " weak-hash-iterator" : - ((is_hash_table(obj)) ? " has-key-type" : - ((is_let(obj)) ? " maclet" : - ((is_c_function(obj)) ? " func-definer" : - ((is_syntax(obj)) ? " syntax-definer" : - " ?26?")))))))) : "", - /* bit 27+24 */ - ((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" : - ((is_hash_table(obj)) ? " simple-values" : - ((is_normal_symbol(obj)) ? " binder" : - ((is_c_function(obj)) ? " safe-args" : - ((is_syntax(obj)) ? " syntax-binder" : - " ?27?"))))) : "", - /* bit 28+24 */ - ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) || (is_any_closure(obj))) ? " very-safe-closure" : - ((is_let(obj)) ? " baffle-let" : - " ?28?")) : "", - /* bit 29+24 */ - ((full_typ & T_CYCLIC) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || - (is_any_closure(obj))) ? " cyclic" : " ?29?") : "", - /* bit 30+24 */ - ((full_typ & T_CYCLIC_SET) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || - (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : "", - /* bit 31+24 */ - ((full_typ & T_KEYWORD) != 0) ? ((is_symbol(obj)) ? " keyword" : - ((is_pair(obj)) ? " fx-treeable" : - " ?31?")) : "", - /* bit 32+24 */ - ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_normal_vector(obj)) ? " simple-elements" : - ((is_hash_table(obj)) ? " simple-keys" : - ((is_normal_symbol(obj)) ? " safe-setter" : - ((is_pair(obj)) ? " float-optable" : - ((typ >= T_C_MACRO) ? " function-simple-elements" : - " 32?"))))) : "", - /* bit 33+24 */ - ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : - ((is_pair(obj)) ? " opt1-func-listed" : - " ?33?")) : "", - /* bit 34+24 */ - ((full_typ & T_FULL_HAS_GX) != 0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "", - /* bit 35+24 */ - ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", - /* bit 36+24 */ - ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", - /* bit 37+24 */ - ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "", - /* bit 62 */ - ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", - /* bit 63 */ - ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "", - - ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", - ((is_symbol(obj)) && (((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) || ((symbol_type(obj) & ~0xffff) != 0))) ? " bad-symbol-type" : "", - NULL); - - buf = (char *)Malloc(1024); - snprintf(buf, 1024, "type: %s? (%d), opt_op: %d %s, flags: #x%" PRIx64 "%s", - type_name(sc, obj, NO_ARTICLE), typ, optimize_op(obj), (optimize_op(obj) < NUM_OPS) ? op_names[optimize_op(obj)] : "", full_typ, str); - return(buf); -} - -/* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */ - -static bool has_odd_bits(s7_pointer obj) -{ - uint64_t full_typ = full_type(obj); - if ((full_typ & UNUSED_BITS) != 0) return(true); - if (((full_typ & T_MULTIFORM) != 0) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_KEYWORD) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_SYNTACTIC) != 0) && (!is_syntax(obj)) && (!is_pair(obj)) && (!is_normal_symbol(obj))) return(true); - if (((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) && (!is_pair(obj)) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_OPTIMIZED) != 0) && (!is_c_function(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_SAFE_CLOSURE) != 0) && (!is_any_closure(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_SAFE_PROCEDURE) != 0) && (!is_applicable(obj))) return(true); - if (((full_typ & T_EXPANSION) != 0) && (!is_normal_symbol(obj)) && (!is_either_macro(obj))) return(true); - if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_GLOBAL) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_syntax(obj))) return(true); - if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_symbol(obj))) return(true); - if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_VERY_SAFE_CLOSURE) != 0) && (!is_pair(obj)) && (!is_any_closure(obj)) && (!is_let(obj))) return(true); - if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_UNKNOPT) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_HAS_GX) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) && (!is_syntax(obj))) return(true); - if (((full_typ & T_CHECKED) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_symbol(obj))) return(true); - if (((full_typ & T_SHARED) != 0) && (!t_sequence_p[type(obj)]) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_COPY_ARGS) != 0) && (!is_pair(obj)) && - (!is_any_macro(obj)) && (!is_any_closure(obj)) && (!is_c_function(obj)) && (!is_syntax(obj))) - return(true); - if (((full_typ & T_FULL_SYMCONS) != 0) && - (!is_symbol(obj)) && (!is_any_procedure(obj)) && (!is_hash_table(obj)) && (!is_pair(obj))) - return(true); - if (((full_typ & T_FULL_BINDER) != 0) && - ((!is_pair(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_syntax(obj)))) - return(true); - if (((full_typ & T_FULL_DEFINER) != 0) && - (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) && - (!is_hash_table(obj)) && (!is_let(obj)) && (!is_syntax(obj))) - return(true); - if (((full_typ & T_FULL_HAS_LET_FILE) != 0) && - (!is_let(obj)) && (!is_any_vector(obj)) && (!is_hash_table(obj)) && (!is_c_function(obj)) && - (!is_slot(obj)) && (!is_pair(obj)) && (!is_closure_star(obj))) - return(true); - if (((full_typ & T_SAFE_STEPPER) != 0) && - (!is_let(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_number(obj)) && - (!is_pair(obj)) && (!is_hash_table(obj)) && (!is_any_macro(obj)) && (!is_symbol(obj))) - return(true); - if (((full_typ & T_SETTER) != 0) && - (!is_slot(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_c_function_star(obj))) - return(true); - if (((full_typ & T_LOCATION) != 0) && - (!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj)) && (!is_any_procedure(obj)) && (!is_slot(obj))) - return(true); - if (((full_typ & T_MUTABLE) != 0) && - (!is_number(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_iterator(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) - return(true); - if (((full_typ & T_GENSYM) != 0) && (!is_slot(obj)) && (!is_any_closure(obj)) && - (!is_let(obj)) && (!is_symbol(obj)) && (!is_string(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_any_vector(obj))) - return(true); - if (((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) && - ((!is_normal_vector(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (unchecked_type(obj) < T_C_MACRO))) - return(true); - if (((full_typ & T_CYCLIC) != 0) && (!is_simple_sequence(obj)) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_CYCLIC_SET) != 0) && (!is_simple_sequence(obj)) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_FULL_HAS_FN) != 0) && (!is_pair(obj))) return(true); - if (is_symbol(obj)) - { - if ((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) - return(true); - if ((symbol_type(obj) & ~0xffff) != 0) /* boolean function bool type and *s7*_let field id */ - return(true); - } - if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) return(true); - /* if ((in_heap(obj)) && ((type(obj) == T_C_FUNCTION) || (type(obj) == T_C_FUNCTION_STAR) || (type(obj) == T_C_MACRO))) return(true); */ - /* this is currently impossible -- s7_make_function et al use semipermanent pointers, but is that a bug? */ - return(false); -} - -void s7_show_let(s7_scheme *sc) /* debugging convenience */ -{ - for (s7_pointer olet = sc->curlet; is_let(T_Lid(olet)); olet = let_outlet(olet)) - { - if (olet == sc->owlet) - fprintf(stderr, "(owlet): "); - else - if (is_funclet(olet)) - fprintf(stderr, "(%s funclet): ", display(funclet_function(olet))); - else - if (olet == sc->shadow_rootlet) - fprintf(stderr, "(shadow rootlet): "); - fprintf(stderr, "%s\n", display(olet)); - } -} - -static const char *check_name(s7_scheme *sc, int32_t typ) -{ - if ((typ >= 0) && (typ < NUM_TYPES)) - { - s7_pointer p = sc->type_names[typ]; - if (is_string(p)) return(string_value(p)); - } - return("unknown type!"); -} - -#if REPORT_ROOTLET_REDEF -static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line) -{ - if (is_global(symbol)) - fprintf(stderr, "%s[%d]: %s%s%s in %s\n", - func, line, - BOLD_TEXT, display(symbol), UNBOLD_TEXT, - display_80(sc->cur_code)); - full_type(symbol) = (full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)); -} -#endif - -static char *safe_object_to_string(s7_pointer p) -{ - char *buf = (char *)Malloc(128); - snprintf(buf, 128, "type: %d", unchecked_type(p)); - return(buf); -} - -static void complain(const char* complaint, s7_pointer p, const char *func, int32_t line, uint8_t typ) -{ - fprintf(stderr, complaint, BOLD_TEXT, func, line, check_name(cur_sc, typ), safe_object_to_string(p), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); -} - -static char* show_debugger_bits(s7_pointer p) -{ - char *bits_str = (char *)Malloc(512); - int64_t bits = p->debugger_bits; - snprintf(bits_str, 512, " %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", - ((bits & OPT1_SET) != 0) ? " opt1_set" : "", - ((bits & OPT1_FAST) != 0) ? " opt1_fast" : "", - ((bits & OPT1_CFUNC) != 0) ? " opt1_cfunc" : "", - ((bits & OPT1_CLAUSE) != 0) ? " opt1_clause" : "", - ((bits & OPT1_LAMBDA) != 0) ? " opt1_lambda" : "", - ((bits & OPT1_SYM) != 0) ? " opt1_sym" : "", - ((bits & OPT1_PAIR) != 0) ? " opt1_pair" : "", - ((bits & OPT1_CON) != 0) ? " opt1_con" : "", - ((bits & OPT1_ANY) != 0) ? " opt1_any" : "", - ((bits & OPT1_HASH) != 0) ? " opt1_hash" : "", - - ((bits & OPT2_SET) != 0) ? " opt2_set" : "", - ((bits & OPT2_KEY) != 0) ? " opt2_any" : "", - ((bits & OPT2_SLOW) != 0) ? " opt2_slow" : "", - ((bits & OPT2_SYM) != 0) ? " opt2_sym" : "", - ((bits & OPT2_PAIR) != 0) ? " opt2_pair" : "", - ((bits & OPT2_CON) != 0) ? " opt2_con" : "", - ((bits & OPT2_FX) != 0) ? " opt2_fx" : "", - ((bits & OPT2_FN) != 0) ? " opt2_fn" : "", - ((bits & OPT2_LAMBDA) != 0) ? " opt2_lambda" : "", - ((bits & OPT2_DIRECT) != 0) ? " opt2_direct" : "", - ((bits & OPT2_NAME) != 0) ? " opt2_raw_name" : "", - ((bits & OPT2_INT) != 0) ? " opt2_int" : "", - - ((bits & OPT3_SET) != 0) ? " opt3_set" : "", - ((bits & OPT3_ARGLEN) != 0) ? " opt3_arglen" : "", - ((bits & OPT3_SYM) != 0) ? " opt3_sym" : "", - ((bits & OPT3_CON) != 0) ? " opt3_con" : "", - ((bits & OPT3_AND) != 0) ? " opt3_pair " : "", - ((bits & OPT3_ANY) != 0) ? " opt3_any " : "", - ((bits & OPT3_LET) != 0) ? " opt3_let " : "", - ((bits & OPT3_BYTE) != 0) ? " opt3_byte " : "", - ((bits & OPT3_DIRECT) != 0) ? " opt3_direct" : "", - ((bits & OPT3_LOCATION) != 0) ? " opt3_location" : "", - ((bits & OPT3_LEN) != 0) ? " opt3_len" : "", - ((bits & OPT3_INT) != 0) ? " opt3_int" : "", - - ((bits & L_HIT) != 0) ? " let_set" : "", - ((bits & L_FUNC) != 0) ? " let_func" : "", - ((bits & L_DOX) != 0) ? " let_dox" : ""); - return(bits_str); -} - -static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2) -{ - if (!p) - fprintf(stderr, "%s%s[%d]: null pointer passed to check_ref%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - else - { - uint8_t typ = unchecked_type(p); - if (typ != expected_type) - { - if ((!func1) || (typ != T_FREE)) - { - fprintf(stderr, "%s%s[%d]: not %s, but %s (%s)%s\n", - BOLD_TEXT, - func, line, check_name(cur_sc, expected_type), check_name(cur_sc, typ), safe_object_to_string(p), - UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - } - else - if ((strcmp(func, func1) != 0) && - ((!func2) || (strcmp(func, func2) != 0))) - { - fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", BOLD_TEXT, func, line, check_name(cur_sc, expected_type), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - }}} - return(p); -} - -static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_ref(p, T_LET, func, line, NULL, NULL); - if ((p->debugger_bits & L_HIT) == 0) fprintf(stderr, "%s[%d]: let not set\n", func, line); - if ((p->debugger_bits & L_MASK) != role) fprintf(stderr, "%s[%d]: let bad role\n", func, line); - return(p); -} - -static s7_pointer check_let_set(s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_ref(p, T_LET, func, line, NULL, NULL); - p->debugger_bits &= (~L_MASK); - p->debugger_bits |= (L_HIT | role); - return(p); -} - -static s7_pointer check_ref2(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2) -{ - if (!p) - fprintf(stderr, "%s[%d]: null pointer passed to check_ref2\n", func, line); - else - { - uint8_t typ = unchecked_type(p); - if ((typ != expected_type) && (typ != other_type)) - return(check_ref(p, expected_type, func, line, func1, func2)); - } - return(p); -} - -static s7_pointer check_ref3(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE)) - complain("%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref4(s7_pointer p, const char *func, int32_t line) -{ - if ((strcmp(func, "sweep") != 0) && - (strcmp(func, "process_multivector") != 0)) - { - uint8_t typ = unchecked_type(p); - if (!t_vector_p[typ]) complain("%s%s[%d]: not a vector, but %s (%s)%s\n", p, func, line, typ); - } - return(p); -} - -static s7_pointer check_ref5(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if (!t_has_closure_let[typ]) complain("%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref6(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if (typ < T_C_MACRO) complain("%s%s[%d]: not a c function or macro, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ < T_INTEGER) || (typ > T_COMPLEX)) - complain("%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref8(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */ - complain("%s%s[%d]: not a sequence or structure, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref9(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) && (!is_any_macro(p)) && (typ != T_C_POINTER)) - complain("%s%s[%d]: not a possible method holder, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref10(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL)) - complain("%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((!t_applicable_p[typ]) && (p != cur_sc->F)) - complain("%s%s[%d]: applicable object is %s (%s)%s?\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref12(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ; - if (is_slot_end(p)) return(p); - typ = unchecked_type(p); - if ((typ != T_SLOT) && (typ != T_NIL)) /* unset slots are nil */ - complain("%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref13(s7_pointer p, const char *func, int32_t line) -{ - if (!is_any_vector(p)) complain("%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, unchecked_type(p)); - if (!is_subvector(p)) complain("%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, func, line, unchecked_type(p)); - return(p); -} - -static s7_pointer check_ref14(s7_pointer p, const char *func, int32_t line) -{ - if ((!is_any_procedure(p)) && (!is_boolean(p))) - complain("%s%s[%d]: setter is %s (%s)%s?\n", p, func, line, unchecked_type(p)); - return(p); -} - -static void print_gc_info(s7_scheme *sc, s7_pointer obj, int32_t line) -{ - if (!obj) - fprintf(stderr, "[%d]: obj is %p\n", line, obj); - else - if (unchecked_type(obj) != T_FREE) - fprintf(stderr, "[%d]: %p type is %d?\n", line, obj, unchecked_type(obj)); - else - { - s7_int free_type = full_type(obj); - char *bits; - char fline[128]; - full_type(obj) = obj->alloc_type; - sc->printing_gc_info = true; - bits = describe_type_bits(sc, obj); /* this func called in type macro */ - sc->printing_gc_info = false; - full_type(obj) = free_type; - if (obj->explicit_free_line > 0) - snprintf(fline, 128, ", freed at %d, ", obj->explicit_free_line); - fprintf(stderr, "%s%p is free (line %d, alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), alloc: %s[%d], %sgc: %s[%d]%s", - BOLD_TEXT, obj, line, s7_type_names[obj->alloc_type & 0xff], obj->alloc_type, obj->alloc_type, - bits, obj->alloc_func, obj->alloc_line, - (obj->explicit_free_line > 0) ? fline : "", obj->gc_func, obj->gc_line, UNBOLD_TEXT); - if (S7_DEBUGGING) fprintf(stderr, "%s, last gc line: %d%s", BOLD_TEXT, sc->last_gc_line, UNBOLD_TEXT); - fprintf(stderr, "\n"); - free(bits); - } - if (sc->stop_at_error) abort(); -} - -static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line) -{ - if (!p) - { - fprintf(stderr, "%s%s[%d]: null pointer!%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - } - else - if (unchecked_type(p) >= NUM_TYPES) - { - fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", BOLD_TEXT, func, line, unchecked_type(p), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - } - if (unchecked_type(p) == T_FREE) - { - fprintf(stderr, "%s%s[%d]: attempt to use free cell%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - print_gc_info(cur_sc, p, line); - } - return(p); -} - -static s7_pointer check_ref15(s7_pointer p, const char *func, int32_t line) /* called in mark_let so s7_scheme* for cur_sc is difficult */ -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if ((is_multiple_value(p)) && - (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */ - complain("%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n", p, func, line, typ); - if (has_odd_bits(p)) - {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);} - return(p); -} - -static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if ((typ != T_LET) && (typ != T_NIL)) complain("%s%s[%d]: not a let or nil, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref17(s7_pointer p, const char *func, int32_t line) -{ - if ((!is_any_macro(p)) || (is_c_macro(p))) complain("%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, unchecked_type(p)); - return(p); -} - -static s7_pointer check_ref18(s7_pointer p, const char *func, int32_t line) -{ - if (!is_symbol_and_keyword(p)) complain("%s%s[%d]: not a keyword: %s (%s)%s?\n", p, func, line, unchecked_type(p)); - if (strcmp(func, "new_symbol") != 0) - { - if (global_value(p) != p) - fprintf(stderr, "%s%s[%d]: keyword %s value is not itself (type: %s)%s\n", BOLD_TEXT, func, line, display(p), s7_type_names[unchecked_type(global_value(p))], UNBOLD_TEXT); - if (in_heap(keyword_symbol_unchecked(p))) - fprintf(stderr, "%s%s[%d]: keyword %s symbol is in the heap%s\n", BOLD_TEXT, func, line, display(p), UNBOLD_TEXT); - if (has_odd_bits(p)) - {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);} - } - return(p); -} - -static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if (t_ext_p[typ]) fprintf(stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", BOLD_TEXT, func, line, s7_type_names[typ], UNBOLD_TEXT); - return(p); -} - -static const char *opt1_role_name(uint64_t role) -{ - if (role == OPT1_FAST) return("opt1_fast"); - if (role == OPT1_CFUNC) return("opt1_cfunc"); - if (role == OPT1_LAMBDA) return("opt1_lambda"); - if (role == OPT1_CLAUSE) return("opt1_clause"); - if (role == OPT1_SYM) return("opt1_sym"); - if (role == OPT1_PAIR) return("opt1_pair"); - if (role == OPT1_CON) return("opt1_con"); - if (role == OPT1_ANY) return("opt1_any"); - return((role == OPT1_HASH) ? "opt1_hash" : "opt1_unknown"); -} - -static const char *opt2_role_name(uint64_t role) -{ - if (role == OPT2_FX) return("opt2_fx"); - if (role == OPT2_FN) return("opt2_fn"); - if (role == OPT2_KEY) return("opt2_any"); - if (role == OPT2_SLOW) return("opt2_slow"); - if (role == OPT2_SYM) return("opt2_sym"); - if (role == OPT2_PAIR) return("opt2_pair"); - if (role == OPT2_CON) return("opt2_con"); - if (role == OPT2_LAMBDA) return("opt2_lambda"); - if (role == OPT2_DIRECT) return("opt2_direct"); - if (role == OPT2_INT) return("opt2_int"); - return((role == OPT2_NAME) ? "opt2_raw_name" : "opt2_unknown"); -} - -static const char *opt3_role_name(uint64_t role) -{ - if (role == OPT3_ARGLEN) return("opt3_arglen"); - if (role == OPT3_SYM) return("opt3_sym"); - if (role == OPT3_CON) return("opt3_con"); - if (role == OPT3_AND) return("opt3_pair"); - if (role == OPT3_ANY) return("opt3_any"); - if (role == OPT3_LET) return("opt3_let"); - if (role == OPT3_BYTE) return("opt3_byte"); - if (role == OPT3_DIRECT) return("direct_opt3"); - if (role == OPT3_LEN) return("opt3_len"); - if (role == OPT3_INT) return("opt3_int"); - return((role == OPT3_LOCATION) ? "opt3_location" : "opt3_unknown"); -} - -static void show_opt1_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) -{ - char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64, - BOLD_TEXT, func, line, UNBOLD_TEXT, - p, p->object.cons.opt1, - opt1_role_name(role), - p->debugger_bits, bits, (s7_int)role); - free(bits); -} - -static s7_pointer opt1_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - if ((!opt1_is_set(p)) || - ((!opt1_role_matches(p, role)) && - (role != OPT1_ANY))) - { - show_opt1_bits(p, func, line, role); - if (sc->stop_at_error) abort(); - } - return(p->object.cons.opt1); -} - -static void base_opt1(s7_pointer p, uint64_t role) -{ - set_opt1_role(p, role); - set_opt1_is_set(p); -} - -static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, uint64_t role, const char *func, int32_t line) -{ - if (((p->debugger_bits & OPT1_MASK) != role) && - ((p->debugger_bits & OPT1_MASK) == OPT1_LAMBDA) && - (role != OPT1_CFUNC)) - fprintf(stderr, "%s[%d]: opt1_lambda -> %s, op: %s, x: %s,\n %s\n", - func, line, opt1_role_name(role), - (is_optimized(x)) ? op_names[optimize_op(x)] : "unopt", - display(x), display(p)); - p->object.cons.opt1 = x; - base_opt1(p, role); - return(x); -} - -static uint64_t opt1_hash_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt1_is_set(p)) || (!opt1_role_matches(p, OPT1_HASH))) - { - show_opt1_bits(p, func, line, (uint64_t)OPT1_HASH); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.hash); -} - -static void set_opt1_hash_1(s7_pointer p, uint64_t x) -{ - p->object.sym_cons.hash = x; - base_opt1(p, OPT1_HASH); -} - -static void show_opt2_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) -{ - char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt2: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64 " %s", - BOLD_TEXT, func, line, UNBOLD_TEXT, - p, p->object.cons.o2.opt2, - opt2_role_name(role), - p->debugger_bits, bits, (s7_int)role, - opt2_role_name(role)); - free(bits); -} - -static bool f_call_func_mismatch(const char *func) -{ - return((!safe_strcmp(func, "check_and")) && /* these reflect set_fx|unchecked where the destination checks for null fx_proc */ - (!safe_strcmp(func, "check_or")) && - (!safe_strcmp(func, "eval")) && - (!safe_strcmp(func, "set_any_c_np")) && - (!safe_strcmp(func, "set_any_closure_np")) && - (!safe_strcmp(func, "optimize_func_two_args")) && - (!safe_strcmp(func, "optimize_func_many_args")) && - (!safe_strcmp(func, "optimize_func_three_args")) && - (!safe_strcmp(func, "fx_c_ff")) && - (!safe_strcmp(func, "op_map_for_each_fa")) && - (!safe_strcmp(func, "op_map_for_each_faa"))); -} - -static void check_opt2_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - if (!p) - { - fprintf(stderr, "%s%s[%d]: opt2 null!\n%s", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if ((!opt2_is_set(p)) || - (!opt2_role_matches(p, role))) - { - show_opt2_bits(p, func, line, role); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt2_bits(sc, p, role, func, line); - return(p->object.cons.o2.opt2); -} - -static s7_int opt2_n_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt2_bits(sc, p, role, func, line); - return(p->object.cons.o2.n); -} - -static void base_opt2(s7_pointer p, uint64_t role) -{ - set_opt2_role(p, role); - set_opt2_is_set(p); -} - -static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, uint64_t role, const char *func, int32_t line) -{ - if ((role == OPT2_FX) && - (x == NULL) && - (f_call_func_mismatch(func))) - fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n", func, line, - string_value(object_to_truncated_string(sc, p, 80)), - ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? BOLD_TEXT : "", - op_names[optimize_op(car(p))], - ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? UNBOLD_TEXT : ""); - if ((role != OPT2_FX) && (role != OPT2_DIRECT) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */ - { - fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, opt2_role_name(role), display_80(p)); - if (sc->stop_at_error) abort(); - } - p->object.cons.o2.opt2 = x; - base_opt2(p, role); -} - -static void set_opt2_n_1(s7_scheme *unused_sc, s7_pointer p, s7_int x, uint64_t role, const char *unused_func, int32_t unused_line) -{ - p->object.cons.o2.n = x; - base_opt2(p, role); -} - -static const char *opt2_name_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt2_is_set(p)) || - (!opt2_role_matches(p, OPT2_NAME))) - { - show_opt2_bits(p, func, line, (uint64_t)OPT2_NAME); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.fstr); -} - -static void set_opt2_name_1(s7_pointer p, const char *str) -{ - p->object.sym_cons.fstr = str; - base_opt2(p, OPT2_NAME); -} - -static void show_opt3_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) -{ - char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt3: %s %" PRIx64 "%s", BOLD_TEXT, func, line, UNBOLD_TEXT, opt3_role_name(role), p->debugger_bits, bits); - free(bits); -} - -static void check_opt3_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - if (!p) - { - fprintf(stderr, "%s%s[%d]: opt3 null!\n%s", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if ((!opt3_is_set(p)) || - (!opt3_role_matches(p, role))) - { - show_opt3_bits(p, func, line, role); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer opt3_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt3_bits(sc, p, role, func, line); - return(p->object.cons.o3.opt3); -} - -static s7_int opt3_n_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt3_bits(sc, p, role, func, line); - return(p->object.cons.o3.n); -} - -static void base_opt3(s7_pointer p, uint64_t role) -{ - set_opt3_role(p, role); - set_opt3_is_set(p); -} - -static void set_opt3_1(s7_pointer p, s7_pointer x, uint64_t role) -{ - clear_type_bit(p, T_LOCATION); - p->object.cons.o3.opt3 = x; - base_opt3(p, role); -} - -static void set_opt3_n_1(s7_pointer p, s7_int x, uint64_t role) -{ - clear_type_bit(p, T_LOCATION); - p->object.cons.o3.n = x; - base_opt3(p, role); -} - -static uint8_t opt3_byte_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt3_bits(sc, p, role, func, line); - return(p->object.cons.o3.opt_type); -} - -static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint64_t role, const char *unused_func, int32_t unused_line) -{ - clear_type_bit(p, T_LOCATION); - p->object.cons.o3.opt_type = x; - base_opt3(p, role); -} - -static uint64_t opt3_location_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt3_is_set(p)) || - ((p->debugger_bits & OPT3_LOCATION) == 0) || - (!has_location(p))) - { - show_opt3_bits(p, func, line, (uint64_t)OPT3_LOCATION); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.location); -} - -static void set_opt3_location_1(s7_pointer p, uint64_t x) -{ - p->object.sym_cons.location = x; - (p)->debugger_bits = (OPT3_LOCATION | (p->debugger_bits & ~OPT3_LEN)); /* turn on line, cancel len */ - set_opt3_is_set(p); -} - -static uint64_t opt3_len_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt3_is_set(p)) || - ((p->debugger_bits & OPT3_LEN) == 0) || - (has_location(p))) - { - show_opt3_bits(p, func, line, (uint64_t)OPT3_LEN); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.location); -} - -static void set_opt3_len_1(s7_pointer p, uint64_t x) -{ - clear_type_bit(p, T_LOCATION); - p->object.sym_cons.location = x; - (p)->debugger_bits = (OPT3_LEN | (p->debugger_bits & ~(OPT3_LOCATION))); - set_opt3_is_set(p); -} - -static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - /* show current state, current allocated state */ - char *allocated_bits, *str; - int64_t save_full_type = full_type(obj); - s7_int len, nlen; - const char *excl_name = (is_free(obj)) ? "free cell!" : "unknown object!"; - block_t *b; - char *current_bits = describe_type_bits(sc, obj); - - full_type(obj) = obj->alloc_type; - allocated_bits = describe_type_bits(sc, obj); - full_type(obj) = save_full_type; - - len = safe_strlen(excl_name) + safe_strlen(current_bits) + safe_strlen(allocated_bits) + safe_strlen(obj->alloc_func) + 512; - b = mallocate(sc, len); - str = (char *)block_data(b); - nlen = snprintf(str, len, - "\n<%s %s,\n alloc: %s[%d] %s, %d uses>", excl_name, current_bits, - obj->alloc_func, obj->alloc_line, allocated_bits, obj->uses); - free(current_bits); - free(allocated_bits); - if (is_null(port)) - fprintf(stderr, "%p: %s\n", obj, str); - else port_write_string(port)(sc, str, clamp_length(nlen, len), port); - liberate(sc, b); -} - -static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e); -static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func) -{ - if (!p) - { - s7_pointer slot = symbol_to_local_slot(sc, sym, sc->curlet); - char *s = describe_type_bits(sc, sym); - fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line, symbol_name(sym), UNBOLD_TEXT); - fprintf(stderr, " symbol_id: %" ld64 ", let_id: %" ld64 ", bits: %s", symbol_id(sym), let_id(sc->curlet), s); - free(s); - if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot)); - fprintf(stderr, "\n"); - if (sc->stop_at_error) abort(); - } - return(p); -} -#endif /* S7_DEBUGGING */ -/* -------------------------------- end internal debugging apparatus -------------------------------- */ - - -static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1) -{ - set_car(sc->elist_1, x1); - return(sc->elist_1); -} - -static s7_pointer set_elist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) -{ - set_car(sc->elist_2, x1); - set_cadr(sc->elist_2, x2); - return(sc->elist_2); -} - -static s7_pointer set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) -{ - s7_pointer p = sc->elist_3; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); - return(sc->elist_3); -} - -static s7_pointer set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) -{ - s7_pointer p = sc->elist_4; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); p = cdr(p); - set_car(p, x4); - return(sc->elist_4); -} - -static s7_pointer set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5) -{ - set_car(sc->elist_5, x1); - set_elist_4(sc, x2, x3, x4, x5); - return(sc->elist_5); -} - -static s7_pointer set_elist_6(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6) -{ - set_car(sc->elist_6, x1); - set_elist_5(sc, x2, x3, x4, x5, x6); - return(sc->elist_6); -} - -static s7_pointer set_elist_7(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6, s7_pointer x7) -{ - set_car(sc->elist_7, x1); - set_elist_6(sc, x2, x3, x4, x5, x6, x7); - return(sc->elist_7); -} - -static s7_pointer set_wlist_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3) -{ - s7_pointer p = lst; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); - return(lst); -} - -static s7_pointer set_wlist_4(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) -{ - s7_pointer p = lst; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); p = cdr(p); - set_car(p, x4); - return(lst); -} - -static s7_pointer set_mlist_1(s7_scheme *sc, s7_pointer x1) -{ - set_car(sc->mlist_1, x1); - return(sc->mlist_1); -} - -static s7_pointer set_mlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* mlist_3 saves 3 in tmock -- see ~/old/s7-mlist_3.c */ -{ - set_car(sc->mlist_2, x1); - set_cadr(sc->mlist_2, x2); - return(sc->mlist_2); -} - -static s7_pointer set_plist_1(s7_scheme *sc, s7_pointer x1) -{ - set_car(sc->plist_1, x1); - return(sc->plist_1); -} - -static s7_pointer set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) -{ - set_car(sc->plist_2, x1); - set_car(sc->plist_2_2, x2); - return(sc->plist_2); -} - -static s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) -{ - return(set_wlist_3(sc->plist_3, x1, x2, x3)); -} - -static s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */ -{ - set_car(sc->qlist_2, x1); - set_cadr(sc->qlist_2, x2); - return(sc->qlist_2); -} - -static s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) /* let_set_fallback */ -{ - return(set_wlist_3(sc->qlist_3, x1, x2, x3)); -} - -static s7_pointer set_clist_1(s7_scheme *sc, s7_pointer x1) /* for c_object length method etc, a "weak" list */ -{ - set_car(sc->clist_1, x1); - return(sc->clist_1); -} - -static s7_pointer set_clist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* for c_object equal method etc, a "weak" list */ -{ - set_car(sc->clist_2, x1); - set_cadr(sc->clist_2, x2); - return(sc->clist_2); -} - -static s7_pointer set_dlist_1(s7_scheme *sc, s7_pointer x1) /* another like clist: temp usage, "weak" (not gc_marked), but semipermanent list */ -{ - set_car(sc->dlist_1, x1); - return(sc->dlist_1); -} - -static s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) -{ - set_car(sc->u1_1, x1); - set_cdr(sc->u1_1, x2); - return(sc->u1_1); -} - - -/* ---------------- error handlers ---------------- */ -static const char *make_type_name(s7_scheme *sc, const char *name, article_t article) -{ - s7_int i, slen = safe_strlen(name); - s7_int len = slen + 8; - if (len > sc->typnam_len) - { - if (sc->typnam) free(sc->typnam); - sc->typnam = (char *)Malloc(len); - sc->typnam_len = len; - } - if (article == INDEFINITE_ARTICLE) - { - i = 1; - sc->typnam[0] = 'a'; - if ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') || (name[0] == 'o') || (name[0] == 'u')) - sc->typnam[i++] = 'n'; - sc->typnam[i++] = ' '; - } - else i = 0; - memcpy((void *)(sc->typnam + i), (void *)name, slen); - sc->typnam[i + slen] = '\0'; - return(sc->typnam); -} - -static const char *type_name_from_type(int32_t typ, article_t article) -{ - switch (typ) - { - case T_FREE: return((article == NO_ARTICLE) ? "free-cell" : "a free cell"); - case T_NIL: return("nil"); - case T_UNUSED: return((article == NO_ARTICLE) ? "#" : "the unused object"); - case T_EOF: return((article == NO_ARTICLE) ? "#" : "the end-of-file object"); - case T_UNSPECIFIED: return((article == NO_ARTICLE) ? "#" : "the unspecified object"); - case T_UNDEFINED: return((article == NO_ARTICLE) ? "undefined" : "an undefined object"); - case T_BOOLEAN: return("boolean"); - case T_STRING: return((article == NO_ARTICLE) ? "string" : "a string"); - case T_BYTE_VECTOR: return((article == NO_ARTICLE) ? "byte-vector" : "a byte-vector"); - case T_SYMBOL: return((article == NO_ARTICLE) ? "symbol" : "a symbol"); - case T_SYNTAX: return((article == NO_ARTICLE) ? "syntax" : "syntactic"); - case T_PAIR: return((article == NO_ARTICLE) ? "pair" : "a pair"); - case T_GOTO: return((article == NO_ARTICLE) ? "goto" : "a goto (from call-with-exit)"); - case T_CONTINUATION: return((article == NO_ARTICLE) ? "continuation" : "a continuation"); - case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION: return((article == NO_ARTICLE) ? "c-function" : "a c-function"); - case T_C_FUNCTION_STAR: return((article == NO_ARTICLE) ? "c-function*" : "a c-function*"); - case T_CLOSURE: return((article == NO_ARTICLE) ? "function" : "a function"); - case T_CLOSURE_STAR: return((article == NO_ARTICLE) ? "function*" : "a function*"); - case T_C_MACRO: return((article == NO_ARTICLE) ? "c-macro" : "a c-macro"); - case T_C_POINTER: return((article == NO_ARTICLE) ? "c-pointer" : "a c-pointer"); - case T_CHARACTER: return((article == NO_ARTICLE) ? "character" : "a character"); - case T_VECTOR: return((article == NO_ARTICLE) ? "vector" : "a vector"); - case T_INT_VECTOR: return((article == NO_ARTICLE) ? "int-vector" : "an int-vector"); - case T_FLOAT_VECTOR: return((article == NO_ARTICLE) ? "float-vector" : "a float-vector"); - case T_MACRO_STAR: return((article == NO_ARTICLE) ? "macro*" : "a macro*"); - case T_MACRO: return((article == NO_ARTICLE) ? "macro" : "a macro"); - case T_BACRO_STAR: return((article == NO_ARTICLE) ? "bacro*" : "a bacro*"); - case T_BACRO: return((article == NO_ARTICLE) ? "bacro" : "a bacro"); - case T_CATCH: return((article == NO_ARTICLE) ? "catch" : "a catch"); - case T_STACK: return((article == NO_ARTICLE) ? "stack" : "a stack"); - case T_DYNAMIC_WIND: return((article == NO_ARTICLE) ? "dynamic-wind" : "a dynamic-wind"); - case T_HASH_TABLE: return((article == NO_ARTICLE) ? "hash-table" : "a hash-table"); - case T_ITERATOR: return((article == NO_ARTICLE) ? "iterator" : "an iterator"); - case T_LET: return((article == NO_ARTICLE) ? "let" : "a let"); - case T_COUNTER: return((article == NO_ARTICLE) ? "internal-counter" : "an internal counter"); - case T_RANDOM_STATE: return((article == NO_ARTICLE) ? "random-state" : "a random-state"); - case T_SLOT: return((article == NO_ARTICLE) ? "slot" : "a slot (variable binding)"); - case T_INTEGER: return((article == NO_ARTICLE) ? "integer" : "an integer"); - case T_RATIO: return((article == NO_ARTICLE) ? "ratio" : "a ratio"); - case T_REAL: return((article == NO_ARTICLE) ? "real" : "a real"); - case T_COMPLEX: return((article == NO_ARTICLE) ? "complex-number" : "a complex number"); - case T_BIG_INTEGER: return((article == NO_ARTICLE) ? "big-integer" : "a big integer"); - case T_BIG_RATIO: return((article == NO_ARTICLE) ? "big-ratio" : "a big ratio"); - case T_BIG_REAL: return((article == NO_ARTICLE) ? "big-real" : "a big real"); - case T_BIG_COMPLEX: return((article == NO_ARTICLE) ? "big-complex-number": "a big complex number"); - case T_INPUT_PORT: return((article == NO_ARTICLE) ? "input-port" : "an input port"); - case T_OUTPUT_PORT: return((article == NO_ARTICLE) ? "output-port" : "an output port"); - case T_C_OBJECT: return((article == NO_ARTICLE) ? "c-object" : "a c_object"); - } - return(NULL); -} - -static s7_pointer find_let(s7_scheme *sc, s7_pointer obj) -{ - if (is_let(obj)) return(obj); - switch (type(obj)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - return(closure_let(obj)); - case T_C_OBJECT: - return(c_object_let(obj)); - case T_C_POINTER: - if ((is_let(c_pointer_info(obj))) && - (c_pointer_info(obj) != sc->rootlet)) - return(c_pointer_info(obj)); - } - return(sc->nil); -} - -static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - s7_pointer slot; - if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */ - return(sc->undefined); - slot = lookup_slot_from(symbol, let); - if (slot != global_slot(symbol)) - return(slot_value(slot)); - return(sc->undefined); -} - -static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - return(find_method(sc, find_let(sc, let), symbol)); -} - -static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article) -{ - switch (unchecked_type(arg)) - { - case T_C_OBJECT: return(make_type_name(sc, string_value(c_object_scheme_name(sc, arg)), article)); - case T_INPUT_PORT: return(make_type_name(sc, (is_file_port(arg)) ? "input file port" : ((is_string_port(arg)) ? "input string port" : "input port"), article)); - case T_OUTPUT_PORT: return(make_type_name(sc, (is_file_port(arg)) ? "output file port" : ((is_string_port(arg)) ? "output string port" : "output port"), article)); - case T_LET: - if (has_active_methods(sc, arg)) - { - s7_pointer class_name = find_method(sc, arg, sc->class_name_symbol); - if (is_symbol(class_name)) - return(make_type_name(sc, symbol_name(class_name), article)); - } - default: - { - const char *str = type_name_from_type(unchecked_type(arg), article); - if (str) return(str); - }} - return("messed up object"); -} - -static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len); - -static s7_pointer object_type_name(s7_scheme *sc, s7_pointer x) -{ - uint8_t typ; - if (has_active_methods(sc, x)) - { - s7_pointer p = find_method_with_let(sc, x, sc->class_name_symbol); - if (is_symbol(p)) return(symbol_name_cell(p)); - } - typ = type(x); - if (typ < NUM_TYPES) - { - if (typ == T_C_OBJECT) return(c_object_scheme_name(sc, x)); - return(sc->type_names[typ]); - } - return(wrap_string(sc, "unknown type!", 13)); -} - -static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg) -{ - if (type(arg) < NUM_TYPES) - { - s7_pointer p = sc->type_names[type(arg)]; /* these use INDEFINITE_ARTICLE */ - if (is_string(p)) return(p); - } - return(s7_make_string_wrapper(sc, type_name(sc, arg, INDEFINITE_ARTICLE))); -} - - -static noreturn void sole_arg_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) -{ - set_wlist_4(cdr(sc->sole_arg_wrong_type_info), caller, arg, object_type_name(sc, arg), typ); - error_nr(sc, sc->wrong_type_arg_symbol, sc->sole_arg_wrong_type_info); -} - -static /* Inline */ noreturn void wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ) -{ - s7_pointer p = cdr(sc->wrong_type_arg_info); /* info list is '(format_string caller arg_n arg type_name descr) */ - set_car(p, caller); p = cdr(p); - set_car(p, (is_small_int(arg_num)) ? small_int(arg_num) : wrap_integer(sc, arg_num)); p = cdr(p); - set_car(p, arg); p = cdr(p); - set_car(p, object_type_name(sc, arg)); p = cdr(p); - set_car(p, typ); - error_nr(sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info); -} - -s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr) -{ - if (arg_n > 0) - wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg_n, arg, wrap_string(sc, descr, safe_strlen(descr))); - sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg, wrap_string(sc, descr, safe_strlen(descr))); - return(sc->wrong_type_arg_symbol); -} - -s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr) -{ - if (arg_n > 0) wrong_type_error_nr(sc, caller, arg_n, arg, descr); - sole_arg_wrong_type_error_nr(sc, caller, arg, descr); - return(sc->wrong_type_arg_symbol); /* never happens */ -} - -static noreturn void sole_arg_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) -{ - set_wlist_3(cdr(sc->sole_arg_out_of_range_info), caller, arg, descr); - error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); -} - -static noreturn void out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr) -{ - set_wlist_4(cdr(sc->out_of_range_info), caller, arg_n, arg, descr); - error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); -} - -s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr) -{ - if (arg_n > 0) - { - set_wlist_4(cdr(sc->out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), - wrap_integer(sc, arg_n), arg, wrap_string(sc, descr, safe_strlen(descr))); - error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); - } - set_wlist_3(cdr(sc->sole_arg_out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), - arg, wrap_string(sc, descr, safe_strlen(descr))); - error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); - return(sc->out_of_range_symbol); -} - - -static noreturn void wrong_number_of_args_error_nr(s7_scheme *sc, const char *caller, s7_pointer args) -{ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, s7_make_string_wrapper(sc, caller), args)); /* "caller" includes the format directives */ -} - -s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args) -{ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, s7_make_string_wrapper(sc, caller), args)); /* "caller" includes the format directives */ - return(sc->wrong_number_of_args_symbol); -} - - -static noreturn void syntax_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer obj) -{ - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), obj)); -} - -static noreturn void syntax_error_with_caller_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer obj) -{ - error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, errmsg, len), caller, obj)); -} - -static noreturn void syntax_error_with_caller2_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer name, s7_pointer obj) -{ - error_nr(sc, sc->syntax_error_symbol, set_elist_4(sc, wrap_string(sc, errmsg, len), caller, name, obj)); -} - -static noreturn void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj) -{ - error_nr(sc, sc->missing_method_symbol, - set_elist_3(sc, wrap_string(sc, "missing ~S method in ~A", 23), method, - (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : obj)); -} - -static noreturn void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);} - - -/* -------- method handlers -------- */ -s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) -{ - if (has_active_methods(sc, obj)) return(find_method_with_let(sc, obj, method)); - return(sc->undefined); -} - -/* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc */ -#define check_method(Sc, Obj, Method, Args) \ - { \ - s7_pointer func; \ - if ((has_active_methods(Sc, Obj)) && \ - ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ - return(s7_apply_function(Sc, func, Args)); \ - } - -static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) -{ - s7_pointer func = find_method_with_let(sc, obj, method); - if (func == sc->undefined) return(sc->F); - return(s7_apply_function(sc, func, set_mlist_1(sc, obj))); /* plist here and below will probably not work (_pp case known bad) */ -} - -/* this is a macro mainly to simplify the Checker handling */ -#define check_boolean_method(Sc, Checker, Method, Args) \ - { \ - s7_pointer p = car(Args); \ - if (Checker(p)) return(Sc->T); \ - if (!has_active_methods(Sc, p)) return(Sc->F); \ - return(apply_boolean_method(Sc, p, Method)); \ - } - -static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args); -static s7_pointer find_and_apply_method(s7_scheme *sc, s7_pointer obj, s7_pointer sym, s7_pointer args) /* slower if inline */ -{ - s7_pointer func = find_method_with_let(sc, obj, sym); - if (is_closure(func)) return(apply_method_closure(sc, func, args)); - if (func == sc->undefined) missing_method_error_nr(sc, sym, obj); - return(s7_apply_function(sc, func, args)); -} - -static s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, args)); -} - -static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num) -{ - if (has_active_methods(sc, obj)) return(find_and_apply_method(sc, obj, method, args)); - if (sc->type_names[type(obj)] != typ) wrong_type_error_nr(sc, method, num, obj, typ); - if (!is_immutable(obj)) wrong_type_error_nr(sc, method, num, obj, typ); - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, method, obj)); - return(NULL); -} - -static s7_pointer mutable_method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) -{ - return(mutable_method_or_bust(sc, obj, method, set_qlist_3(sc, x1, x2, x3), typ, num)); /* was list_3, plist_3 not safe */ -} - -static s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) -{ - if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj))); -} - -static s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); -} - -static s7_pointer method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_qlist_3(sc, x1, x2, x3))); /* was list_3, plist not safe */ -} - -static s7_pointer method_or_bust_with_type_and_loc_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) -{ - int32_t loc = sc->error_argnum + num; - sc->error_argnum = 0; - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, loc, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); -} - -static s7_pointer method_or_bust_with_type_pi(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_int x2, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, make_integer(sc, x2)))); -} - -static s7_pointer method_or_bust_with_type_pf(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_double x2, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, make_real(sc, x2)))); -} - -static s7_pointer sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ) -{ - if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); - return(find_and_apply_method(sc, obj, method, args)); -} - -static s7_pointer sole_arg_method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) -{ - if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj))); -} - - -/* -------------------------------- constants -------------------------------- */ -/* #f and #t */ -s7_pointer s7_f(s7_scheme *sc) {return(sc->F);} -s7_pointer s7_t(s7_scheme *sc) {return(sc->T);} - - -/* () */ -s7_pointer s7_nil(s7_scheme *sc) {return(sc->nil);} -bool s7_is_null(s7_scheme *sc, s7_pointer p) {return(is_null(p));} -static bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */ - -static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args) -{ - #define H_is_null "(null? obj) returns #t if obj is the empty list" - #define Q_is_null sc->pl_bt - check_boolean_method(sc, is_null, sc->is_null_symbol, args); -} - - -/* # and # */ -s7_pointer s7_undefined(s7_scheme *sc) {return(sc->undefined);} -s7_pointer s7_unspecified(s7_scheme *sc) {return(sc->unspecified);} - -bool s7_is_unspecified(s7_scheme *sc, s7_pointer val) {return(is_unspecified(val));} - -static s7_pointer g_is_undefined(s7_scheme *sc, s7_pointer args) -{ - #define H_is_undefined "(undefined? val) returns #t if val is # or its reader equivalent" - #define Q_is_undefined sc->pl_bt - check_boolean_method(sc, is_undefined, sc->is_undefined_symbol, args); -} - -static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args) -{ - #define H_is_unspecified "(unspecified? val) returns #t if val is #" - #define Q_is_unspecified sc->pl_bt - check_boolean_method(sc, is_unspecified, sc->is_unspecified_symbol, args); -} - - -/* -------------------------------- eof-object? -------------------------------- */ -s7_pointer eof_object = NULL; /* # is an entry in the chars array, so it's not a part of sc */ - -s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);} - -static s7_pointer g_is_eof_object(s7_scheme *sc, s7_pointer args) -{ - #define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object" - #define Q_is_eof_object sc->pl_bt - check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args); -} - -static bool is_eof_object_b_p(s7_pointer p) {return(p == eof_object);} - - -/* -------------------------------- not -------------------------------- */ -static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);} - -static s7_pointer g_not(s7_scheme *sc, s7_pointer args) -{ - #define H_not "(not obj) returns #t if obj is #f, otherwise #t: (not ()) -> #f" - #define Q_not sc->pl_bt - return((car(args) == sc->F) ? sc->T : sc->F); -} - - -/* -------------------------------- boolean? -------------------------------- */ -bool s7_boolean(s7_scheme *sc, s7_pointer x) {return(x != sc->F);} -s7_pointer s7_make_boolean(s7_scheme *sc, bool x) {return(make_boolean(sc, x));} - -bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);} - -static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args) -{ - #define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" - #define Q_is_boolean sc->pl_bt - check_boolean_method(sc, is_boolean, sc->is_boolean_symbol, args); -} - - -/* -------------------------------- constant? -------------------------------- */ -static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_immutable_symbol(sym)) /* for keywords */ - return(true); - if (is_possibly_constant(sym)) - { - s7_pointer slot = lookup_slot_from(sym, sc->curlet); - return((is_slot(slot)) && (is_immutable_slot(slot))); - } - return(false); -} - -#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p))) - -static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args) -{ - #define H_is_constant "(constant? obj) returns #t if obj either evaluates to itself, or is a symbol whose binding is constant" - #define Q_is_constant sc->pl_bt - return(make_boolean(sc, is_constant(sc, car(args)))); -} - -static bool is_constant_b_7p(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));} -static s7_pointer is_constant_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_constant(sc, p)));} - - -/* -------------------------------- immutable? -------------------------------- */ -bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));} - -static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args) -{ - #define H_is_immutable "(immutable? sequence) returns #t if the sequence is immutable" - #define Q_is_immutable sc->pl_bt - s7_pointer p = car(args); - if (is_number(p)) return(sc->T); /* should these be marked immutable? should we use (type != SYMBOL) as above? */ - return(make_boolean(sc, is_immutable(p))); -} - - -/* -------------------------------- immutable! -------------------------------- */ -s7_pointer s7_immutable(s7_pointer p) -{ - set_immutable(p); - return(p); -} - -static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) -{ - #define H_immutable "(immutable! x) declares that the x can't be changed. x is returned." - #define Q_immutable s7_make_signature(sc, 2, sc->T, sc->T) - s7_pointer p = car(args); - if (is_symbol(p)) - { - s7_pointer slot = lookup_slot_from(p, sc->curlet); - if (is_slot(slot)) - { - set_immutable_slot(slot); - return(p); /* symbol is not set immutable ? */ - }} - set_immutable(p); /* could set_immutable save the current file/line? Then the immutable error checks for define-constant and this setting */ - return(p); -} - -/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */ - - -/* -------------------------------- GC -------------------------------- */ -/* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the - * total cell allocations. In snd-test, reals are 50%. slots need not be in the heap, - * but moving them out to their own free list was actually slower because we need (in that - * case) to manage them in the sweep process by tracking lets. - */ - -#if S7_DEBUGGING -static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) -{ - s7_int loc = s7_gc_protect(sc, x); - if (loc > 8192) - { - fprintf(stderr, "infinite loop or memory leak at line %d %s?\n", line, string_value(s7_object_to_string(sc, current_code(sc), false))); - abort(); - } - return(loc); -} -#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__) -#else -#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X) -#endif - -static void resize_gc_protect(s7_scheme *sc) -{ - s7_int size = sc->protected_objects_size; - block_t *ob = vector_block(sc->protected_objects); - s7_int new_size = 2 * size; - block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - block_info(nb) = NULL; - vector_block(sc->protected_objects) = nb; - vector_elements(sc->protected_objects) = (s7_pointer *)block_data(nb); - vector_length(sc->protected_objects) = new_size; - sc->protected_objects_size = new_size; - sc->protected_objects_free_list = (s7_int *)Realloc(sc->protected_objects_free_list, new_size * sizeof(s7_int)); - for (s7_int i = size; i < new_size; i++) - { - vector_element(sc->protected_objects, i) = sc->unused; - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = i; - } -} - -s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x) -{ - s7_int loc; - if (sc->protected_objects_free_list_loc < 0) - resize_gc_protect(sc); - loc = sc->protected_objects_free_list[sc->protected_objects_free_list_loc--]; - vector_element(sc->protected_objects, loc) = x; - return(loc); -} - -void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc) -{ - if (loc < sc->protected_objects_size) - { - if (vector_element(sc->protected_objects, loc) != sc->unused) - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; - else if (S7_DEBUGGING) fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc); - vector_element(sc->protected_objects, loc) = sc->unused; - } -} - -s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc) -{ - s7_pointer obj = sc->unspecified; - if (loc < sc->protected_objects_size) - obj = vector_element(sc->protected_objects, loc); - if (obj == sc->unused) - return(sc->unspecified); - return(obj); -} - -#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc) - -s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc) -{ - vector_element(sc->protected_objects, loc) = x; - return(x); -} - -s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc) -{ - vector_element(sc->protected_objects, loc) = sc->F; - return(sc->F); -} - - -/* these 3 are needed by sweep */ -static void (*mark_function[NUM_TYPES])(s7_pointer p); -void s7_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[unchecked_type(p)])(p);} -static void mark_noop(s7_pointer unused_p) {} - - -static void close_output_port(s7_scheme *sc, s7_pointer p); -static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym); -static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table); - -static void process_iterator(s7_scheme *unused_sc, s7_pointer s1) -{ - if (is_weak_hash_iterator(s1)) - { - s7_pointer h = iterator_sequence(s1); - clear_weak_hash_iterator(s1); - if (unchecked_type(h) == T_HASH_TABLE) - weak_hash_iters(h)--; - } -} - -static void process_multivector(s7_scheme *sc, s7_pointer s1) -{ - vdims_t *info = vector_dimension_info(s1); /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */ - if ((info) && - (info != sc->wrap_only)) - { - if (vector_elements_should_be_freed(info)) /* a kludge for foreign code convenience */ - { - free(any_vector_elements(s1)); - vector_elements_should_be_freed(info) = false; - } - liberate(sc, info); - vector_set_dimension_info(s1, NULL); - } - liberate(sc, vector_block(s1)); -} - -static void process_input_string_port(s7_scheme *sc, s7_pointer s1) -{ -#if S7_DEBUGGING - /* this set of ports is a subset of the ports that respond true to is_string_port -- - * the latter include file ports fully read into local memory; see read_file which uses add_input_port, not add_input_string_port - */ - if (port_filename(s1)) - fprintf(stderr, "string input port has a filename: %s\n", port_filename(s1)); - if (port_needs_free(s1)) - fprintf(stderr, "string input port needs data release\n"); -#endif - liberate(sc, port_block(s1)); -} - -static void free_port_data(s7_scheme *sc, s7_pointer s1) -{ - if (port_data(s1)) - { - liberate(sc, port_data_block(s1)); - port_data_block(s1) = NULL; - port_data(s1) = NULL; - port_data_size(s1) = 0; - } - port_needs_free(s1) = false; -} - -static void close_input_function(s7_scheme *sc, s7_pointer p); - -static void process_input_port(s7_scheme *sc, s7_pointer s1) -{ - if (!port_is_closed(s1)) - { - if (is_file_port(s1)) - { - if (port_file(s1)) - { - fclose(port_file(s1)); - port_file(s1) = NULL; - }} - else - if (is_function_port(s1)) - close_input_function(sc, s1); - } - if (port_needs_free(s1)) - free_port_data(sc, s1); - - if (port_filename(s1)) - { - liberate(sc, port_filename_block(s1)); - port_filename(s1) = NULL; - } - liberate(sc, port_block(s1)); -} - -static void process_output_port(s7_scheme *sc, s7_pointer s1) -{ - close_output_port(sc, s1); /* needed for free filename, etc */ - liberate(sc, port_block(s1)); - if (port_needs_free(s1)) - { - port_needs_free(s1) = false; - if (port_data_block(s1)) - { - liberate(sc, port_data_block(s1)); - port_data_block(s1) = NULL; - }} -} - -static void process_continuation(s7_scheme *sc, s7_pointer s1) -{ - continuation_op_stack(s1) = NULL; - liberate_block(sc, continuation_block(s1)); -} - - -#if WITH_GMP -#if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0))) -static int32_t mpq_cmp_z(const mpq_t op1, const mpz_t op2) -{ - mpq_t z1; - int32_t result; - mpq_init(z1); - mpq_set_z(z1, op2); - result = mpq_cmp(op1, z1); - mpq_clear(z1); - return(result); -} -#endif - -static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n); - -static s7_int s7_integer_clamped_if_gmp(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) - return(integer(p)); - if (is_t_big_integer(p)) - return(big_integer_to_s7_int(sc, big_integer(p))); - return(0); -} - -static void free_big_integer(s7_scheme *sc, s7_pointer p) -{ - big_integer_nxt(p) = sc->bigints; - sc->bigints = big_integer_bgi(p); - big_integer_bgi(p) = NULL; -} - -static void free_big_ratio(s7_scheme *sc, s7_pointer p) -{ - big_ratio_nxt(p) = sc->bigrats; - sc->bigrats = big_ratio_bgr(p); - big_ratio_bgr(p) = NULL; -} - -static void free_big_real(s7_scheme *sc, s7_pointer p) -{ - big_real_nxt(p) = sc->bigflts; - sc->bigflts = big_real_bgf(p); - big_real_bgf(p) = NULL; -} - -static void free_big_complex(s7_scheme *sc, s7_pointer p) -{ - big_complex_nxt(p) = sc->bigcmps; - sc->bigcmps = big_complex_bgc(p); - big_complex_bgc(p) = NULL; -} -#else -#define s7_integer_clamped_if_gmp(Sc, P) integer(P) -#endif - - -static void free_hash_table(s7_scheme *sc, s7_pointer table); - -static void sweep(s7_scheme *sc) -{ - s7_int i, j; - gc_list_t *gp; - - #define process_gc_list(Code) \ - if (gp->loc > 0) \ - { \ - for (i = 0, j = 0; i < gp->loc; i++) \ - { \ - s7_pointer s1 = gp->list[i]; \ - if (is_free_and_clear(s1)) \ - { \ - Code; \ - } \ - else gp->list[j++] = s1; \ - } \ - gp->loc = j; \ - } \ - - gp = sc->strings; - process_gc_list(liberate(sc, string_block(s1))) - - gp = sc->gensyms; - process_gc_list(remove_gensym_from_symbol_table(sc, s1); liberate(sc, gensym_block(s1))) - if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; - - gp = sc->undefineds; - process_gc_list(free(undefined_name(s1))) - - gp = sc->c_objects; - process_gc_list((c_object_gc_free(sc, s1)) ? (void)(*(c_object_gc_free(sc, s1)))(sc, s1) : (void)(*(c_object_free(sc, s1)))(c_object_value(s1))) - - gp = sc->vectors; - process_gc_list(liberate(sc, vector_block(s1))) - - gp = sc->multivectors; - process_gc_list(process_multivector(sc, s1)); - - gp = sc->hash_tables; - if (gp->loc > 0) - { - for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (is_free_and_clear(s1)) - free_hash_table(sc, s1); - else - { - if ((is_weak_hash_table(s1)) && - (weak_hash_iters(s1) == 0) && - (hash_table_entries(s1) > 0)) - cull_weak_hash_table(sc, s1); - gp->list[j++] = s1; - }} - gp->loc = j; - } - - gp = sc->weak_hash_iterators; - process_gc_list(process_iterator(sc, s1)); - - gp = sc->opt1_funcs; - if (gp->loc > 0) - { - for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (!is_free_and_clear(s1)) - gp->list[j++] = s1; - } - gp->loc = j; - } - - gp = sc->input_ports; - process_gc_list(process_input_port(sc, s1)); - - gp = sc->input_string_ports; - process_gc_list(process_input_string_port(sc, s1)); - - gp = sc->output_ports; - process_gc_list(process_output_port(sc, s1)); - - gp = sc->continuations; - process_gc_list(process_continuation(sc, s1)); - - gp = sc->weak_refs; - if (gp->loc > 0) - { - for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (!is_free_and_clear(s1)) - { - if (is_free_and_clear(c_pointer_weak1(s1))) - c_pointer_weak1(s1) = sc->F; - if (is_free_and_clear(c_pointer_weak2(s1))) - c_pointer_weak2(s1) = sc->F; - if ((c_pointer_weak1(s1) != sc->F) || - (c_pointer_weak2(s1) != sc->F)) - gp->list[j++] = s1; - }} - gp->loc = j; - } - -#if WITH_GMP - gp = sc->big_integers; - process_gc_list(free_big_integer(sc, s1)) - - gp = sc->big_ratios; - process_gc_list(free_big_ratio(sc ,s1)) - - gp = sc->big_reals; - process_gc_list(free_big_real(sc, s1)) - - gp = sc->big_complexes; - process_gc_list(free_big_complex(sc, s1)) - - gp = sc->big_random_states; - process_gc_list(gmp_randclear(random_gmp_state(s1))) -#endif -} - -static /* inline */ void add_to_gc_list(gc_list_t *gp, s7_pointer p) /* why inline here? (not tgc) */ -{ - if (gp->loc == gp->size) - { - gp->size *= 2; - gp->list = (s7_pointer *)Realloc(gp->list, gp->size * sizeof(s7_pointer)); - } - gp->list[gp->loc++] = p; -} - -static gc_list_t *make_gc_list(void) -{ - gc_list_t *gp = (gc_list_t *)Malloc(sizeof(gc_list_t)); - #define INIT_GC_CACHE_SIZE 4 - gp->size = INIT_GC_CACHE_SIZE; - gp->loc = 0; - gp->list = (s7_pointer *)Malloc(gp->size * sizeof(s7_pointer)); - return(gp); -} - -static void just_mark(s7_pointer p) {set_mark(p);} - -static void add_gensym(s7_scheme *sc, s7_pointer p) -{ - add_to_gc_list(sc->gensyms, p); - mark_function[T_SYMBOL] = just_mark; -} - -#define add_c_object(sc, p) add_to_gc_list(sc->c_objects, p) -#define add_hash_table(sc, p) add_to_gc_list(sc->hash_tables, p) -#define add_string(sc, p) add_to_gc_list(sc->strings, p) -#define add_input_port(sc, p) add_to_gc_list(sc->input_ports, p) -#define add_input_string_port(sc, p) add_to_gc_list(sc->input_string_ports, p) -#define add_output_port(sc, p) add_to_gc_list(sc->output_ports, p) -#define add_continuation(sc, p) add_to_gc_list(sc->continuations, p) -#define add_undefined(sc, p) add_to_gc_list(sc->undefineds, p) -#define add_vector(sc, p) add_to_gc_list(sc->vectors, p) -#define add_multivector(sc, p) add_to_gc_list(sc->multivectors, p) -#define add_weak_ref(sc, p) add_to_gc_list(sc->weak_refs, p) -#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc->weak_hash_iterators, p) -#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0) - -#if WITH_GMP -#define add_big_integer(sc, p) add_to_gc_list(sc->big_integers, p) -#define add_big_ratio(sc, p) add_to_gc_list(sc->big_ratios, p) -#define add_big_real(sc, p) add_to_gc_list(sc->big_reals, p) -#define add_big_complex(sc, p) add_to_gc_list(sc->big_complexes, p) -#define add_big_random_state(sc, p) add_to_gc_list(sc->big_random_states, p) -#endif - -static void init_gc_caches(s7_scheme *sc) -{ - sc->strings = make_gc_list(); - sc->gensyms = make_gc_list(); - sc->undefineds = make_gc_list(); - sc->vectors = make_gc_list(); - sc->multivectors = make_gc_list(); - sc->hash_tables = make_gc_list(); - sc->input_ports = make_gc_list(); - sc->input_string_ports = make_gc_list(); - sc->output_ports = make_gc_list(); - sc->continuations = make_gc_list(); - sc->c_objects = make_gc_list(); - sc->weak_refs = make_gc_list(); - sc->weak_hash_iterators = make_gc_list(); - sc->opt1_funcs = make_gc_list(); -#if WITH_GMP - sc->big_integers = make_gc_list(); - sc->big_ratios = make_gc_list(); - sc->big_reals = make_gc_list(); - sc->big_complexes = make_gc_list(); - sc->big_random_states = make_gc_list(); - sc->ratloc = NULL; -#endif - /* slightly unrelated... */ - sc->setters_size = 4; - sc->setters_loc = 0; - sc->setters = (s7_pointer *)Malloc(sc->setters_size * sizeof(s7_pointer)); -} - -static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, uint64_t type); - -static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) -{ - /* setters GC-protected. The c_function_setter field can't be used because the built-in functions - * are often removed from the heap and never thereafter marked. Only closures and macros are protected here. - */ - for (s7_int i = 0; i < sc->setters_loc; i++) - { - s7_pointer x = sc->setters[i]; - if (car(x) == p) - { - set_cdr(x, setter); - return; - }} - if (sc->setters_loc == sc->setters_size) - { - sc->setters_size *= 2; - sc->setters = (s7_pointer *)Realloc(sc->setters, sc->setters_size * sizeof(s7_pointer)); - } - sc->setters[sc->setters_loc++] = semipermanent_cons(sc, p, setter, T_PAIR | T_IMMUTABLE); -} - - -static inline void gc_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[unchecked_type(p)])(p);} - -static void mark_symbol_vector(s7_pointer p, s7_int len) -{ - set_mark(p); - if (mark_function[T_SYMBOL] != mark_noop) /* else no gensyms */ - { - s7_pointer *e = vector_elements(p); - for (s7_int i = 0; i < len; i++) - if ((is_symbol(e[i])) && (is_gensym(e[i]))) /* need is_symbol: make-vector + set! vector-typer symbol? where init is not a symbol */ - set_mark(e[i]); - } -} - -static void mark_simple_vector(s7_pointer p, s7_int len) -{ - s7_pointer *e = vector_elements(p); - set_mark(p); - for (s7_int i = 0; i < len; i++) - set_mark(e[i]); -} - -static void just_mark_vector(s7_pointer p, s7_int unused_len) {set_mark(p);} - -static void mark_vector_1(s7_pointer p, s7_int top) -{ - s7_pointer *tp = (s7_pointer *)(vector_elements(p)); - s7_pointer *tend, *tend4; - set_mark(p); - if (!tp) return; - tend = (s7_pointer *)(tp + top); - tend4 = (s7_pointer *)(tend - 8); - while (tp <= tend4) - LOOP_8(gc_mark(*tp++)); - while (tp < tend) - gc_mark(*tp++); -} - -static void mark_typed_vector_1(s7_pointer p, s7_int top) /* for typed vectors with closure setters */ -{ - gc_mark(typed_vector_typer(p)); - mark_vector_1(p, top); -} - -static inline void mark_slot(s7_pointer p) -{ - set_mark(T_Slt(p)); - gc_mark(slot_value(p)); - if (slot_has_setter(p)) - gc_mark(slot_setter(p)); - if (slot_has_pending_value(p)) - gc_mark(slot_pending_value(p)); - set_mark(slot_symbol(p)); -} - -static void mark_let(s7_pointer let) -{ - for (s7_pointer x = let; is_let(x) && (!is_marked(x)); x = let_outlet(x)) /* let can be sc->nil, e.g. closure_let */ - { - set_mark(x); - if (has_dox_slot1(x)) mark_slot(let_dox_slot1(x)); - if ((has_dox_slot2(x)) && (is_slot(let_dox_slot2(x)))) mark_slot(let_dox_slot2(x)); - /* it can happen (call/cc related) that let_dox_slot2 is a slot but invalid, but in that case has_dox_slot2 will not be set(?) */ - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (!is_marked(y)) /* slot value might be the enclosing let */ - mark_slot(y); - } -} - -#if WITH_HISTORY -static void gc_owlet_mark(s7_pointer tp) -{ - /* gc_mark but if tp is a pair ignore the marked bit on unheaped entries */ - if (is_pair(tp)) - { - s7_pointer p = tp; - do { - set_mark(p); - gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */ - p = cdr(p); - } while ((is_pair(p)) && (p != tp) && ((!in_heap(p)) || (!is_marked(p)))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ - gc_mark(p); - } - else - if (!is_marked(tp)) - (*mark_function[unchecked_type(tp)])(tp); -} -#endif - -static void mark_owlet(s7_scheme *sc) -{ -#if WITH_HISTORY - { - for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) - { - gc_owlet_mark(car(p1)); - gc_owlet_mark(car(p2)); - gc_owlet_mark(car(p3)); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; /* these are circular lists */ - }} -#endif - /* sc->error_type and friends are slots in owlet */ - mark_slot(sc->error_type); - slot_set_value(sc->error_data, sc->F); /* or maybe mark_tree(slot_value(sc->error_data)) ? */ - mark_slot(sc->error_data); - mark_slot(sc->error_code); - mark_slot(sc->error_line); - mark_slot(sc->error_file); - mark_slot(sc->error_position); -#if WITH_HISTORY - mark_slot(sc->error_history); -#endif - set_mark(sc->owlet); - mark_let(let_outlet(sc->owlet)); -} - -static void mark_c_pointer(s7_pointer p) -{ - set_mark(p); - gc_mark(c_pointer_type(p)); - gc_mark(c_pointer_info(p)); -} - -static void mark_c_proc_star(s7_pointer p) -{ - set_mark(p); - if ((!c_func_has_simple_defaults(p)) && - (c_function_call_args(p))) /* NULL if not a safe function */ - for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) - gc_mark(car(arg)); -} - -static void mark_pair(s7_pointer p) -{ - do { - set_mark(p); - gc_mark(car(p)); /* expanding this to avoid recursion is slower */ - p = cdr(p); - } while ((is_pair(p)) && (!is_marked(p))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ - gc_mark(p); -} - -static void mark_counter(s7_pointer p) -{ - set_mark(p); - gc_mark(counter_result(p)); - gc_mark(counter_list(p)); - gc_mark(counter_let(p)); -} - -static void mark_closure(s7_pointer p) -{ - set_mark(p); - gc_mark(closure_args(p)); - gc_mark(closure_body(p)); - mark_let(closure_let(p)); - gc_mark(closure_setter_or_map_list(p)); -} - -static void mark_stack_1(s7_pointer p, s7_int top) -{ - s7_pointer *tp = (s7_pointer *)(stack_elements(p)), *tend; - set_mark(p); - if (!tp) return; - tend = (s7_pointer *)(tp + top); - while (tp < tend) - { - gc_mark(*tp++); - gc_mark(*tp++); - gc_mark(*tp++); - tp++; - } -} - -static void mark_stack(s7_pointer p) -{ - /* we can have a bare stack waiting for a continuation to hold it if the new_cell for the continuation triggers the GC! But we need a top-of-stack?? */ - mark_stack_1(p, temp_stack_top(p)); -} - -static void mark_continuation(s7_pointer p) -{ - set_mark(p); - if (!is_marked(continuation_stack(p))) /* can these be cyclic? */ - mark_stack_1(continuation_stack(p), continuation_stack_top(p)); - gc_mark(continuation_op_stack(p)); -} - -static void mark_vector(s7_pointer p) -{ - if (is_typed_vector(p)) - typed_vector_gc_mark(p)(p, vector_length(p)); - else mark_vector_1(p, vector_length(p)); -} - -static void mark_vector_possibly_shared(s7_pointer p) -{ - /* If a subvector (an inner dimension) of a vector is the only remaining reference - * to the main vector, we want to make sure the main vector is not GC'd until - * the subvector is also GC-able. The subvector field either points to the - * parent vector, or it is sc->F, so we need to check for a vector parent if - * the current is multidimensional (this will include 1-dim slices). We need - * to keep the parent case separate (i.e. sc->F means the current is the original) - * so that we only free once (or remove_from_heap once). - * - * If we have a subvector of a subvector, and the middle and original are not otherwise - * in use, we mark the middle one, but (since it itself is not in use anywhere else) - * we don't mark the original! So we need to follow the share-vector chain marking every one. - * - * To remove a cell from the heap, we need its current heap location so that we can replace it. - * The heap is allocated as needed in monolithic blocks of (say) 1/2M s7_cells. When a cell - * is replaced, the new cell (at heap[x] say) is no longer from the original block. Since the - * GC clears all type bits when it frees a cell, we can't use a type bit to distinguish the - * replacements from the originals, but we need that info because in the base case, we use - * the distance of the cell from the base cell to get "x", its location. In the replacement - * case, we add the location at the end of the s7_cell (s7_big_cell). We track the current - * heap blocks via the sc->heap_blocks list. To get the location of "p" above, we run through - * that list looking for a block it fits in. If none is found, we assume it is an s7_big_cell - * and use the saved location. - */ - if (is_subvector(p)) - mark_vector_possibly_shared(subvector_vector(p)); - - /* mark_vector_1 does not check the marked bit, so if subvector below is in a cycle involving - * the calling vector, we get infinite recursion unless we check the mark bit here. - */ - if (!is_marked(p)) - mark_vector_1(p, vector_length(p)); -} - -static void mark_int_or_float_vector(s7_pointer p) {set_mark(p);} - -static void mark_int_or_float_vector_possibly_shared(s7_pointer p) -{ - if (is_subvector(p)) - mark_int_or_float_vector_possibly_shared(subvector_vector(p)); - set_mark(p); -} - -static void mark_c_object(s7_pointer p) -{ - set_mark(p); - if (c_object_gc_mark(c_object_s7(p), p)) - (*(c_object_gc_mark(c_object_s7(p), p)))(c_object_s7(p), p); - else (*(c_object_mark(c_object_s7(p), p)))(c_object_value(p)); -} - -static void mark_catch(s7_pointer p) -{ - set_mark(p); - gc_mark(catch_tag(p)); - gc_mark(catch_handler(p)); -} - -static void mark_dynamic_wind(s7_pointer p) -{ - set_mark(p); - gc_mark(dynamic_wind_in(p)); - gc_mark(dynamic_wind_out(p)); - gc_mark(dynamic_wind_body(p)); -} - -static void mark_hash_table(s7_pointer p) -{ - set_mark(p); - gc_mark(hash_table_procedures(p)); - if (is_pair(hash_table_procedures(p))) - { - gc_mark(hash_table_key_typer_unchecked(p)); /* unchecked to avoid s7-debugger's reference to sc */ - gc_mark(hash_table_value_typer_unchecked(p)); - } - if (hash_table_entries(p) > 0) - { - s7_int len = hash_table_mask(p) + 1; - hash_entry_t **entries = hash_table_elements(p); - hash_entry_t **last = (hash_entry_t **)(entries + len); - - if ((is_weak_hash_table(p)) && - (weak_hash_iters(p) == 0)) - while (entries < last) - { - hash_entry_t *xp; - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - gc_mark(hash_entry_value(xp)); - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - gc_mark(hash_entry_value(xp)); - } - else - while (entries < last) /* counting entries here was slightly faster */ - { - hash_entry_t *xp; - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - { - gc_mark(hash_entry_key(xp)); - gc_mark(hash_entry_value(xp)); - } - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - { - gc_mark(hash_entry_key(xp)); - gc_mark(hash_entry_value(xp)); - }}} -} - -static void mark_iterator(s7_pointer p) -{ - set_mark(p); - gc_mark(iterator_sequence(p)); - if (is_mark_seq(p)) - gc_mark(iterator_current(p)); -} - -static void mark_input_port(s7_pointer p) -{ - set_mark(p); - gc_mark(port_string_or_function(p)); -} - -static void mark_output_port(s7_pointer p) -{ - set_mark(p); - if (is_function_port(p)) - gc_mark(port_string_or_function(p)); -} - -#define clear_type(p) full_type(p) = T_FREE - -static void init_mark_functions(void) -{ - mark_function[T_FREE] = mark_noop; - mark_function[T_UNDEFINED] = just_mark; - mark_function[T_EOF] = mark_noop; - mark_function[T_UNSPECIFIED] = mark_noop; - mark_function[T_NIL] = mark_noop; - mark_function[T_UNUSED] = mark_noop; - mark_function[T_BOOLEAN] = mark_noop; - mark_function[T_SYNTAX] = mark_noop; - mark_function[T_CHARACTER] = mark_noop; - mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */ - mark_function[T_STRING] = just_mark; - mark_function[T_INTEGER] = just_mark; - mark_function[T_RATIO] = just_mark; - mark_function[T_REAL] = just_mark; - mark_function[T_COMPLEX] = just_mark; - mark_function[T_BIG_INTEGER] = just_mark; - mark_function[T_BIG_RATIO] = just_mark; - mark_function[T_BIG_REAL] = just_mark; - mark_function[T_BIG_COMPLEX] = just_mark; - mark_function[T_RANDOM_STATE] = just_mark; - mark_function[T_GOTO] = just_mark; - mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */ - mark_function[T_C_MACRO] = just_mark; - mark_function[T_C_POINTER] = mark_c_pointer; - mark_function[T_C_FUNCTION] = just_mark; - mark_function[T_C_FUNCTION_STAR] = just_mark; /* changes to mark_c_proc_star if defaults involve an expression */ - mark_function[T_C_RST_NO_REQ_FUNCTION] = just_mark; - mark_function[T_PAIR] = mark_pair; - mark_function[T_CLOSURE] = mark_closure; - mark_function[T_CLOSURE_STAR] = mark_closure; - mark_function[T_CONTINUATION] = mark_continuation; - mark_function[T_INPUT_PORT] = mark_input_port; - mark_function[T_VECTOR] = mark_vector; /* this changes if subvector created (similarly below) */ - mark_function[T_INT_VECTOR] = mark_int_or_float_vector; - mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector; - mark_function[T_BYTE_VECTOR] = just_mark; - mark_function[T_MACRO] = mark_closure; - mark_function[T_BACRO] = mark_closure; - mark_function[T_MACRO_STAR] = mark_closure; - mark_function[T_BACRO_STAR] = mark_closure; - mark_function[T_C_OBJECT] = mark_c_object; - mark_function[T_CATCH] = mark_catch; - mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind; - mark_function[T_HASH_TABLE] = mark_hash_table; - mark_function[T_ITERATOR] = mark_iterator; - mark_function[T_LET] = mark_let; - mark_function[T_STACK] = mark_stack; - mark_function[T_COUNTER] = mark_counter; - mark_function[T_SLOT] = mark_slot; -} - -static void mark_op_stack(s7_scheme *sc) -{ - s7_pointer *p = sc->op_stack; - s7_pointer *tp = sc->op_stack_now; - while (p < tp) - gc_mark(*p++); -} - -static void mark_input_port_stack(s7_scheme *sc) -{ - s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc); - for (s7_pointer *p = sc->input_port_stack; p < tp; p++) - gc_mark(*p); -} - -static void mark_rootlet(s7_scheme *sc) -{ - s7_pointer ge = sc->rootlet; - s7_pointer *tmp = rootlet_elements(ge); - s7_pointer *top = (s7_pointer *)(tmp + sc->rootlet_entries); - set_mark(ge); - while (tmp < top) - gc_mark(slot_value(*tmp++)); - /* slot_setter is handled below with an explicit list -- more code than its worth probably */ - /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected - * (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0, - * but I can't get it to break, so they must be protected somehow; apparently they are - * removed from the heap! At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit) - * removes the function from the heap (protecting the gensym). - */ -} - -/* mark_closure calls mark_let on closure_let(func) which marks slot values. - * if we move rootlet to end, unmarked closures at that point could mark let/slot but not slot value? - * or save safe-closure lets to handle all at end? or a gc_list of safe closure lets and only mark let if not safe? - */ - -static void mark_semipermanent_objects(s7_scheme *sc) -{ - for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) - gc_mark(g->p); - /* semipermanent_objects also has lets (removed from heap) -- should they be handled like semipermanent_lets? - * if unmarked should either be removed from the list and perhaps placed on a free list? - * if outlet is free can the let potentially be in use? - * there are many more semipermanent_lets(slots) than semipermanent objects - */ -} -/* do we mark funclet slot values from the function as root? Maybe treat them like semipermanent_lets here? */ - -static void unmark_semipermanent_objects(s7_scheme *sc) -{ - gc_obj_t *g; - for (g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) - clear_mark(g->p); - for (g = sc->semipermanent_lets; g; g = (gc_obj_t *)(g->nxt)) /* there are lets and slots in this list */ - clear_mark(g->p); -} - -#if (!MS_WINDOWS) - #include - #include -#endif - -static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */ -#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name)) - -#if WITH_GCC -static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); -#else -static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); -#endif - -#if S7_DEBUGGING -static int64_t gc(s7_scheme *sc, const char *func, int32_t line) -#else -static int64_t gc(s7_scheme *sc) -#endif -{ - s7_cell **old_free_heap_top; - s7_int i; - - if (sc->gc_in_progress) - error_nr(sc, sc->error_symbol, set_elist_1(sc, wrap_string(sc, "GC called recursively", 21))); - sc->gc_in_progress = true; - sc->gc_start = my_clock(); - sc->gc_calls++; -#if S7_DEBUGGING - sc->last_gc_line = line; -#endif - sc->continuation_counter = 0; - - mark_rootlet(sc); - mark_owlet(sc); - - gc_mark(sc->code); - if (sc->args) gc_mark(sc->args); - gc_mark(sc->curlet); /* not mark_let because op_any_closure_3p uses sc->curlet as a temp!! */ - mark_current_code(sc); /* probably redundant if with_history */ - gc_mark(sc->value); - - mark_stack_1(sc->stack, current_stack_top(sc)); - set_mark(current_input_port(sc)); - mark_input_port_stack(sc); - set_mark(current_output_port(sc)); - set_mark(sc->error_port); - gc_mark(sc->stacktrace_defaults); - gc_mark(sc->autoload_table); - gc_mark(sc->default_random_state); - if (sc->let_temp_hook) gc_mark(sc->let_temp_hook); - - gc_mark(sc->w); - gc_mark(sc->x); - gc_mark(sc->y); - gc_mark(sc->z); - gc_mark(sc->temp1); - gc_mark(sc->temp2); - gc_mark(sc->temp3); - gc_mark(sc->temp4); - gc_mark(sc->temp5); - gc_mark(sc->temp7); - gc_mark(sc->temp8); - gc_mark(sc->temp9); - gc_mark(sc->temp10); - - gc_mark(car(sc->t1_1)); - gc_mark(car(sc->t2_1)); gc_mark(car(sc->t2_2)); - gc_mark(car(sc->t3_1)); gc_mark(car(sc->t3_2)); gc_mark(car(sc->t3_3)); - gc_mark(car(sc->t4_1)); - gc_mark(car(sc->mlist_1)); - gc_mark(car(sc->mlist_2)); gc_mark(cadr(sc->mlist_2)); - gc_mark(car(sc->plist_1)); - gc_mark(car(sc->plist_2)); gc_mark(cadr(sc->plist_2)); - gc_mark(car(sc->plist_3)); gc_mark(cadr(sc->plist_3)); gc_mark(caddr(sc->plist_3)); - gc_mark(car(sc->qlist_2)); gc_mark(cadr(sc->qlist_2)); - gc_mark(car(sc->qlist_3)); - gc_mark(car(sc->u1_1)); - - gc_mark(sc->rec_p1); - gc_mark(sc->rec_p2); - - /* these probably don't need to be marked */ - for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - - gc_mark(car(sc->elist_1)); - gc_mark(car(sc->elist_2)); gc_mark(cadr(sc->elist_2)); - gc_mark(car(sc->elist_3)); gc_mark(cadr(sc->elist_3)); gc_mark(caddr(sc->elist_3)); - gc_mark(car(sc->elist_4)); - gc_mark(car(sc->elist_5)); - gc_mark(car(sc->elist_6)); - gc_mark(car(sc->elist_7)); - - for (i = 1; i < NUM_SAFE_LISTS; i++) - if ((is_pair(sc->safe_lists[i])) && - (list_is_in_use(sc->safe_lists[i]))) - for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) - gc_mark(car(p)); - - for (i = 0; i < sc->setters_loc; i++) - gc_mark(cdr(sc->setters[i])); - - for (i = 0; i <= sc->format_depth; i++) /* sc->num_fdats is size of array */ - if (sc->fdats[i]) - gc_mark(sc->fdats[i]->curly_arg); - - if (sc->rec_stack) - { - just_mark(sc->rec_stack); - for (i = 0; i < sc->rec_loc; i++) - gc_mark(sc->rec_els[i]); - } - mark_vector(sc->protected_objects); - mark_vector(sc->protected_setters); - set_mark(sc->protected_setter_symbols); - if ((is_symbol(sc->profile_prefix)) && (is_gensym(sc->profile_prefix))) set_mark(sc->profile_prefix); - - /* protect recent allocations using the free_heap cells above the current free_heap_top (if any). - * cells above sc->free_heap_top might be malloc'd garbage (after heap reallocation), so we keep track of - * where the last actually freed cells were after the previous GC call. We're trying to - * GC protect the previous GC_TEMPS_SIZE allocated pointers so that the caller doesn't have - * to gc-protect every temporary cell. - */ - { - s7_pointer *tmps = sc->free_heap_top; - s7_pointer *tmps_top = tmps + sc->gc_temps_size; - if (tmps_top > sc->previous_free_heap_top) - tmps_top = sc->previous_free_heap_top; - while (tmps < tmps_top) - gc_mark(*tmps++); - } - mark_op_stack(sc); - mark_semipermanent_objects(sc); - - if (sc->profiling_gensyms) - { - profile_data_t *pd = sc->profile_data; - for (i = 0; i < pd->top; i++) - if ((pd->funcs[i]) && (is_gensym(pd->funcs[i]))) - set_mark(pd->funcs[i]); - } - - { - gc_list_t *gp = sc->opt1_funcs; - for (i = 0; i < gp->loc; i++) - { - s7_pointer s1 = T_Pair(gp->list[i]); - if ((is_marked(s1)) && (!is_marked(opt1_any(s1)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ - gc_mark(opt1_any(s1)); /* not set_mark -- need to protect let/body/args as well */ - }} - - /* free up all unmarked objects */ - old_free_heap_top = sc->free_heap_top; - { - s7_pointer *fp = sc->free_heap_top; - s7_pointer *tp = sc->heap; - s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); - -#if S7_DEBUGGING - #define gc_object(Tp) \ - p = (*Tp++); \ - if (signed_type(p) > 0) \ - { \ - p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ - if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ - signed_type(p) = 0; \ - (*fp++) = p; \ - } \ - else if (signed_type(p) < 0) clear_mark(p); -#else - #define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {signed_type(p) = 0; (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); - /* this appears to be about 10% faster than the previous form - * if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but - * it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug - * (this case is caught by has_odd_bits). If ignored, the type will be set, and later the bit cleared, so no problem? - * An alternate form that simply calls clear_mark (no check for < 0) appears to be the same speed even in cases with lots - * of long-lived objects. - */ -#endif - while (tp < heap_top) /* != here or ^ makes no difference, and going to 64 (from 32) doesn't matter */ - { - s7_pointer p; - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - } - /* I tried using pthreads here, since there is no need for a lock in this loop, but the *fp++ part needs to - * be local to each thread, then merged at the end. In my timing tests, the current version was faster. - * If NUM_THREADS=2, and all thread variables are local, surely there's no "false sharing"? - */ - sc->free_heap_top = fp; - sweep(sc); - } - - unmark_semipermanent_objects(sc); - sc->gc_freed = (int64_t)(sc->free_heap_top - old_free_heap_top); - sc->gc_total_freed += sc->gc_freed; - sc->gc_end = my_clock(); - sc->gc_total_time += (sc->gc_end - sc->gc_start); - - if (show_gc_stats(sc)) - { -#if (!MS_WINDOWS) -#if S7_DEBUGGING - s7_warn(sc, 512, "%s[%d]: gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", func, line, - sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); -#else - s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", - sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); -#endif -#else - s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size); -#endif - } - if (show_protected_objects_stats(sc)) - { - s7_int num, len = vector_length(sc->protected_objects); /* allocated at startup */ - for (i = 0, num = 0; i < len; i++) - if (vector_element(sc->protected_objects, i) != sc->unused) - num++; - s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", num, len); - } - sc->previous_free_heap_top = sc->free_heap_top; - sc->gc_in_progress = false; - return(sc->gc_freed); -} - - -#ifndef GC_RESIZE_HEAP_FRACTION - #define GC_RESIZE_HEAP_FRACTION 0.8 -/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap) - * in my tests, only tvect.scm ends up larger if 3/4 used - */ -#endif - -#define GC_RESIZE_HEAP_BY_4_FRACTION 0.67 -/* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */ - - -#if S7_DEBUGGING -#define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__) -static void resize_heap_to_1(s7_scheme *sc, int64_t size, const char *func, int line) -#else -static void resize_heap_to(s7_scheme *sc, int64_t size) -#endif -{ - int64_t old_size = sc->heap_size; - int64_t old_free = sc->free_heap_top - sc->free_heap; - s7_cell *cells; - s7_cell **cp; - heap_block_t *hp; - -#if (S7_DEBUGGING) && (!MS_WINDOWS) - if (show_gc_stats(sc)) - s7_warn(sc, 512, "%s from %s[%d]: old: %" ld64 " / %ld, new: %" ld64 ", fraction: %.3f -> %" ld64 "\n", - __func__, func, line, old_free, old_size, size, sc->gc_resize_heap_fraction, (int64_t)(floor(sc->heap_size * sc->gc_resize_heap_fraction))); -#endif - - if (size == 0) - { - if (old_free < old_size * sc->gc_resize_heap_by_4_fraction) - sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */ - else sc->heap_size *= 2; - if (sc->gc_resize_heap_fraction > .4) - sc->gc_resize_heap_fraction *= .95; - } - else - if (size > sc->heap_size) - while (sc->heap_size < size) sc->heap_size *= 2; - else return; - /* do not call new_cell here! */ -#if POINTER_32 - if (((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) - { /* can this happen in 64-bit land? SIZE_MAX is unsigned int in 32-bit, unsigned long in 64 bit = UINTPTR_MAX = 18446744073709551615UL */ - s7_warn(sc, 256, "heap size requested, %" ld64 " => %" ld64 " bytes, is greater than size_t: %u\n", - sc->heap_size, - (2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell)), - SIZE_MAX); - sc->heap_size = old_size + 64000; - } -#endif - cp = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); - if (cp) - sc->heap = cp; - else - { - s7_warn(sc, 256, "heap reallocation failed! tried to get %" ld64 " bytes (will retry with a smaller amount)\n", - (int64_t)(sc->heap_size * sizeof(s7_cell *))); - sc->heap_size = old_size + 64000; - sc->heap = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); - } - sc->free_heap = (s7_cell **)Realloc(sc->free_heap, sc->heap_size * sizeof(s7_cell *)); - sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE); - sc->free_heap_top = sc->free_heap + old_free; /* incremented below, added old_free 21-Aug-12?!? */ - - cells = (s7_cell *)Calloc(sc->heap_size - old_size, sizeof(s7_cell)); /* Malloc + clear_type below is much slower?! */ - add_saved_pointer(sc, (void *)cells); - { - s7_pointer p = cells; - for (int64_t k = old_size; k < sc->heap_size;) - { - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - }} - hp = (heap_block_t *)Malloc(sizeof(heap_block_t)); - hp->start = (intptr_t)cells; - hp->end = (intptr_t)cells + ((sc->heap_size - old_size) * sizeof(s7_cell)); - hp->offset = old_size; - hp->next = sc->heap_blocks; - sc->heap_blocks = hp; - sc->previous_free_heap_top = sc->free_heap_top; - - if (show_heap_stats(sc)) - { - const char *str = string_value(object_to_truncated_string(sc, current_code(sc), 80)); - if (size != 0) - s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ") from %s\n", - sc->heap_size, old_free, old_size, size, str); - else s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ") from %s\n", - sc->heap_size, old_free, old_size, str); - } - if (sc->heap_size >= sc->max_heap_size) - error_nr(sc, make_symbol(sc, "heap-too-big", 12), - set_elist_3(sc, wrap_string(sc, "heap has grown past (*s7* 'max-heap-size): ~S > ~S", 50), - wrap_integer(sc, sc->max_heap_size), - wrap_integer(sc, sc->heap_size))); -} - - -#define resize_heap(Sc) resize_heap_to(Sc, 0) - -#if S7_DEBUGGING -#define call_gc(Sc) gc(Sc, __func__, __LINE__) -static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line) -#else -#define call_gc(Sc) gc(Sc) -static void try_to_call_gc(s7_scheme *sc) -#endif -{ - /* called only from new_cell */ - if (sc->gc_off) /* we can't just return here! Someone needs a new cell, and once the heap free list is exhausted, segfault */ - resize_heap(sc); - else - { - if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304)) - sc->gc_resize_heap_fraction = 0.5; -#if S7_DEBUGGING - gc(sc, func, line); /* not call_gc! */ -#else - gc(sc); -#endif - if ((int64_t)(sc->free_heap_top - sc->free_heap) < (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */ - resize_heap(sc); - } -} - /* originally I tried to mark each temporary value until I was done with it, but that way madness lies... By delaying - * GC of _every_ %$^#%@ pointer, I can dispense with hundreds of individual protections. So the free_heap's last - * GC_TEMPS_SIZE allocated pointers are protected during the mark sweep. - */ - -static s7_pointer g_gc(s7_scheme *sc, s7_pointer args) -{ - #define H_gc "(gc (on #t)) runs the garbage collector. If 'on' is supplied, it turns the GC on or off. \ -Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!" - #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol) - - /* g_gc can't be called in a situation where these lists matter (I think...) */ - set_mlist_1(sc, sc->unused); - set_mlist_2(sc, sc->unused, sc->unused); - set_plist_1(sc, sc->unused); - set_plist_2(sc, sc->unused, sc->unused); - set_plist_3(sc, sc->unused, sc->unused, sc->unused); - set_qlist_2(sc, sc->unused, sc->unused); - set_car(sc->qlist_3, sc->unused); - set_elist_1(sc, sc->unused); - set_elist_2(sc, sc->unused, sc->unused); - set_elist_3(sc, sc->unused, sc->unused, sc->unused); - set_car(sc->elist_4, sc->unused); - set_car(sc->elist_5, sc->unused); - set_car(sc->elist_6, sc->unused); - set_car(sc->elist_7, sc->unused); /* clist and dlist are weak references */ - set_ulist_1(sc, sc->unused, sc->unused); - if (is_not_null(args)) - { - if (!is_boolean(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->gc_symbol, args, sc->type_names[T_BOOLEAN])); - sc->gc_off = (car(args) == sc->F); - if (sc->gc_off) - return(sc->F); - } - call_gc(sc); - return(sc->unspecified); -} - -s7_pointer s7_gc_on(s7_scheme *sc, bool on) -{ - sc->gc_off = !on; - return(s7_make_boolean(sc, on)); -} - -#if S7_DEBUGGING -static void check_free_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int32_t line) -#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__) -#else -static void check_free_heap_size(s7_scheme *sc, s7_int size) -#endif -{ - s7_int free_cells = sc->free_heap_top - sc->free_heap; - if (free_cells < size) - { -#if S7_DEBUGGING - gc(sc, func, line); -#else - gc(sc); -#endif - while ((sc->free_heap_top - sc->free_heap) < (s7_int)(size * 1.5)) - resize_heap(sc); - } -} - -#define ALLOC_POINTER_SIZE 256 -static s7_cell *alloc_pointer(s7_scheme *sc) -{ - if (sc->alloc_pointer_k == ALLOC_POINTER_SIZE) /* if either no current block or the block is used up, make a new block */ - { - sc->semipermanent_cells += ALLOC_POINTER_SIZE; - sc->alloc_pointer_cells = (s7_cell *)Calloc(ALLOC_POINTER_SIZE, sizeof(s7_cell)); /* not Malloc here or below (maybe set full type to 0 if Malloc) */ - add_saved_pointer(sc, sc->alloc_pointer_cells); - sc->alloc_pointer_k = 0; - } - return(&(sc->alloc_pointer_cells[sc->alloc_pointer_k++])); -} - -#define ALLOC_BIG_POINTER_SIZE 256 -static s7_big_cell *alloc_big_pointer(s7_scheme *sc, int64_t loc) -{ - s7_big_pointer p; - if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE) - { - sc->semipermanent_cells += ALLOC_BIG_POINTER_SIZE; - sc->alloc_big_pointer_cells = (s7_big_cell *)Calloc(ALLOC_BIG_POINTER_SIZE, sizeof(s7_big_cell)); - add_saved_pointer(sc, sc->alloc_big_pointer_cells); - sc->alloc_big_pointer_k = 0; - } - p = (&(sc->alloc_big_pointer_cells[sc->alloc_big_pointer_k++])); - p->big_hloc = loc; - /* needed if this new pointer is itself petrified later -- it's not from one of the heap blocks, - * but it's in the heap, and we'll need to know where it is in the heap to replace it - */ - return(p); -} - -static void add_semipermanent_object(s7_scheme *sc, s7_pointer obj) /* called by remove_from_heap */ -{ - gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_objects; - sc->semipermanent_objects = g; -} - -static void add_semipermanent_let_or_slot(s7_scheme *sc, s7_pointer obj) -{ - gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_lets; - sc->semipermanent_lets = g; -} - -#if S7_DEBUGGING -static const char *type_name_from_type(int32_t typ, article_t article); - -#define free_cell(Sc, P) free_cell_1(Sc, P, __LINE__) -static void free_cell_1(s7_scheme *sc, s7_pointer p, int32_t line) -#else -static void free_cell(s7_scheme *sc, s7_pointer p) -#endif -{ -#if S7_DEBUGGING - /* anything that needs gc_list attention should not be freed here */ - uint8_t typ = unchecked_type(p); - gc_list_t *gp = sc->opt1_funcs; - - if ((t_freeze_p[typ]) || ((typ == T_SYMBOL) && (is_gensym(p)))) - fprintf(stderr, "free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); - if ((t_any_closure_p[typ]) && (gp->loc > 0)) - for (s7_int i = 0; i < gp->loc; i++) - if (gp->list[i] == p) - fprintf(stderr, "opt1_funcs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); - gp = sc->weak_refs; - if (gp->loc > 0) - for (s7_int i = 0; i < gp->loc; i++) - if (gp->list[i] == p) - fprintf(stderr, "weak refs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); - - p->debugger_bits = 0; - p->explicit_free_line = line; -#endif - clear_type(p); - (*(sc->free_heap_top++)) = p; -} - -static inline s7_pointer petrify(s7_scheme *sc, s7_pointer x) -{ - int64_t loc = heap_location(sc, x); - s7_pointer p = (s7_pointer)alloc_big_pointer(sc, loc); - sc->heap[loc] = p; - free_cell(sc, p); - unheap(sc, x); /* set_immutable(x); */ /* if there are GC troubles, this might catch them? */ - return(x); -} - -#if S7_DEBUGGING -#define remove_gensym_from_heap(Sc, Gensym) remove_gensym_from_heap_1(Sc, Gensym, __func__, __LINE__) -static void remove_gensym_from_heap_1(s7_scheme *sc, s7_pointer x, const char *func, int line) -#else -static void remove_gensym_from_heap(s7_scheme *sc, s7_pointer x) /* x known to be a symbol and in the heap */ -#endif -{ - int64_t loc = heap_location(sc, x); - sc->heap[loc] = (s7_pointer)alloc_big_pointer(sc, loc); - free_cell(sc, sc->heap[loc]); -#if S7_DEBUGGING - x->gc_func = func; - x->gc_line = line; -#endif - unheap(sc, x); /* set UNHEAP bit in type(x) */ - { - gc_list_t *gp = sc->gensyms; - for (s7_int i = 0; i < gp->loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */ - if (gp->list[i] == x) - { - for (s7_int j = i + 1; i < gp->loc - 1; i++, j++) - gp->list[i] = gp->list[j]; - gp->list[i] = NULL; - gp->loc--; - if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; - break; - }} -} - -static inline void remove_from_heap(s7_scheme *sc, s7_pointer x) -{ - /* global functions are very rarely redefined, so we can remove the function body from the heap when it is defined */ - if (!in_heap(x)) return; - if (is_pair(x)) /* all the compute time is here, might be faster to go down a level explicitly */ - { - s7_pointer p = x; - do { - petrify(sc, p); - remove_from_heap(sc, car(p)); - p = cdr(p); - } while (is_pair(p) && (in_heap(p))); - if (in_heap(p)) petrify(sc, p); - return; - } - switch (type(x)) - { - case T_LET: /* very rare */ - if (is_funclet(x)) set_immutable_let(x); - case T_HASH_TABLE: - case T_VECTOR: - /* not int|float_vector or string because none of their elements are GC-able (so unheap below is ok) - * but hash-table and let seem like they need protection? And let does happen via define-class. - */ - add_semipermanent_object(sc, x); - return; - case T_SYMBOL: - if (is_gensym(x)) - remove_gensym_from_heap(sc, x); - return; - case T_CLOSURE: case T_CLOSURE_STAR: - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - /* these need to be GC-protected! */ - add_semipermanent_object(sc, x); - return; - default: - break; - } - petrify(sc, x); -} - - -/* -------------------------------- stacks -------------------------------- */ -#define OP_STACK_INITIAL_SIZE 64 - -#if S7_DEBUGGING -static void push_op_stack(s7_scheme *sc, s7_pointer op) -{ - (*sc->op_stack_now++) = T_Ext(op); /* not T_App etc -- args can be pushed */ - if (sc->op_stack_now > (sc->op_stack + sc->op_stack_size)) - { - fprintf(stderr, "%sop_stack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer pop_op_stack(s7_scheme *sc) -{ - s7_pointer op = T_Ext(*(--(sc->op_stack_now))); - if (sc->op_stack_now < sc->op_stack) - { - fprintf(stderr, "%sop_stack underflow%s\n", BOLD_TEXT, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(T_Ext(op)); -} -#else -#define push_op_stack(Sc, Op) (*Sc->op_stack_now++) = Op -#define pop_op_stack(Sc) (*(--(Sc->op_stack_now))) -#endif - -static void initialize_op_stack(s7_scheme *sc) -{ - sc->op_stack = (s7_pointer *)Malloc(OP_STACK_INITIAL_SIZE * sizeof(s7_pointer)); - sc->op_stack_size = OP_STACK_INITIAL_SIZE; - sc->op_stack_now = sc->op_stack; - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); - for (int32_t i = 0; i < OP_STACK_INITIAL_SIZE; i++) sc->op_stack[i] = sc->unused; -} - -static void resize_op_stack(s7_scheme *sc) -{ - int32_t new_size = sc->op_stack_size * 2; - int32_t loc = (int32_t)(sc->op_stack_now - sc->op_stack); - sc->op_stack = (s7_pointer *)Realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer)); - for (int32_t i = sc->op_stack_size; i < new_size; i++) sc->op_stack[i] = sc->unused; - sc->op_stack_size = (uint32_t)new_size; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + loc); - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); -} - -#if S7_DEBUGGING -#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__) -static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (sc->stack_end < sc->stack_start) - { - fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - /* here and in push_stack, both code and args might be non-free only because they've been retyped - * inline (as in named let) -- they actually don't make sense in these cases, but are ignored, - * and are carried around as GC protection in other cases. - */ - sc->code = T_Pos(sc->stack_end[0]); - sc->curlet = sc->stack_end[1]; /* not T_Lid|Pos, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */ - sc->args = sc->stack_end[2]; - sc->cur_op = (opcode_t)(sc->stack_end[3]); - if (sc->cur_op >= NUM_OPS) - { - fprintf(stderr, "%s%s[%d]: pop_stack invalid opcode: %" p64 " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if ((sc->cur_op != OP_GC_PROTECT) && - (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1])) && - (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */ - fprintf(stderr, "%s[%d]: curlet not a let: %s\n", func, line, op_names[sc->cur_op]); -} - -#define pop_stack_no_op(Sc) pop_stack_no_op_1(Sc, __func__, __LINE__) -static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (sc->stack_end < sc->stack_start) - { - fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - sc->code = T_Pos(sc->stack_end[0]); - if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1]))) - fprintf(stderr, "%s[%d]: curlet not a let\n", func, line); - sc->curlet = sc->stack_end[1]; /* not T_Lid|Pos: gc_protect can set this directly (not through push_stack) to anything */ - sc->args = sc->stack_end[2]; -} - -#define push_stack(Sc, Op, Args, Code) \ - do {s7_pointer *_end_; _end_ = Sc->stack_end; push_stack_1(Sc, Op, Args, Code, _end_, __func__, __LINE__);} while (0) - -static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code, s7_pointer *end, const char *func, int32_t line) -{ - if ((SHOW_EVAL_OPS) && (op == OP_EVAL_DONE)) fprintf(stderr, "%s[%d]: push eval_done\n", func, line); - if (sc->stack_end >= sc->stack_start + sc->stack_size) - { - fprintf(stderr, "%s%s[%d]: stack overflow, %" ld64 " > %u, trigger: %" ld64 " %s\n", - BOLD_TEXT, func, line, - (s7_int)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, - (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), - UNBOLD_TEXT); - s7_show_stack(sc); - /* make room for debugging */ - - abort(); - if (sc->stop_at_error) abort(); - } - if (sc->stack_end >= sc->stack_resize_trigger) - { - fprintf(stderr, "%s%s[%d]: stack resize skipped%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) - { - /* this is pointless if we can't look around in gdb, so give us some room */ - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); - abort(); - }} - if (sc->stack_end != end) - fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line); - if (op >= NUM_OPS) - { - fprintf(stderr, "%s%s[%d]: push_stack invalid opcode: %" p64 " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if (code) sc->stack_end[0] = T_Pos(code); - sc->stack_end[1] = T_Lid(sc->curlet); - if ((args) && (unchecked_type(args) != T_FREE)) sc->stack_end[2] = T_Pos(args); - sc->stack_end[3] = (s7_pointer)op; - sc->stack_end += 4; -} - -#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) -#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) -#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->unused, Code) -#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) -#define push_stack_op(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) -#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) -#define push_stack_direct(Sc, Op) push_stack(Sc, Op, Sc->args, Sc->code) -#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->code) -/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */ - -#else - -#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0) -#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0) - -#define push_stack(Sc, Op, Args, Code) \ - do { \ - Sc->stack_end[0] = Code; \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_direct(Sc, Op) \ - do { \ - Sc->cur_op = Op; \ - memcpy((void *)(Sc->stack_end), (void *)Sc, 4 * sizeof(s7_pointer)); \ - /* Sc->stack_end[3] = (s7_pointer)(Op); */ \ - Sc->stack_end += 4; \ - } while (0) -/* is this faster with cur_op because of the cast to s7_pointer, or is callgrind messing up memcpy stats? - * time's output is all over the map. I think the cur_op form should be slower, but callgrind disagrees. - */ - -#define push_stack_no_code(Sc, Op, Args) \ - do { \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_let_no_code(Sc, Op, Args) \ - do { \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_args(Sc, Op, Code) \ - do { \ - Sc->stack_end[0] = Code; \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_args_direct(Sc, Op) \ - do { \ - memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_let(Sc, Op, Args, Code) \ - do { \ - Sc->stack_end[0] = Code; \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_op(Sc, Op) \ - do { \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_op_let(Sc, Op) \ - do { \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) -#endif -/* since we don't GC mark the stack past the stack_top, push_stack_no_args and friends can cause pop_stack to set - * sc->code and sc->args to currently free objects. - */ - -#if S7_DEBUGGING -#define unstack(Sc) unstack_1(Sc, __func__, __LINE__) -static void unstack_1(s7_scheme *sc, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (((opcode_t)sc->stack_end[3]) != OP_GC_PROTECT) - { - fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line, op_names[(opcode_t)sc->stack_end[3]], UNBOLD_TEXT); - /* "popped apply" means we called something that went to eval+apply when we thought it was a safe function */ - fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args)); - fprintf(stderr, " cur_code: %s, estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); - if (sc->stop_at_error) abort(); - } -} -#define unstack_with(Sc, Op) unstack_2(Sc, Op, __func__, __LINE__) -static void unstack_2(s7_scheme *sc, opcode_t op, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (((opcode_t)sc->stack_end[3]) != op) - { - fprintf(stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", BOLD_TEXT, func, line, op_names[(opcode_t)sc->stack_end[3]], op_names[op], UNBOLD_TEXT); - fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args)); - fprintf(stderr, " cur_code: %s, estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); - if (sc->stop_at_error) abort(); - } -} -#else -#define unstack(sc) sc->stack_end -= 4 -#define unstack_with(sc, op) sc->stack_end -= 4 -#endif - -#define main_stack_op(Sc) ((opcode_t)(Sc->stack_end[-1])) -/* #define main_stack_args(Sc) (Sc->stack_end[-2]), #define main_stack_let(Sc) (Sc->stack_end[-3]), #define main_stack_code(Sc) (Sc->stack_end[-4]) */ -/* beware of main_stack_code! If a function has a tail-call, the main_stack_code that form sees - * if main_stack_op==op-begin1 can change from call to call -- the begin actually refers - * to the caller, which is dependent on where the current function was called, so we can't hard-wire - * any optimizations based on that sequence. - */ - -static void stack_reset(s7_scheme *sc) -{ - sc->stack_end = sc->stack_start; - push_stack_op(sc, OP_EVAL_DONE); -} - -static uint32_t resize_stack_unchecked(s7_scheme *sc) -{ - uint64_t loc = current_stack_top(sc); - uint32_t new_size = sc->stack_size * 2; - block_t *ob = stack_block(sc->stack); - block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - block_info(nb) = NULL; - stack_block(sc->stack) = nb; - stack_elements(sc->stack) = (s7_pointer *)block_data(nb); - { - s7_pointer *orig = stack_elements(sc->stack); - s7_int i = sc->stack_size; - s7_int left = new_size - i - 8; - while (i <= left) - LOOP_8(orig[i++] = sc->unused); - for (; i < new_size; i++) - orig[i] = sc->unused; - } - vector_length(sc->stack) = new_size; - sc->stack_size = new_size; - sc->stack_start = stack_elements(sc->stack); - sc->stack_end = (s7_pointer *)(sc->stack_start + loc); - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (new_size - STACK_RESIZE_TRIGGER)); - return(new_size); -} - -#if S7_DEBUGGING -#define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__) -static void resize_stack_1(s7_scheme *sc, const char *func, int line) -{ - if ((sc->stack_size * 2) > sc->max_stack_size) - { - fprintf(stderr, "%s%s[%d]: stack too big, %" ld64 " > %u, trigger: %" ld64 " %s\n", - BOLD_TEXT, func, line, - (s7_int)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, - (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), - UNBOLD_TEXT); - /* s7_show_stack(sc); */ /* prints so much the error message is inaccessible */ - fprintf(stderr, "stack:\n"); - for (int64_t i = current_stack_top(sc) - 1; i >= current_stack_top(sc) - 100; i -= 4) - fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]); - resize_stack_unchecked(sc); /* give us some room while debugging! */ - abort(); - if (sc->stop_at_error) abort(); - } - resize_stack_unchecked(sc); -} -#else -static void resize_stack(s7_scheme *sc) -{ - uint32_t new_size = resize_stack_unchecked(sc); - if (show_stack_stats(sc)) - s7_warn(sc, 128, "stack grows to %u\n", new_size); - if (new_size > sc->max_stack_size) - error_nr(sc, make_symbol(sc, "stack-too-big", 13), - set_elist_1(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size)", 43))); - /* error needs to follow realloc, else error -> catchers in error_nr -> let_temp* -> eval_done -> stack_resize -> infinite loop */ -} -#endif - -#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0) - -s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x) -{ - push_stack_no_let_no_code(sc, OP_GC_PROTECT, x); - return(x); -} - -s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x) -{ - unstack(sc); - return(x); -} - -#define stack_protected1(Sc) Sc->stack_end[-2] /* args */ -#define stack_protected2(Sc) Sc->stack_end[-4] /* code */ -#define stack_protected3(Sc) Sc->stack_end[-3] /* curlet */ - -#if S7_DEBUGGING - #define set_stack_protected1(Sc, Val) do {if ((opcode_t)(Sc->stack_end[-1]) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-2] = Val;} while (0) - #define set_stack_protected2(Sc, Val) do {if ((opcode_t)(Sc->stack_end[-1]) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-4] = Val;} while (0) - #define set_stack_protected3(Sc, Val) do {if ((opcode_t)(Sc->stack_end[-1]) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-3] = Val;} while (0) - - #define set_stack_protected1_with(Sc, Val, Op) do {if ((opcode_t)(Sc->stack_end[-1]) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-2] = Val;} while (0) - #define set_stack_protected2_with(Sc, Val, Op) do {if ((opcode_t)(Sc->stack_end[-1]) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-4] = Val;} while (0) - #define set_stack_protected3_with(Sc, Val, Op) do {if ((opcode_t)(Sc->stack_end[-1]) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-3] = Val;} while (0) -#else - #define set_stack_protected1(Sc, Val) Sc->stack_end[-2] = Val - #define set_stack_protected2(Sc, Val) Sc->stack_end[-4] = Val - #define set_stack_protected3(Sc, Val) Sc->stack_end[-3] = Val - - #define set_stack_protected1_with(Sc, Val, Op) Sc->stack_end[-2] = Val - #define set_stack_protected2_with(Sc, Val, Op) Sc->stack_end[-4] = Val - #define set_stack_protected3_with(Sc, Val, Op) Sc->stack_end[-3] = Val -#endif - -#define gc_protect_via_stack(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj) -#define gc_protect_2_via_stack(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y;} while (0) -#define gc_protect_3_via_stack(Sc, X, Y, Z) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y; stack_protected3(sc) = Z;} while (0) -/* often X and Y are fx_calls, so push X, then set Y */ - - -/* -------------------------------- symbols -------------------------------- */ -static inline uint64_t raw_string_hash(const uint8_t *key, s7_int len) -{ - if (len <= 8) - { - uint64_t xs[1] = {0}; - memcpy((void *)xs, (void *)key, len); - return(xs[0]); - } - else - { - uint64_t xs[2] = {0, 0}; - memcpy((void *)xs, (void *)key, (len > 16) ? 16 : len); /* compiler complaint here is bogus */ - return(xs[0] + xs[1]); - } -} - -static uint8_t *alloc_symbol(s7_scheme *sc) -{ - #define SYMBOL_SIZE (3 * sizeof(s7_cell) + sizeof(block_t)) - #define ALLOC_SYMBOL_SIZE (64 * SYMBOL_SIZE) - uint8_t *result; - if (sc->alloc_symbol_k == ALLOC_SYMBOL_SIZE) - { - sc->alloc_symbol_cells = (uint8_t *)Malloc(ALLOC_SYMBOL_SIZE); - add_saved_pointer(sc, sc->alloc_symbol_cells); - sc->alloc_symbol_k = 0; - } - result = &(sc->alloc_symbol_cells[sc->alloc_symbol_k]); - sc->alloc_symbol_k += SYMBOL_SIZE; - return(result); -} - -static s7_pointer make_semipermanent_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot = alloc_pointer(sc); - set_full_type(slot, T_SLOT | T_UNHEAP); - slot_set_symbol_and_value(slot, symbol, value); - return(slot); -} - -static /* inline */ s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len, uint64_t hash, uint32_t location) /* inline useless here 20-Oct-22 */ -{ - /* name might not be null-terminated, these are semipermanent symbols even in s7_gensym; g_gensym handles everything separately */ - uint8_t *base = alloc_symbol(sc); - s7_pointer x = (s7_pointer)base; - s7_pointer str = (s7_pointer)(base + sizeof(s7_cell)); - s7_pointer p = (s7_pointer)(base + 2 * sizeof(s7_cell)); - uint8_t *val = (uint8_t *)permalloc(sc, len + 1); - memcpy((void *)val, (void *)name, len); - val[len] = '\0'; - - full_type(str) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* avoid debugging confusion involving set_type (also below) */ - string_length(str) = len; - string_value(str) = (char *)val; - string_hash(str) = hash; - - full_type(x) = T_SYMBOL | T_UNHEAP; - symbol_set_name_cell(x, str); - set_global_slot(x, sc->undefined); /* was sc->nil */ - symbol_info(x) = (block_t *)(base + 3 * sizeof(s7_cell)); - set_initial_slot(x, sc->undefined); - symbol_set_local_slot_unchecked_and_unincremented(x, 0LL, sc->nil); - symbol_set_tag(x, 0); - symbol_set_tag2(x, 0); - symbol_clear_ctr(x); /* alloc_symbol uses malloc */ - symbol_clear_type(x); - - if ((len > 1) && /* not 0, otherwise : is a keyword */ - ((name[0] == ':') || (name[len - 1] == ':'))) /* see s7test under keyword? for troubles if both colons are present */ - { - s7_pointer slot, ksym; - set_type_bit(x, T_IMMUTABLE | T_KEYWORD | T_GLOBAL); - set_optimize_op(str, OP_CONSTANT); - ksym = make_symbol(sc, (name[0] == ':') ? (char *)(name + 1) : name, len - 1); - keyword_set_symbol(x, ksym); - set_has_keyword(ksym); - /* the keyword symbol needs to be semipermanent (not a gensym) else we have to laboriously gc-protect it */ - if ((is_gensym(ksym)) && - (in_heap(ksym))) - remove_gensym_from_heap(sc, ksym); - slot = make_semipermanent_slot(sc, x, x); - set_global_slot(x, slot); - set_local_slot(x, slot); - } - full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */ - set_car(p, x); - set_cdr(p, vector_element(sc->symbol_table, location)); - vector_element(sc->symbol_table, location) = p; - pair_set_raw_hash(p, hash); - pair_set_raw_len(p, (uint64_t)len); /* symbol name length, so it ought to fit! */ - pair_set_raw_name(p, string_value(str)); - return(x); -} - -static Inline s7_pointer inline_make_symbol(s7_scheme *sc, const char *name, s7_int len) /* inline out: ca 40=2% in tload */ -{ /* name here might not be null-terminated */ - uint64_t hash = raw_string_hash((const uint8_t *)name, len); - uint32_t location = hash % SYMBOL_TABLE_SIZE; - - if (len <= 8) - { - for (s7_pointer x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - ((uint64_t)len == pair_raw_len(x))) - return(car(x)); - } - else /* checking name[len=='\0' and using strcmp if so was not a big win */ - for (s7_pointer x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - ((uint64_t)len == pair_raw_len(x)) && - (strings_are_equal_with_length(name, pair_raw_name(x), len))) /* length here because name might not be null-terminated */ - return(car(x)); - return(new_symbol(sc, name, len, hash, location)); -} - -static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len) {return(inline_make_symbol(sc, name, len));} - -s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) {return(inline_make_symbol(sc, name, safe_strlen(name)));} - -static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, uint64_t hash, uint32_t location, s7_int len) -{ - for (s7_pointer x = vector_element(sc->symbol_table, location); is_not_null(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - (strings_are_equal_with_length(name, pair_raw_name(x), len))) - return(car(x)); - return(sc->nil); -} - -s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name) -{ - s7_int len = safe_strlen(name); - uint64_t hash = raw_string_hash((const uint8_t *)name, len); - s7_pointer result = symbol_table_find_by_name(sc, name, hash, hash % SYMBOL_TABLE_SIZE, len); - return((is_null(result)) ? NULL : result); -} - - -/* -------------------------------- symbol-table -------------------------------- */ -static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len); - -static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_symbol_table "(symbol-table) returns a vector containing the current symbol-table symbols" - #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol) - - s7_pointer *els, *entries = vector_elements(sc->symbol_table); - int32_t syms = 0; - s7_pointer lst; - /* this can't be optimized by returning the actual symbol-table (a vector of lists), because - * gensyms can cause the table's lists and symbols to change at any time. This wreaks havoc - * on traversals like for-each. So, symbol-table returns a snap-shot of the table contents - * at the time it is called. - * (define (for-each-symbol func num) (for-each (lambda (sym) (if (> num 0) (for-each-symbol func (- num 1)) (func sym))) (symbol-table))) - * (for-each-symbol (lambda (sym) (gensym) 1)) - */ - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = entries[i]; is_not_null(x); x = cdr(x)) - syms++; - sc->w = make_simple_vector(sc, syms); - els = vector_elements(sc->w); - for (int32_t i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = entries[i]; is_not_null(x); x = cdr(x)) - els[j++] = car(x); - lst = sc->w; - sc->w = sc->unused; - return(lst); -} - -bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data) -{ - /* this includes the special constants # and so on for simplicity -- are there any others? */ - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) - if (symbol_func(symbol_name(car(x)), data)) - return(true); - return((symbol_func("#t", data)) || (symbol_func("#f", data)) || - (symbol_func("#", data)) || (symbol_func("#", data)) || - (symbol_func("#", data)) || - (symbol_func("#true", data)) || (symbol_func("#false", data))); -} - -bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data) -{ - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) - if (symbol_func(symbol_name(car(x)), data)) - return(true); - return(false); -} - - -/* -------------------------------- gensym -------------------------------- */ -static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym) -{ - /* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */ - s7_pointer name = symbol_name_cell(sym); - uint32_t location = string_hash(name) % SYMBOL_TABLE_SIZE; - s7_pointer x = vector_element(sc->symbol_table, location); - if (car(x) == sym) - vector_element(sc->symbol_table, location) = cdr(x); - else - for (s7_pointer y = x, z = cdr(x); is_pair(z); y = z, z = cdr(z)) - if (car(z) == sym) - { - set_cdr(y, cdr(z)); - return; - } -} - -s7_pointer s7_gensym(s7_scheme *sc, const char *prefix) -{ - s7_int len = safe_strlen(prefix) + 32; - block_t *b = mallocate(sc, len); - char *name = (char *)block_data(b); - /* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */ - name[0] = '\0'; - { - s7_int slen = catstrs(name, len, "{", (prefix) ? prefix : "", "}-", pos_int_to_str_direct(sc, sc->gensym_counter++), (char *)NULL); - uint64_t hash = raw_string_hash((const uint8_t *)name, slen); - int32_t location = hash % SYMBOL_TABLE_SIZE; - s7_pointer x = new_symbol(sc, name, slen, hash, location); /* not T_GENSYM -- might be called from outside */ - liberate(sc, b); - return(x); - } -} - -static bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));} - -static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args) -{ - #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" - #define Q_is_gensym sc->pl_bt - check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args); -} - -static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) -{ - #define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol" - #define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol) - - const char *prefix; - char *name, *p, *base; - s7_int len, plen, nlen; - uint32_t location; - uint64_t hash; - s7_pointer x, str, stc; - block_t *b, *ib; - - /* get symbol name */ - if (is_not_null(args)) - { - s7_pointer gname = car(args); - if (!is_string(gname)) - return(sole_arg_method_or_bust(sc, gname, sc->gensym_symbol, args, sc->type_names[T_STRING])); - prefix = string_value(gname); - plen = string_length(gname); /* was safe_strlen(prefix): were we stopping at #\null deliberately? */ - } - else - { - prefix = "gensym"; - plen = 6; - } - len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19 */ - - b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell)); - base = (char *)block_data(b); - str = (s7_cell *)base; - stc = (s7_cell *)(base + sizeof(s7_cell)); - ib = (block_t *)(base + 2 * sizeof(s7_cell)); - name = (char *)(base + sizeof(block_t) + 2 * sizeof(s7_cell)); - - name[0] = '{'; - memcpy((void *)(name + 1), prefix, plen); /* memcpy is ok with plen==0, I think */ - name[plen + 1] = '}'; - name[plen + 2] = '-'; /* {gensym}-nnn */ - - p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0'); - memcpy((void *)(name + plen + 3), (void *)p, len); - nlen = len + plen + 2; - hash = raw_string_hash((const uint8_t *)name, nlen); - location = hash % SYMBOL_TABLE_SIZE; - - if ((WITH_WARNINGS) && (!is_null(symbol_table_find_by_name(sc, name, hash, location, nlen)))) - s7_warn(sc, nlen + 32, "%s is already in use!", name); - - /* make-string for symbol name */ - if (S7_DEBUGGING) full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */ - set_full_type(str, T_STRING | T_IMMUTABLE | T_UNHEAP); - string_length(str) = nlen; - string_value(str) = name; - string_hash(str) = hash; - - /* allocate the symbol in the heap so GC'd when inaccessible */ - new_cell(sc, x, T_SYMBOL | T_GENSYM); - symbol_set_name_cell(x, str); - symbol_info(x) = ib; - set_global_slot(x, sc->undefined); /* set_initial_slot(x, sc->undefined); */ - symbol_set_local_slot_unchecked(x, 0LL, sc->nil); - symbol_clear_ctr(x); - symbol_set_tag(x, 0); - symbol_set_tag2(x, 0); - symbol_clear_type(x); - gensym_block(x) = b; - - /* place new symbol in symbol-table */ - if (S7_DEBUGGING) full_type(stc) = 0; - set_full_type(stc, T_PAIR | T_IMMUTABLE | T_UNHEAP); - set_car(stc, x); - set_cdr(stc, vector_element(sc->symbol_table, location)); - vector_element(sc->symbol_table, location) = stc; - pair_set_raw_hash(stc, hash); - pair_set_raw_len(stc, (uint64_t)string_length(str)); - pair_set_raw_name(stc, string_value(str)); - - add_gensym(sc, x); - return(x); -} - - -/* -------------------------------- syntax? -------------------------------- */ -bool s7_is_syntax(s7_pointer p) {return(is_syntax(p));} - -static s7_pointer g_is_syntax(s7_scheme *sc, s7_pointer args) -{ - #define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" - #define Q_is_syntax sc->pl_bt - check_boolean_method(sc, is_syntax, sc->is_syntax_symbol, args); -} - - -/* -------------------------------- symbol? -------------------------------- */ -bool s7_is_symbol(s7_pointer p) {return(is_symbol(p));} - -static s7_pointer g_is_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" - #define Q_is_symbol sc->pl_bt - check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args); -} - -const char *s7_symbol_name(s7_pointer p) {return(symbol_name(p));} - -s7_pointer s7_name_to_value(s7_scheme *sc, const char *name) {return(s7_symbol_value(sc, make_symbol_with_strlen(sc, name)));} -/* should this also handle non-symbols such as "+nan.0"? */ - - -/* -------------------------------- symbol->string -------------------------------- */ -static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) -{ - s7_pointer x; - new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE); - string_block(x) = inline_mallocate(sc, len + 1); - string_value(x) = (char *)block_data(string_block(x)); - memcpy((void *)string_value(x), (void *)str, len); - string_value(x)[len] = 0; - string_length(x) = len; - string_hash(x) = 0; - add_string(sc, x); - return(x); -} - -static s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len) -{ - return(inline_make_string_with_length(sc, str, len)); /* packaged to avoid inlining everywhere */ -} - -static s7_pointer g_symbol_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_string "(symbol->string sym) returns the symbol sym converted to a string" - #define Q_symbol_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_symbol_symbol) - - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL])); - /* s7_make_string uses strlen which stops at an embedded null */ - return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */ -} - -static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL])); - if (is_gensym(sym)) - return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy of gensym name (which will be freed) */ - return(symbol_name_cell(sym)); -} - -static s7_pointer symbol_to_string_p_p(s7_scheme *sc, s7_pointer sym) -{ - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL])); - return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); -} - -static s7_pointer symbol_to_string_uncopied_p(s7_scheme *sc, s7_pointer sym) -{ - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL])); - if (is_gensym(sym)) - return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); - return(symbol_name_cell(sym)); -} - - -/* -------------------------------- string->symbol -------------------------------- */ -static inline s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_pointer caller) -{ - if (!is_string(str)) - return(method_or_bust_p(sc, str, caller, sc->type_names[T_STRING])); - if (string_length(str) <= 0) - sole_arg_wrong_type_error_nr(sc, caller, str, wrap_string(sc, "a non-null string", 17)); - return(make_symbol(sc, string_value(str), string_length(str))); -} - -static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol" - #define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol) - return(g_string_to_symbol_1(sc, car(args), sc->string_to_symbol_symbol)); -} - -static s7_pointer string_to_symbol_p_p(s7_scheme *sc, s7_pointer p) {return(g_string_to_symbol_1(sc, p, sc->string_to_symbol_symbol));} - - -/* -------------------------------- symbol -------------------------------- */ -static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller); - -static s7_pointer mark_as_symbol_from_symbol(s7_pointer sym) -{ - set_is_symbol_from_symbol(sym); - return(sym); -} - -static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol "(symbol str ...) returns its string arguments concatenated and converted to a symbol" - #define Q_symbol s7_make_circular_signature(sc, 1, 2, sc->is_symbol_symbol, sc->is_string_symbol) - - /* (let ((x 0)) (set! (symbol "x") 12)) ;symbol (a c-function) does not have a setter: (set! (symbol "x") 12) - * (let (((symbol "x") 3)) x) ; bad variable ((symbol "x") - * (let ((x 2)) (+ (symbol "x") 1)) ;+ first argument, x, is a symbol but should be a number - * maybe document this: (symbol...) just returns the symbol - * (let ((x 3)) (+ (symbol->value (symbol "x")) 1)) -> 4, (let ((x 0)) (apply set! (symbol "x") (list 32)) x) -> 32 - */ - - s7_int len = 0, cur_len; - s7_pointer p, sym; - block_t *b; - char *name; - - for (p = args; is_pair(p); p = cdr(p)) - if (is_string(car(p))) - len += string_length(car(p)); - else break; - if (is_pair(p)) - { - if (is_null(cdr(args))) - return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol))); - return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, g_string_append_1(sc, args, sc->symbol_symbol), sc->symbol_symbol))); - } - if (len == 0) - sole_arg_wrong_type_error_nr(sc, sc->symbol_symbol, car(args), wrap_string(sc, "a non-null string", 17)); - - b = mallocate(sc, len + 1); - name = (char *)block_data(b); - /* can't use catstrs_direct here because it stops at embedded null */ - for (cur_len = 0, p = args; is_pair(p); p = cdr(p)) - { - s7_pointer str = car(p); - if (string_length(str) > 0) - { - memcpy((void *)(name + cur_len), (void *)string_value(str), string_length(str)); - cur_len += string_length(str); - }} - name[len] = '\0'; - sym = mark_as_symbol_from_symbol(inline_make_symbol(sc, name, len)); - liberate(sc, b); - return(sym); -} - -static s7_pointer symbol_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - char buf[256]; - s7_int len; - if ((!is_string(p1)) || (!is_string(p2))) return(g_symbol(sc, set_plist_2(sc, p1, p2))); - len = string_length(p1) + string_length(p2); - if ((len == 0) || (len >= 256)) return(g_symbol(sc, set_plist_2(sc, p1, p2))); - memcpy((void *)buf, (void *)string_value(p1), string_length(p1)); - memcpy((void *)(buf + string_length(p1)), (void *)string_value(p2), string_length(p2)); - return(mark_as_symbol_from_symbol(inline_make_symbol(sc, buf, len))); -} - - -/* -------- symbol sets -------- */ -static inline s7_pointer add_symbol_to_list(s7_scheme *sc, s7_pointer sym) -{ - symbol_set_tag(sym, sc->syms_tag); - symbol_set_tag2(sym, sc->syms_tag2); - return(sym); -} - -static inline void clear_symbol_list(s7_scheme *sc) -{ - sc->syms_tag++; - if (sc->syms_tag == 0) - { - sc->syms_tag = 1; /* we're assuming (in let_equal) that this tag is not 0 */ - sc->syms_tag2++; - } -} - -#define symbol_is_in_list(Sc, Sym) ((symbol_tag(Sym) == Sc->syms_tag) && (symbol_tag2(Sym) == Sc->syms_tag2)) - - -/* -------------------------------- lets/slots -------------------------------- */ -static Inline s7_pointer inline_make_let(s7_scheme *sc, s7_pointer old_let) -{ - s7_pointer x; - new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); - let_set_id(x, ++sc->let_number); - let_set_slots(x, slot_end(sc)); - let_set_outlet(x, old_let); - return(x); -} - -static inline s7_pointer make_let(s7_scheme *sc, s7_pointer old_let) {return(inline_make_let(sc, old_let));} - -static Inline s7_pointer inline_make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer new_let, slot; - sc->value = value; - new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_id(new_let, ++sc->let_number); - let_set_outlet(new_let, old_let); - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - symbol_set_local_slot(symbol, sc->let_number, slot); - slot_set_next(slot, slot_end(sc)); - let_set_slots(new_let, slot); - return(new_let); -} - -static s7_pointer make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) -{ - return(inline_make_let_with_slot(sc, old_let, symbol, value)); -} - -static Inline s7_pointer inline_make_let_with_two_slots(s7_scheme *sc, s7_pointer old_let, - s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2) -{ - /* we leave value1/value2 computation order to the C compiler here -- in the old macro, it was explicitly value1 then value2 - * this means any let in old scheme code that actually depends on the order may break -- it should be let*. - */ - s7_pointer new_let, slot1, slot2; - new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_id(new_let, ++sc->let_number); - let_set_outlet(new_let, old_let); - - new_cell_no_check(sc, slot1, T_SLOT); - slot_set_symbol_and_value(slot1, symbol1, value1); - symbol_set_local_slot(symbol1, sc->let_number, slot1); - let_set_slots(new_let, slot1); - - new_cell_no_check(sc, slot2, T_SLOT); - slot_set_symbol_and_value(slot2, symbol2, value2); - symbol_set_local_slot(symbol2, sc->let_number, slot2); - slot_set_next(slot2, slot_end(sc)); - slot_set_next(slot1, slot2); - return(new_let); -} - -static s7_pointer make_let_with_two_slots(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2) -{ - return(inline_make_let_with_two_slots(sc, old_let, symbol1, value1, symbol2, value2)); -} - -/* in all these functions, symbol_set_local_slot should follow slot_set_value so that we can evaluate the slot's value in its old state */ -static inline void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value, uint64_t id) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - set_local(symbol); - symbol_set_local_slot(symbol, id, slot); -} - -static void add_slot_unchecked_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - set_local(symbol); -} - -#define add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let)) - -static inline s7_pointer add_slot_checked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - symbol_set_local_slot(symbol, let_id(let), slot); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - return(slot); -} - -static inline s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - set_local(symbol); - if (let_id(let) >= symbol_id(symbol)) - symbol_set_local_slot(symbol, let_id(let), slot); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - return(slot); -} - -static s7_pointer add_slot_unchecked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - set_local(symbol); - if (let_id(let) >= symbol_id(symbol)) - symbol_set_local_slot(symbol, let_id(let), slot); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - return(slot); -} - -static Inline s7_pointer inline_add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, slot_end(sc)); - symbol_set_local_slot(symbol, id, slot); - slot_set_next(last_slot, slot); - return(slot); -} - -static s7_pointer add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) -{ - return(inline_add_slot_at_end(sc, id, last_slot, symbol, value)); -} - -static s7_pointer add_slot_at_end_no_local(s7_scheme *sc, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, slot_end(sc)); - slot_set_next(last_slot, slot); - return(slot); -} - -static inline void make_let_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3) -{ - s7_pointer last_slot, cargs = closure_args(func); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2); - last_slot = next_slot(let_slots(sc->curlet)); - inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3); -} - -static inline void make_let_with_four_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) -{ - s7_pointer last_slot, cargs = closure_args(func); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2); - cargs = cddr(cargs); - last_slot = next_slot(let_slots(sc->curlet)); - last_slot = inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs), val3); - inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val4); -} - -static s7_pointer reuse_as_let(s7_scheme *sc, s7_pointer let, s7_pointer next_let) -{ - /* we're reusing let here as a let -- it was probably a pair */ -#if S7_DEBUGGING - let->debugger_bits = 0; - if (!in_heap(let)) {fprintf(stderr, "reusing an unheaped %s as a let?\n", s7_type_names[type(let)]); abort();} -#endif - set_full_type(T_Pair(let), T_LET | T_SAFE_PROCEDURE); - let_set_slots(let, slot_end(sc)); - let_set_outlet(let, next_let); - let_set_id(let, ++sc->let_number); - return(let); -} - -static s7_pointer reuse_as_slot(s7_scheme *sc, s7_pointer slot, s7_pointer symbol, s7_pointer value) -{ - set_full_type(T_Pair(slot), T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - return(slot); -} - -#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0) - -static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val, id); - return(let); -} - -static s7_pointer update_let_with_two_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val1, id); slot = next_slot(slot); - update_slot(slot, val2, id); - return(let); -} - -static s7_pointer update_let_with_three_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val1, id); slot = next_slot(slot); - update_slot(slot, val2, id); slot = next_slot(slot); - update_slot(slot, val3, id); - return(let); -} - -static s7_pointer update_let_with_four_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val1, id); slot = next_slot(slot); - update_slot(slot, val2, id); slot = next_slot(slot); - update_slot(slot, val3, id); slot = next_slot(slot); - update_slot(slot, val4, id); - return(let); -} - -static s7_pointer make_semipermanent_let(s7_scheme *sc, s7_pointer vars) -{ - s7_pointer slot, let = alloc_pointer(sc); - set_full_type(let, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); - let_set_id(let, ++sc->let_number); - let_set_outlet(let, sc->curlet); - slot = make_semipermanent_slot(sc, caar(vars), sc->F); - add_semipermanent_let_or_slot(sc, slot); - symbol_set_local_slot(caar(vars), sc->let_number, slot); - let_set_slots(let, slot); - for (s7_pointer var = cdr(vars); is_pair(var); var = cdr(var)) - { - s7_pointer last_slot = slot; - slot = make_semipermanent_slot(sc, caar(var), sc->F); - add_semipermanent_let_or_slot(sc, slot); - symbol_set_local_slot(caar(var), sc->let_number, slot); - slot_set_next(last_slot, slot); - } - slot_set_next(slot, slot_end(sc)); - add_semipermanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */ - return(let); -} - -static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value); - -static inline s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer y, s7_pointer value) -{ - if (slot_has_setter(y)) - slot_set_value(y, call_setter(sc, y, value)); - else - { - if (is_immutable_slot(y)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_set_symbol, slot_symbol(y))); - slot_set_value(y, value); - } - return(slot_value(y)); -} - -static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) -{ - s7_pointer e = car(args), val; - if (e == sc->rootlet) - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! rootlet", 19)); - if (e == sc->s7_starlet) - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! *s7*", 16)); - if (e == sc->owlet) /* (owlet) copies sc->owlet, so this probably can't happen */ - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! owlet", 17)); - if (is_funclet(e)) - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! a funclet", 21)); - val = cadr(args); - for (s7_pointer p = let_slots(e); tis_slot(p); p = next_slot(p)) - checked_slot_set_value(sc, p, val); - return(val); -} - -static s7_int s7_starlet_length(void); - -static s7_int let_length(s7_scheme *sc, s7_pointer e) -{ - /* used by length, applicable_length, copy, and some length optimizations */ - s7_int i; - s7_pointer p; - - if (e == sc->rootlet) - return(sc->rootlet_entries); - if (e == sc->s7_starlet) - return(s7_starlet_length()); - if (has_active_methods(sc, e)) - { - s7_pointer length_func = find_method(sc, e, sc->length_symbol); - if (length_func != sc->undefined) - { - p = s7_apply_function(sc, length_func, set_plist_1(sc, e)); - return((s7_is_integer(p)) ? s7_integer(p) : -1); /* ?? */ - }} - for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p)); - return(i); -} - - -static void slot_set_setter(s7_pointer p, s7_pointer val) -{ - if ((type(val) == T_C_FUNCTION) && - (c_function_has_bool_setter(val))) - slot_set_setter_1(p, c_function_bool_setter(val)); - else slot_set_setter_1(p, val); -} - -static void slot_set_value_with_hook_1(s7_scheme *sc, s7_pointer slot, s7_pointer value) -{ - /* (set! (hook-functions *rootlet-redefinition-hook*) (list (lambda (hook) (format *stderr* "~A ~A~%" (hook 'name) (hook 'value))))) */ - s7_pointer symbol = slot_symbol(slot); - if ((global_slot(symbol) == slot) && - (value != slot_value(slot))) - s7_call(sc, sc->rootlet_redefinition_hook, set_plist_2(sc, symbol, value)); - slot_set_value(slot, value); -} - -static void remove_function_from_heap(s7_scheme *sc, s7_pointer value); /* calls remove_let_from_heap */ - -static void remove_let_from_heap(s7_scheme *sc, s7_pointer lt) -{ - for (s7_pointer p = let_slots(lt); tis_slot(p); p = next_slot(p)) - { - s7_pointer val = slot_value(p); - if ((has_closure_let(val)) && - (in_heap(closure_args(val)))) - remove_function_from_heap(sc, val); - } - let_set_removed(lt); -} - -static void add_slot_to_rootlet(s7_scheme *sc, s7_pointer slot) -{ - s7_pointer ge = sc->rootlet; - rootlet_element(ge, sc->rootlet_entries++) = slot; - set_in_rootlet(slot); - if (sc->rootlet_entries >= vector_length(ge)) - { - s7_int len; - block_t *ob, *nb; - vector_length(ge) *= 2; - len = vector_length(ge); - ob = rootlet_block(ge); - nb = reallocate(sc, ob, len * sizeof(s7_pointer)); - block_info(nb) = NULL; - rootlet_block(ge) = nb; - rootlet_elements(ge) = (s7_pointer *)block_data(nb); - for (s7_int i = sc->rootlet_entries; i < len; i++) rootlet_element(ge, i) = sc->nil; - } -} - -static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) -{ - s7_pointer lt; - remove_from_heap(sc, closure_args(value)); - remove_from_heap(sc, closure_body(value)); - /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */ - lt = closure_let(value); /* closure_let and all its outlets can't be rootlet */ - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - { - lt = let_outlet(lt); - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - { - remove_let_from_heap(sc, lt); - lt = let_outlet(lt); - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - remove_let_from_heap(sc, lt); - }} -} - -s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if ((!is_let(let)) || - (let == sc->rootlet)) - { - s7_pointer slot; - if (is_immutable(sc->rootlet)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't define '~S; rootlet is immutable", 38), symbol)); - if ((sc->safety <= NO_SAFETY) && - (has_closure_let(value))) - remove_function_from_heap(sc, value); - - /* first look for existing slot -- this is not always checked before calling s7_make_slot */ - if (is_slot(global_slot(symbol))) - { - slot = global_slot(symbol); - symbol_increment_ctr(symbol); - slot_set_value_with_hook(slot, value); - return(slot); - } - - slot = make_semipermanent_slot(sc, symbol, value); - add_slot_to_rootlet(sc, slot); - set_global_slot(symbol, slot); - if (symbol_id(symbol) == 0) /* never defined locally? */ - { - if ((!is_gensym(symbol)) && - (initial_slot(symbol) == sc->undefined) && - (!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */ - ((!sc->unlet) || /* init_unlet creates sc->unlet (includes syntax), after that initial_slot is for c_functions?? */ - (is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */ - set_initial_slot(symbol, make_semipermanent_slot(sc, symbol, value)); - set_local_slot(symbol, slot); - set_global(symbol); - } - symbol_increment_ctr(symbol); - if (is_gensym(symbol)) - remove_gensym_from_heap(sc, symbol); - return(slot); - } - return(add_slot_checked_with_id(sc, let, symbol, value)); - /* there are about as many lets as local variables -- this strikes me as surprising, but it holds up across a lot of code */ -} - -static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value) -{ - s7_pointer y; - new_cell(sc, y, T_SLOT); - slot_set_symbol_and_value(y, variable, value); - return(y); -} - - -/* -------------------------------- let? -------------------------------- */ -bool s7_is_let(s7_pointer e) {return(is_let(e));} - -static s7_pointer g_is_let(s7_scheme *sc, s7_pointer args) -{ - #define H_is_let "(let? obj) returns #t if obj is a let." - #define Q_is_let sc->pl_bt - check_boolean_method(sc, is_let, sc->is_let_symbol, args); -} - - -/* -------------------------------- funclet? -------------------------------- */ -static s7_pointer g_is_funclet(s7_scheme *sc, s7_pointer args) -{ - #define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)." - #define Q_is_funclet sc->pl_bt - - s7_pointer lt = car(args); - if ((is_let(lt)) && ((is_funclet(lt)) || (is_maclet(lt)))) - return(sc->T); - if (!has_active_methods(sc, lt)) - return(sc->F); - return(apply_boolean_method(sc, lt, sc->is_funclet_symbol)); -} - - -/* -------------------------------- unlet -------------------------------- */ -static s7_pointer normal_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); -static s7_pointer normal_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc); - -#define UNLET_ENTRIES 512 /* 397 if not --disable-deprecated etc */ - -static void init_unlet(s7_scheme *sc) -{ - int32_t k = 0; - s7_pointer *inits; - s7_pointer *els = vector_elements(sc->symbol_table); - block_t *block = mallocate(sc, UNLET_ENTRIES * sizeof(s7_pointer)); - sc->unlet = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* freed explicitly in s7_free */ - set_full_type(sc->unlet, T_VECTOR | T_UNHEAP); - vector_length(sc->unlet) = UNLET_ENTRIES; - vector_block(sc->unlet) = block; - vector_elements(sc->unlet) = (s7_pointer *)block_data(block); - vector_set_dimension_info(sc->unlet, NULL); - vector_getter(sc->unlet) = normal_vector_getter; - vector_setter(sc->unlet) = normal_vector_setter; - inits = vector_elements(sc->unlet); - s7_vector_fill(sc, sc->unlet, sc->nil); - - inits[k++] = initial_slot(sc->else_symbol); - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = els[i]; is_pair(x); x = cdr(x)) - { - s7_pointer sym = car(x); - if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - { - s7_pointer val = initial_value(sym); - if ((is_c_function(val)) || (is_syntax(val))) /* we assume the initial_slot value needs no GC protection */ - inits[k++] = initial_slot(sym); - /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: make-hook hook-functions - * if these initial_slot values are added to unlet, they need explicit GC protection. - */ - if ((S7_DEBUGGING) && (k >= UNLET_ENTRIES)) fprintf(stderr, "unlet overflow\n"); - }} -} - -static s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args) -{ - /* add sc->unlet bindings to the current environment */ - #define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions" - #define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol) - - s7_pointer *inits = vector_elements(sc->unlet); - s7_pointer res; - - sc->w = make_let(sc, sc->curlet); - for (int32_t i = 0; (i < UNLET_ENTRIES) && (is_slot(inits[i])); i++) - { - s7_pointer sym = slot_symbol(inits[i]); - s7_pointer x = slot_value(inits[i]); - if ((x != global_value(sym)) || /* it has been changed globally */ - ((!is_global(sym)) && /* it might be shadowed locally */ - (s7_symbol_local_value(sc, sym, sc->curlet) != global_value(sym)))) - add_slot_checked_with_id(sc, sc->w, sym, x); - } - /* if (set! + -) then + needs to be overridden, but the local bit isn't set, so we have to check the actual values in the non-local case. - * (define (f x) (with-let (unlet) (+ x 1))) - */ - res = sc->w; - sc->w = sc->unused; - return(res); -} - - -/* -------------------------------- openlet? -------------------------------- */ -bool s7_is_openlet(s7_pointer e) {return(has_methods(e));} - -static s7_pointer g_is_openlet(s7_scheme *sc, s7_pointer args) -{ - #define H_is_openlet "(openlet? obj) returns #t is 'obj' has methods." - #define Q_is_openlet sc->pl_bt - - s7_pointer e = car(args); /* if e is not a let, should this raise an error? -- no, easier to use this way in cond */ - check_method(sc, e, sc->is_openlet_symbol, args); - return(make_boolean(sc, has_methods(e))); -} - - -/* -------------------------------- openlet -------------------------------- */ -s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e) -{ - set_has_methods(e); - return(e); -} - -static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args) -{ - #define H_openlet "(openlet e) tells the built-in generic functions that the let 'e might have an over-riding method." - #define Q_openlet sc->pcl_e - - s7_pointer e = car(args), elet, func; - if ((e == sc->rootlet) || (e == sc->nil)) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet rootlet", 21))); - elet = find_let(sc, e); /* returns nil if no let found, so has to follow error check above */ - if (!is_let(elet)) - sole_arg_wrong_type_error_nr(sc, sc->openlet_symbol, e, a_let_string); - if ((has_active_methods(sc, e)) && - ((func = find_method(sc, elet, sc->openlet_symbol)) != sc->undefined)) - return(s7_apply_function(sc, func, args)); - set_has_methods(e); - return(e); -} - -/* -------------------------------- coverlet -------------------------------- */ -static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) -{ - #define H_coverlet "(coverlet e) undoes an earlier openlet." - #define Q_coverlet sc->pcl_e - - s7_pointer e = car(args); - check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e)); - if ((e == sc->rootlet) || (e == sc->s7_starlet)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e)); - - if ((is_let(e)) || (has_closure_let(e)) || - ((is_c_object(e)) && (c_object_let(e) != sc->nil)) || - ((is_c_pointer(e)) && (is_let(c_pointer_info(e))))) - { - clear_has_methods(e); - return(e); - } - sole_arg_wrong_type_error_nr(sc, sc->coverlet_symbol, e, a_let_string); - return(NULL); -} - - -/* -------------------------------- varlet -------------------------------- */ -static void check_let_fallback(s7_scheme *sc, s7_pointer symbol, s7_pointer let) -{ - if (symbol == sc->let_ref_fallback_symbol) - set_has_let_ref_fallback(let); - else - if (symbol == sc->let_set_fallback_symbol) - set_has_let_set_fallback(let); -} - -static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) -{ - if ((old_e == sc->rootlet) || (new_e == sc->s7_starlet)) - return; - if (new_e == sc->rootlet) - for (s7_pointer x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - { - s7_pointer sym = slot_symbol(x), val = slot_value(x); - if (is_slot(global_slot(sym))) - slot_set_value(global_slot(sym), val); - else s7_make_slot(sc, new_e, sym, val); - } - else - if (old_e == sc->s7_starlet) - { - s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); - s7_int gc_loc = s7_gc_protect(sc, iter); - iterator_current(iter) = cons_unchecked(sc, sc->F, sc->F); - set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */ - while (true) - { - s7_pointer y = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - add_slot_checked_with_id(sc, new_e, car(y), cdr(y)); - } - s7_gc_unprotect_at(sc, gc_loc); - } - else - for (s7_pointer x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - add_slot_checked_with_id(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ -} - -static s7_pointer check_c_object_let(s7_scheme *sc, s7_pointer old_e, s7_pointer caller) -{ - if (is_c_object(old_e)) - old_e = c_object_let(old_e); - if (!is_let(old_e)) - sole_arg_wrong_type_error_nr(sc, caller, old_e, a_let_string); - return(old_e); -} - -s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if (!is_let(let)) - wrong_type_error_nr(sc, sc->varlet_symbol, 1, let, a_let_string); - if (!is_symbol(symbol)) - wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, a_symbol_string); - - if ((is_slot(global_slot(symbol))) && - (is_syntax(global_value(symbol)))) - wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); - - if (let == sc->rootlet) - { - if (is_slot(global_slot(symbol))) - slot_set_value(global_slot(symbol), value); - else s7_make_slot(sc, let, symbol, value); - } - else - { - add_slot_checked_with_id(sc, let, symbol, value); - check_let_fallback(sc, symbol, let); - } - return(value); -} - -static int32_t position_of(s7_pointer p, s7_pointer args) -{ - int32_t i; - for (i = 1; p != args; i++, args = cdr(args)); - return(i); -} - -static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args) /* varlet = with-let + define */ -{ - #define H_varlet "(varlet let ...) adds its arguments (a let, a cons: symbol . value, or two arguments, the symbol and its value) \ -to the let let, and returns let. (varlet (curlet) 'a 1) adds 'a to the current environment with the value 1." - #define Q_varlet s7_make_circular_signature(sc, 2, 4, sc->is_let_symbol, \ - s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ - s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), \ - sc->T) - - s7_pointer e = car(args); - if (is_null(e)) - e = sc->rootlet; - else - { - check_method(sc, e, sc->varlet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->varlet_symbol, 1, e, a_let_string); - if ((is_immutable(e)) || (e == sc->s7_starlet)) - error_nr(sc, sc->immutable_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, e)); - } - for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) - { - s7_pointer sym, val, p = car(x); - switch (type(p)) - { - case T_SYMBOL: - sym = (is_keyword(p)) ? keyword_symbol(p) : p; - if (!is_pair(cdr(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), p, args)); - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); - x = cdr(x); - val = car(x); - break; - - case T_PAIR: - sym = car(p); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); - val = cdr(p); - break; - - case T_LET: - append_let(sc, e, check_c_object_let(sc, p, sc->varlet_symbol)); - if (has_let_set_fallback(p)) set_has_let_set_fallback(e); - if (has_let_ref_fallback(p)) set_has_let_ref_fallback(e); - continue; - - default: - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); - } - if (e == sc->rootlet) - { - if (is_slot(global_slot(sym))) - { - if (is_syntax(global_value(sym))) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, wrap_string(sc, "a non-syntactic symbol", 22)); - /* without this check we can end up turning our code into gibberish: - * (set! quote 1) -> ;can't set! quote - * (varlet (rootlet) '(quote . 1)), :quote -> 1 - * or worse set quote to a function of one arg that tries to quote something -- infinite loop - */ - slot_set_value_with_hook(global_slot(sym), val); - } - else s7_make_slot(sc, e, sym, val); - } - else - { - check_let_fallback(sc, sym, e); - add_slot_checked_with_id(sc, e, sym, val); - }} - /* this used to check for sym already defined, and set its value, but that greatly slows down - * the most common use (adding a slot), and makes it hard to shadow explicitly. Don't use - * varlet as a substitute for set!/let-set!. - */ - return(e); -} - - -/* -------------------------------- cutlet -------------------------------- */ -static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) -{ - #define H_cutlet "(cutlet e symbol ...) removes symbols from the let e." - #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->is_symbol_symbol) - - s7_pointer e = car(args); - s7_int the_un_id; - if (is_null(e)) - e = sc->rootlet; - else - { - check_method(sc, e, sc->cutlet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->cutlet_symbol, 1, e, a_let_string); - if ((is_immutable(e)) || (e == sc->s7_starlet)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, e)); - } - /* besides removing the slot we have to make sure the symbol_id does not match else - * let-ref and others will use the old slot! What's the un-id? Perhaps the next one? - * (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b) - */ - the_un_id = ++sc->let_number; - - for (s7_pointer syms = cdr(args); is_pair(syms); syms = cdr(syms)) - { - s7_pointer sym = car(syms); - - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - - if (e == sc->rootlet) - { - if (!is_slot(global_slot(sym))) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); - if (is_immutable(global_slot(sym))) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - symbol_set_id(sym, the_un_id); - slot_set_value(global_slot(sym), sc->undefined); - /* here we need to at least clear bits: syntactic binder clean-symbol(?) etc, maybe also locally */ - } - else - { - s7_pointer slot; - if ((has_let_fallback(e)) && - ((sym == sc->let_ref_fallback_symbol) || (sym == sc->let_set_fallback_symbol))) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); - - slot = let_slots(e); - if (tis_slot(slot)) - { - if (slot_symbol(slot) == sym) - { - if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - let_set_slots(e, next_slot(let_slots(e))); - symbol_set_id(sym, the_un_id); - } - else - { - s7_pointer last_slot = slot; - for (slot = next_slot(let_slots(e)); tis_slot(slot); last_slot = slot, slot = next_slot(slot)) - if (slot_symbol(slot) == sym) - { - if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - symbol_set_id(sym, the_un_id); - slot_set_next(last_slot, next_slot(slot)); - break; - }}}}} - return(e); -} - - -/* -------------------------------- sublet -------------------------------- */ -static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_pointer caller) -{ - s7_pointer new_e = make_let(sc, (e == sc->rootlet) ? sc->nil : e); - set_all_methods(new_e, e); - - if (!is_null(bindings)) - { - s7_pointer sp = NULL; - sc->temp3 = new_e; - for (s7_pointer x = bindings; is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x), sym, val; - - switch (type(p)) - { - case T_SYMBOL: - sym = (is_keyword(p)) ? keyword_symbol(p) : p; - if (!is_pair(cdr(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, p, bindings)); - x = cdr(x); - val = car(x); - break; - - case T_PAIR: - sym = car(p); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - val = cdr(p); - break; - - case T_LET: - append_let(sc, new_e, check_c_object_let(sc, p, caller)); - if (tis_slot(let_slots(new_e))) /* make sure the end slot (sp) is correct */ - for (sp = let_slots(new_e); tis_slot(next_slot(sp)); sp = next_slot(sp)); - continue; - - default: - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); - } - - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), sym, a_non_constant_symbol_string); - if ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) - wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); - - /* here we know new_e is a let and is not rootlet */ - if (!sp) - sp = add_slot_checked_with_id(sc, new_e, sym, val); - else - { - if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc); /* or maybe add add_slot_at_end_checked? */ - sp = inline_add_slot_at_end(sc, let_id(new_e), sp, sym, val); - set_local(sym); /* ? */ - } - check_let_fallback(sc, sym, new_e); - } - sc->temp3 = sc->unused; - } - return(new_e); -} - -s7_pointer s7_sublet(s7_scheme *sc, s7_pointer e, s7_pointer bindings) {return(sublet_1(sc, e, bindings, sc->sublet_symbol));} - -static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args) -{ - #define H_sublet "(sublet let ...) makes a new let within the environment 'let', initializing it with the bindings" - #define Q_sublet Q_varlet - - s7_pointer e = car(args); - if (is_null(e)) - e = sc->rootlet; - else - { - check_method(sc, e, sc->sublet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->sublet_symbol, 1, e, a_let_string); - } - return(sublet_1(sc, e, cdr(args), sc->sublet_symbol)); -} - -static s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = cadr(args), new_e; - check_method(sc, sc->curlet, sc->sublet_symbol, args); - new_e = inline_make_let_with_slot(sc, sc->curlet, sym, caddr(args)); - set_all_methods(new_e, sc->curlet); - check_let_fallback(sc, sym, new_e); - return(new_e); -} - -static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer f, int32_t num_args, s7_pointer expr, bool ops) -{ - if (num_args == 3) - { - s7_pointer args = cdr(expr); - if ((is_pair(car(args))) && (caar(args) == sc->curlet_symbol) && (is_null(cdar(args))) && - (is_pair(cadr(args))) && (caadr(args) == sc->quote_symbol) && (is_symbol(cadadr(args)))) - return(sc->sublet_curlet); - } - return(f); -} - - -/* -------------------------------- inlet -------------------------------- */ -s7_pointer s7_inlet(s7_scheme *sc, s7_pointer args) -{ - #define H_inlet "(inlet ...) adds its arguments, each a let, a cons: '(symbol . value), or a keyword/value pair, \ -to a new let, and returns the new let. (inlet :a 1 :b 2) or (inlet '(a . 1) '(b . 2))" - #define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T) - return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol)); -} - -#define g_inlet s7_inlet - -static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args) -{ - /* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols, no syntax, etc */ - s7_pointer new_e = make_let(sc, sc->nil); - int64_t id = let_id(new_e); - s7_pointer sp = NULL; - - sc->temp3 = new_e; - for (s7_pointer x = args; is_pair(x); x = cddr(x)) - { - s7_pointer symbol = car(x); - if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */ - symbol = keyword_symbol(symbol); - if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - if (!sp) - { - add_slot_unchecked(sc, new_e, symbol, cadr(x), id); - sp = let_slots(new_e); - } - else sp = inline_add_slot_at_end(sc, id, sp, symbol, cadr(x)); - } - sc->temp3 = sc->unused; - return(new_e); -} - -static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) -{ - s7_pointer x; - - if (!is_symbol(symbol)) - return(sublet_1(sc, sc->nil, set_plist_2(sc, symbol, value), sc->inlet_symbol)); - if (is_keyword(symbol)) - symbol = keyword_symbol(symbol); - if (is_constant_symbol(sc, symbol)) - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - if ((is_global(symbol)) && - (is_syntax_or_qq(global_value(symbol)))) - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); - - new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); - sc->temp3 = x; - let_set_id(x, ++sc->let_number); - let_set_outlet(x, sc->nil); - let_set_slots(x, slot_end(sc)); - add_slot_unchecked(sc, x, symbol, value, let_id(x)); - sc->temp3 = sc->unused; - return(x); -} - -static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) -{ - va_list ap; - s7_pointer new_e = make_let(sc, sc->nil); - int64_t id = let_id(new_e); - s7_pointer sp = NULL; - - sc->temp3 = new_e; - va_start(ap, num_args); - for (s7_int i = 0; i < num_args; i += 2) - { - s7_pointer symbol = va_arg(ap, s7_pointer); - s7_pointer value = va_arg(ap, s7_pointer); - if ((S7_DEBUGGING) && (is_keyword(symbol))) fprintf(stderr, "internal_inlet key: %s??\n", display(symbol)); - if (!sp) - { - add_slot_unchecked(sc, new_e, symbol, value, id); - sp = let_slots(new_e); - } - else sp = inline_add_slot_at_end(sc, id, sp, symbol, value); - } - va_end(ap); - sc->temp3 = sc->unused; - return(new_e); -} - -static bool is_proper_quote(s7_scheme *sc, s7_pointer p) -{ - return((is_quoted_pair(p)) && - (is_pair(cdr(p))) && - (is_null(cddr(p))) && - (is_global(sc->quote_symbol))); -} - -static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args > 0) && - ((args % 2) == 0)) - { - for (s7_pointer p = cdr(expr); is_pair(p); p = cddr(p)) - if (!is_symbol_and_keyword(car(p))) - { - s7_pointer sym; - if (!is_proper_quote(sc, car(p))) /* 'abs etc, but tricky: ':abs */ - return(f); - sym = cadar(p); - if ((!is_symbol(sym)) || - (is_possibly_constant(sym)) || /* define-constant etc */ - (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ - ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ - (sym == sc->let_ref_fallback_symbol) || - (sym == sc->let_set_fallback_symbol)) - return(f); - } - return(sc->simple_inlet); - } - return(f); -} - - -/* -------------------------------- let->list -------------------------------- */ -static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list); - -s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) -{ - s7_pointer x; - sc->temp3 = sc->w; - sc->w = sc->nil; - if (let == sc->rootlet) - { - s7_int i, lim2 = sc->rootlet_entries; - s7_pointer *entries = rootlet_elements(let); - - if (lim2 & 1) lim2--; - for (i = 0; i < lim2; ) - { - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++; - sc->w = cons_unchecked(sc, cons_unchecked(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++; - } - if (lim2 < sc->rootlet_entries) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); - } - else - { - s7_pointer iter, func; - s7_int gc_loc = -1; - /* need to check make-iterator method before dropping into let->list */ - - if ((has_active_methods(sc, let)) && - ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined)) - iter = s7_apply_function(sc, func, set_plist_1(sc, let)); - else - if (let == sc->s7_starlet) /* (let->list *s7*) via s7_starlet_make_iterator */ - { - iter = s7_make_iterator(sc, let); - gc_loc = s7_gc_protect(sc, iter); - } - else iter = sc->nil; - - if (is_null(iter)) - for (x = let_slots(let); tis_slot(x); x = next_slot(x)) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w); - else - /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ - while (true) - { - x = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - sc->w = cons(sc, x, sc->w); - } - sc->w = proper_list_reverse_in_place(sc, sc->w); - if (gc_loc != -1) - s7_gc_unprotect_at(sc, gc_loc); - } - x = sc->w; - sc->w = sc->temp3; - sc->temp3 = sc->unused; - return(x); -} - -#if (!WITH_PURE_S7) -static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_let_to_list "(let->list let) returns let's bindings as a list of cons's: '(symbol . value)." - #define Q_let_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_let_symbol) - - s7_pointer let = car(args); - check_method(sc, let, sc->let_to_list_symbol, args); - if (!is_let(let)) - { - if (is_c_object(let)) - let = c_object_let(let); - else - if (is_c_pointer(let)) - let = c_pointer_info(let); - if (!is_let(let)) - sole_arg_wrong_type_error_nr(sc, sc->let_to_list_symbol, let, a_let_string); - } - return(s7_let_to_list(sc, let)); -} -#endif - - -/* -------------------------------- let-ref -------------------------------- */ -static s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - s7_pointer p; - push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); - p = s7_apply_function(sc, find_method(sc, let, sc->let_ref_fallback_symbol), set_qlist_2(sc, let, symbol)); - unstack(sc); - sc->code = T_Pos(sc->stack_end[0]); /* can be # */ - sc->value = T_Ext(sc->stack_end[2]); - return(p); -} - -static s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer p; - push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); - p = s7_apply_function(sc, find_method(sc, let, sc->let_set_fallback_symbol), set_qlist_3(sc, let, symbol, value)); - unstack(sc); - sc->code = T_Pos(sc->stack_end[0]); - sc->value = T_Ext(sc->stack_end[2]); - return(p); -} - -static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */ - if (!is_let(let)) - { - let = find_let(sc, let); - if (!is_let(let)) - wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, a_let_string); - } - if (!is_symbol(symbol)) - { - if (has_let_ref_fallback(let)) /* let-ref|set-fallback refer to (explicit) let-ref in various forms, not the method lookup process */ - return(call_let_ref_fallback(sc, let, symbol)); - wrong_type_error_nr(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string); - } -#if 0 - /* let-ref is currently immutable */ - if (!is_global(sc->let_ref_symbol)) - check_method(sc, let, sc->let_ref_symbol, set_plist_2(sc, let, symbol)); - /* a let-ref method is almost impossible to write without creating an infinite loop: - * any reference to the let will probably call let-ref somewhere, calling us again, and looping. - * This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist. - * After much wasted debugging, I decided to make let-ref and let-set! immutable. - */ -#endif - if (is_keyword(symbol)) - symbol = keyword_symbol(symbol); - - if (let == sc->rootlet) - return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); - - if (let_id(let) == symbol_id(symbol)) - return(local_value(symbol)); /* this has to follow the rootlet check(?) */ - - for (s7_pointer x = let; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(slot_value(y)); - - if (is_openlet(let)) - { - /* If a let is a mock-hash-table (for example), implicit indexing of the hash-table collides with the same thing for the let (field names - * versus keys), and we can't just try again here because that makes it too easy to get into infinite recursion. So, 'let-ref-fallback... - */ - if (has_let_ref_fallback(let)) - return(call_let_ref_fallback(sc, let, symbol)); - } - return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); /* (let () ((curlet) 'pi)) */ -} - -s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) {return(let_ref(sc, let, symbol));} - -static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let" - #define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) - return(let_ref(sc, car(args), cadr(args))); -} - -static s7_pointer slot_in_let(s7_scheme *sc, s7_pointer e, s7_pointer sym) -{ - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(y); - return(sc->undefined); -} - -static s7_pointer lint_let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym) -{ - for (s7_pointer x = lt; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - - if (has_let_ref_fallback(lt)) - return(call_let_ref_fallback(sc, lt, sym)); - - return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); -} - -static inline s7_pointer g_lint_let_ref(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lt = car(args), sym = cadr(args); - if (!is_let(lt)) - wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); - for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - return(lint_let_ref_p_pp(sc, let_outlet(lt), sym)); -} - -static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool ops) -{ - if (!ops) /* || (!is_global(sc->let_ref_symbol))) */ return(f); - if (optimize_op(expr) == HOP_SAFE_C_opSq_C) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if ((car(arg1) == sc->cdr_symbol) && - (is_quoted_symbol(arg2)) && - (!is_possibly_constant(cadr(arg2)))) - { - set_opt3_sym(cdr(expr), cadr(arg2)); - return(sc->lint_let_ref); - }} - return(f); -} - -static bool op_implicit_let_ref_c(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_let(s)) {sc->last_function = s; return(false);} - sc->value = let_ref(sc, T_Ext(s), opt3_con(sc->code)); - return(true); -} - -static bool op_implicit_let_ref_a(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_let(s)) {sc->last_function = s; return(false);} - sc->value = let_ref(sc, s, fx_call(sc, cdr(sc->code))); - return(true); -} - - -/* -------------------------------- let-set! -------------------------------- */ -static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if (is_keyword(symbol)) - symbol = keyword_symbol(symbol); - symbol_increment_ctr(symbol); - - if (let == sc->rootlet) - { - s7_pointer slot; - if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string); - - slot = global_slot(symbol); - if (!is_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); - if (is_syntax(slot_value(slot))) - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); - slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value); - return(slot_value(slot)); - } - - if (let_id(let) == symbol_id(symbol)) - { - s7_pointer slot = local_slot(symbol); - if (is_slot(slot)) - return(checked_slot_set_value(sc, slot, value)); - } - for (s7_pointer x = let; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(checked_slot_set_value(sc, y, value)); - - if (!has_let_set_fallback(let)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); - /* not sure about this -- what's the most useful choice? */ - return(call_let_set_fallback(sc, let, symbol, value)); -} - -static s7_pointer let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if (!is_let(let)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, let, a_let_string); - if (!is_symbol(symbol)) - { - if (has_let_set_fallback(let)) - return(call_let_set_fallback(sc, let, symbol, value)); - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_symbol_string); - } -#if 0 - /* currently let-set! is immutable */ - if (!is_global(sc->let_set_symbol)) - check_method(sc, let, sc->let_set_symbol, set_plist_3(sc, let, symbol, value)); -#endif - return(let_set_1(sc, let, symbol, value)); -} - -s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set(sc, let, symbol, value));} - -static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) -{ - /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */ - #define H_let_set "(let-set! let sym val) sets the symbol sym's value in the let to val" - #define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T) - - if (!is_pair(cdr(args))) /* (let ((a 123.0)) (define (f) (set! (let-ref) a)) (catch #t f (lambda args #f)) (f)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code)); - - return(let_set(sc, car(args), cadr(args), caddr(args))); -} - -static s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - if (!is_symbol(p2)) - wrong_type_error_nr(sc, sc->let_set_symbol, 2, p2, a_symbol_string); - return(let_set_1(sc, p1, p2, p3)); -} - -static s7_pointer g_lint_let_set(s7_scheme *sc, s7_pointer args) -{ - s7_pointer y, lt = car(args), sym = cadr(args), val = caddr(args); - - if (!is_let(lt)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, lt, a_let_string); - if (lt != sc->rootlet) - { - for (s7_pointer x = lt; is_let(x); x = let_outlet(x)) - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - { - slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val); - return(slot_value(y)); - } - if (has_let_set_fallback(lt)) - return(call_let_set_fallback(sc, lt, sym, val)); - } - y = global_slot(sym); - if (!is_slot(y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), sym, lt)); - slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val); - return(slot_value(y)); -} - -static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool ops) -{ - if (!ops) /* || (!is_global(sc->let_set_symbol))) */ return(f); - if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); - if ((car(arg1) == sc->cdr_symbol) && - (car(arg2) == sc->quote_symbol) && - (is_symbol(cadr(arg2))) && - (!is_possibly_constant(cadr(arg2))) && - (!is_possibly_constant(arg3))) - return(sc->lint_let_set); - } - return(f); -} - - -static s7_pointer reverse_slots(s7_scheme *sc, s7_pointer list) -{ - s7_pointer p = list, result = slot_end(sc); - while (tis_slot(p)) - { - s7_pointer q = next_slot(p); - slot_set_next(p, result); - result = p; - p = q; - } - return(result); -} - -static s7_pointer let_copy(s7_scheme *sc, s7_pointer let) -{ - s7_pointer new_e; - - if (T_Let(let) == sc->rootlet) /* (copy (rootlet)) or (copy (funclet abs)) etc */ - return(sc->rootlet); - /* we can't make copy handle lets-as-objects specially because the make-object function in define-class uses copy to make a new object! - * So if it is present, we get it here, and then there's almost surely trouble. - */ - new_e = make_let(sc, let_outlet(let)); - set_all_methods(new_e, let); - sc->temp3 = new_e; - if (tis_slot(let_slots(let))) - { - s7_int id = let_id(new_e); - s7_pointer y = NULL; - for (s7_pointer x = let_slots(let); tis_slot(x); x = next_slot(x)) - { - s7_pointer z; - new_cell(sc, z, T_SLOT); - slot_set_symbol_and_value(z, slot_symbol(x), slot_value(x)); - if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */ - symbol_set_local_slot(slot_symbol(x), id, z); - if (slot_has_setter(x)) - { - slot_set_setter(z, slot_setter(x)); - slot_set_has_setter(z); - } - if (y) - slot_set_next(y, z); - else let_set_slots(new_e, z); - slot_set_next(z, slot_end(sc)); /* in case GC runs during this loop */ - y = z; - }} - /* We can't do a (normal) loop here then reverse the slots later because the symbol's local_slot has to - * match the unshadowed slot, not the last in the list: - * (let ((e1 (inlet 'a 1 'a 2))) (let ((e2 (copy e1))) (list (equal? e1 e2) (equal? (e1 'a) (e2 'a))))) - */ - sc->temp3 = sc->unused; - return(new_e); -} - - -/* -------------------------------- rootlet -------------------------------- */ -static s7_pointer g_rootlet(s7_scheme *sc, s7_pointer unused) -{ - #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)." - #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol) - return(sc->rootlet); -} -/* as with the symbol-table, this function can lead to disaster -- user could - * clobber the let etc. But we want it to be editable and augmentable, - * so I guess I'll leave it alone. (See curlet|funclet as well). - */ - -s7_pointer s7_rootlet(s7_scheme *sc) {return(sc->rootlet);} - -/* shadow_rootlet is a convenience for foreign function writers -- the C code can act as if it were loading everything into rootlet, - * but when actually loaded, everything can be shunted into a separate namespace (*motif* for example). - */ -s7_pointer s7_shadow_rootlet(s7_scheme *sc) {return(sc->shadow_rootlet);} - -s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let) -{ - s7_pointer old_let = sc->shadow_rootlet; - sc->shadow_rootlet = let; - return(old_let); /* like s7_set_curlet below */ -} - - -/* -------------------------------- curlet -------------------------------- */ -static s7_pointer g_curlet(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_curlet "(curlet) returns the current definitions (symbol bindings)" - #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol) - - sc->capture_let_counter++; - return((is_let(sc->curlet)) ? sc->curlet : sc->rootlet); -} - -s7_pointer s7_curlet(s7_scheme *sc) -{ - sc->capture_let_counter++; - return(sc->curlet); -} - -static void update_symbol_ids(s7_scheme *sc, s7_pointer e) -{ - for (s7_pointer p = let_slots(e); tis_slot(p); p = next_slot(p)) - { - s7_pointer sym = slot_symbol(p); - if (symbol_id(sym) != sc->let_number) - symbol_set_local_slot_unincremented(sym, sc->let_number, p); - } -} - -s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e) -{ - s7_pointer old_e = sc->curlet; - set_curlet(sc, e); - if ((is_let(e)) && (let_id(e) > 0)) /* might be () [id=-1] or rootlet [id=0?] etc */ - { - let_set_id(e, ++sc->let_number); - update_symbol_ids(sc, e); - } - return(old_e); -} - - -/* -------------------------------- outlet -------------------------------- */ -s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let) -{ - if ((let == sc->rootlet) || (is_null(let_outlet(let)))) - return(sc->rootlet); - return(let_outlet(let)); -} - -s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let) -{ - if (!is_let(let)) - sole_arg_wrong_type_error_nr(sc, sc->outlet_symbol, let, a_let_string); /* not a method call here! */ - if ((let == sc->rootlet) || (is_null(let_outlet(let)))) - return(sc->rootlet); - return(let_outlet(let)); -} - -static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args) -{ - #define H_outlet "(outlet let) is the environment that contains let." - #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol) - return(outlet_p_p(sc, car(args))); -} - - -static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) -{ - /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */ - s7_pointer let = car(args), new_outer; - - if (!is_let(let)) - wrong_type_error_nr(sc, wrap_string(sc, "set! outlet", 11), 1, let, sc->type_names[T_LET]); - if (let == sc->s7_starlet) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't set! (outlet *s7*)", 24))); - if (is_immutable(let)) - immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "can't (set! (outlet ~S) ~S), ~S is immutable", 44), let, cadr(args), let)); - new_outer = cadr(args); - if (!is_let(new_outer)) - wrong_type_error_nr(sc, wrap_string(sc, "set! outlet", 11), 2, new_outer, sc->type_names[T_LET]); - if (let != sc->rootlet) - { - /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */ - for (s7_pointer lt = new_outer; (is_let(lt)) && (lt != sc->rootlet); lt = let_outlet(lt)) - if (let == lt) - error_nr(sc, make_symbol(sc, "cyclic-let", 10), - set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let)); - let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); /* outlet rootlet->() so that slot search can use is_let(outlet) I think */ - } - return(new_outer); -} - -/* -------------------------------- symbol lookup -------------------------------- */ -static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer e) -{ - if (let_id(e) == symbol_id(symbol)) - return(local_value(symbol)); - if (symbol_id(symbol) < let_id(e)) - { - do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); - if (let_id(e) == symbol_id(symbol)) - return(local_value(symbol)); - } - for (; is_let(e); e = let_outlet(e)) - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(slot_value(y)); - - if (is_slot(global_slot(symbol))) - return(global_value(symbol)); -#if WITH_GCC - return(NULL); /* much faster than various alternatives */ -#else - return(unbound_variable(sc, symbol)); -#endif -} - -#if WITH_GCC && S7_DEBUGGING -static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol) -#else -static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ -#endif -{ - return(inline_lookup_from(sc, symbol, sc->curlet)); -} - -static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) -{ - if (let_id(e) == symbol_id(symbol)) - return(local_slot(symbol)); - if (symbol_id(symbol) < let_id(e)) - { - do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); - if (let_id(e) == symbol_id(symbol)) - return(local_slot(symbol)); - } - for (; is_let(e); e = let_outlet(e)) - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - return(global_slot(symbol)); -} - -s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));} - -s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));} - -s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) {slot_set_value(slot, value); return(value);} - -void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value) {set_real(slot_value(slot), value);} - -static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e) -{ - if (!is_let(e)) - return(global_slot(symbol)); - if (symbol_id(symbol) != 0) - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - return(sc->undefined); -} - -s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) -{ - s7_pointer x = lookup_slot_from(sym, sc->curlet); - return((is_slot(x)) ? slot_value(x) : sc->undefined); -} - -s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let) -{ - /* restrict the search to local let outward */ - if ((let == sc->rootlet) || (is_global(sym))) - return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); - - if (!is_let(let)) - return(s7_symbol_value(sc, sym)); - - if (let_id(let) == symbol_id(sym)) - return(local_value(sym)); - if (symbol_id(sym) < let_id(let)) - { - do {let = let_outlet(let);} while (symbol_id(sym) < let_id(let)); - if (let_id(let) == symbol_id(sym)) - return(local_value(sym)); - } - for (; is_let(let); let = let_outlet(let)) - for (s7_pointer y = let_slots(let); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - - /* need to check rootlet before giving up */ - if (is_slot(global_slot(sym))) - return(global_value(sym)); - - /* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> # not 1 */ - return(sc->undefined); /* 29-Nov-17 */ -} - - -/* -------------------------------- symbol->value -------------------------------- */ -#define lookup_global(Sc, Sym) ((is_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym)) - -static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val); -static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice); - -static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \ -symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" - #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol) - /* (symbol->value 'x e) => (e 'x)? */ - - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, sc->type_names[T_SYMBOL], 1)); - - if (is_not_null(cdr(args))) - { - s7_pointer local_let = cadr(args); - if (local_let == sc->unlet_symbol) - return((is_slot(initial_slot(sym))) ? initial_value(sym) : sc->undefined); - - if (!is_let(local_let)) - { - local_let = find_let(sc, local_let); - if (!is_let(local_let)) - return(method_or_bust(sc, cadr(args), sc->symbol_to_value_symbol, args, a_let_string, 2)); - } - if (local_let == sc->s7_starlet) - return(s7_starlet(sc, s7_starlet_symbol(sym))); - - return(s7_symbol_local_value(sc, sym, local_let)); - } - if (is_global(sym)) - return(global_value(sym)); - return(s7_symbol_value(sc, sym)); -} - -s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - s7_pointer x = lookup_slot_from(sym, sc->curlet); /* if immutable should this return an error? */ - if (is_slot(x)) - slot_set_value(x, val); /* with_hook? */ - return(val); -} - - -/* -------------------------------- symbol->dynamic-value -------------------------------- */ -static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym, int64_t *id) -{ - for (; symbol_id(sym) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(sym)) - { - (*id) = let_id(x); - return(local_value(sym)); - } - for (; (is_let(x)) && (let_id(x) > (*id)); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - { - (*id) = let_id(x); - return(slot_value(y)); - } - return(sc->unused); -} - -static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym" - #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) - - s7_pointer sym = car(args), val; - int64_t top_id = -1; - - if (!is_symbol(sym)) - return(method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, sc->type_names[T_SYMBOL], 1)); - - if (is_global(sym)) - return(global_value(sym)); - - if (let_id(sc->curlet) == symbol_id(sym)) - return(local_value(sym)); - - val = find_dynamic_value(sc, sc->curlet, sym, &top_id); - if (top_id == symbol_id(sym)) - return(val); - - for (int64_t i = current_stack_top(sc) - 1; i > 0; i -= 4) - if (is_let_unchecked(stack_let(sc->stack, i))) /* OP_GC_PROTECT let slot can be anything (even free) */ - { - s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, i), sym, &top_id); - if (cur_val != sc->unused) - val = cur_val; - if (top_id == symbol_id(sym)) - return(val); - } - return((val == sc->unused) ? s7_symbol_value(sc, sym) : val); -} - -static bool direct_memq(const s7_pointer symbol, s7_pointer symbols) -{ - for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) - if (car(x) == symbol) - return(true); - return(false); -} - -static bool direct_assq(const s7_pointer symbol, s7_pointer symbols) -{ /* used only below in do_symbol_is_safe */ - for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) - if (caar(x) == symbol) - return(true); - return(false); -} - -static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - return((is_slot(global_slot(sym))) || - (direct_assq(sym, e)) || - (is_slot(lookup_slot_from(sym, sc->curlet)))); -} - -static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - if (is_slot(global_slot(sym))) - return(true); - if (is_null(e)) - e = sc->rootlet; - return((!is_with_let_let(e)) && - (is_slot(lookup_slot_from(sym, sc->curlet)))); -} - -static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - return((symbol_is_in_list(sc, sym)) || - (let_symbol_is_safe(sc, sym, e))); -} - -static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - return((symbol_is_in_list(sc, sym)) || - (is_slot(global_slot(sym))) || - ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(lookup_slot_from(sym, sc->curlet))))); -} - -static bool pair_symbol_is_safe(s7_scheme *unused_sc, s7_pointer sym, s7_pointer e) -{ - return((is_slot(global_slot(sym))) || - (direct_memq(sym, e))); -} - -static s7_pointer collect_variables(s7_scheme *sc, s7_pointer lst, s7_pointer e) -{ - /* collect local variable names from let/do (pre-error-check), 20 overhead in tgen -> 14 if cons_unchecked below */ - sc->w = e; - for (s7_pointer p = lst; is_pair(p); p = cdr(p)) - sc->w = cons(sc, add_symbol_to_list(sc, caar(p)), sc->w); - return(sc->w); -} - -static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e) -{ - /* collect local variable names from lambda arglists (pre-error-check) */ - s7_pointer p; - s7_int the_un_id = ++sc->let_number; - if (is_symbol(lst)) - { - symbol_set_id(lst, the_un_id); - return(cons(sc, add_symbol_to_list(sc, lst), e)); - } - sc->w = e; - for (p = lst; is_pair(p); p = cdr(p)) - { - s7_pointer car_p = car(p); - if (is_pair(car_p)) - car_p = car(car_p); - if (is_normal_symbol(car_p)) - { - symbol_set_id(car_p, the_un_id); - sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w); - }} - if (is_symbol(p)) /* rest arg */ - { - symbol_set_id(p, the_un_id); - sc->w = cons(sc, add_symbol_to_list(sc, p), sc->w); - } - return(sc->w); -} - -typedef enum {OPT_F, OPT_T, OPT_OOPS} opt_t; -static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e); - -static void clear_all_optimizations(s7_scheme *sc, s7_pointer p) -{ - /* I believe that we would not have been optimized to begin with if the tree were circular, - * and this tree is supposed to be a function call + args -- a circular list here is a bug. - */ - if (is_pair(p)) - { - if ((is_optimized(p)) && - (((optimize_op(p) >= FIRST_UNHOPPABLE_OP) || /* avoid clearing hop ops, fx_function and op_unknown* need to be cleared */ - (!op_has_hop(p))))) - { - clear_optimized(p); /* includes T_SYNTACTIC */ - clear_optimize_op(p); - } - clear_all_optimizations(sc, cdr(p)); - clear_all_optimizations(sc, car(p)); - } -} - -static s7_pointer add_trace(s7_scheme *sc, s7_pointer code) -{ - if ((is_pair(car(code))) && (caar(code) == sc->trace_in_symbol)) - return(code); - return(cons_unchecked(sc, list_2(sc, sc->trace_in_symbol, list_1(sc, sc->curlet_symbol)), code)); -} - -static s7_pointer add_profile(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p; - if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol)) - return(code); - p = cons_unchecked(sc, list_3(sc, sc->profile_in_symbol, make_integer_unchecked(sc, sc->profile_position), list_1(sc, sc->curlet_symbol)), code); - sc->profile_position++; - set_unsafe_optimize_op(car(p), OP_PROFILE_IN); - return(p); -} - -static bool tree_has_definers(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - if (tree_has_definers(sc, car(p))) - return(true); - return((is_symbol(tree)) && (is_definer(tree))); -} - -static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) -{ - s7_pointer mac, body, mac_name = NULL; - uint64_t typ; - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(sc->code)); - switch (op) - { - case OP_DEFINE_MACRO: case OP_MACRO: typ = T_MACRO; break; - case OP_DEFINE_MACRO_STAR: case OP_MACRO_STAR: typ = T_MACRO_STAR; break; - case OP_DEFINE_BACRO: case OP_BACRO: typ = T_BACRO; break; - case OP_DEFINE_BACRO_STAR: case OP_BACRO_STAR: typ = T_BACRO_STAR; break; - case OP_DEFINE_EXPANSION: typ = T_MACRO | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */ - case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; - default: - if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]); - typ = T_MACRO; - break; - } - new_cell(sc, mac, typ | T_DONT_EVAL_ARGS); - closure_set_args(mac, (named) ? cdar(sc->code) : car(sc->code)); - body = cdr(sc->code); - closure_set_body(mac, body); - closure_set_setter(mac, sc->F); - closure_set_let(mac, sc->curlet); - closure_set_arity(mac, CLOSURE_ARITY_NOT_SET); - sc->capture_let_counter++; - gc_protect_via_stack(sc, mac); - - if (named) - { - s7_pointer mac_slot; - mac_name = caar(sc->code); - - if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) && - (!is_let(sc->curlet))) - set_full_type(mac_name, T_EXPANSION | T_SYMBOL | (full_type(mac_name) & T_UNHEAP)); - - /* symbol? macro name has already been checked, find name in let, and define it */ - mac_slot = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ - if (is_slot(mac_slot)) - { - if ((sc->curlet == sc->nil) && (!in_rootlet(mac_slot))) - add_slot_to_rootlet(sc, mac_slot); - slot_set_value_with_hook(mac_slot, mac); - } - else s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */ - if (tree_has_definers(sc, body)) - set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ - } - - if ((!is_either_bacro(mac)) && - (optimize(sc, body, 1, collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS)) - clear_all_optimizations(sc, body); - - if (sc->debug > 1) /* no profile here */ - closure_set_body(mac, add_trace(sc, body)); - - unstack(sc); - if (named) - { - set_pair_macro(closure_body(mac), mac_name); - set_has_pair_macro(mac); - if (has_location(car(sc->code))) - { - pair_set_location(closure_body(mac), pair_location(car(sc->code))); - set_has_location(closure_body(mac)); - }} - /* passed to maclet in apply_macro et al, copied in copy_closure */ - return(mac); -} - -static s7_pointer make_closure_unchecked(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) -{ - s7_pointer x; - new_cell_no_check(sc, x, (type | closure_bits(code))); - closure_set_args(x, args); - closure_set_let(x, sc->curlet); - closure_set_setter(x, sc->F); - closure_set_arity(x, arity); - closure_set_body(x, code); - if (is_pair(cdr(code))) set_closure_has_multiform(x); else set_closure_has_one_form(x); - sc->capture_let_counter++; - return(x); -} - -static inline s7_pointer make_closure_gc_checked(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) /* inline 100=1% tgc, 35=2% texit */ -{ - s7_pointer x; - new_cell(sc, x, (type | closure_bits(code))); - closure_set_args(x, args); - closure_set_let(x, sc->curlet); - closure_set_setter(x, sc->F); - closure_set_arity(x, arity); - closure_set_body(x, code); - if (is_pair(cdr(code))) set_closure_has_multiform(x); else set_closure_has_one_form(x); - sc->capture_let_counter++; - return(x); -} - -static s7_pointer make_closure(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) -{ - /* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */ - s7_pointer x; - new_cell(sc, x, (type | closure_bits(code))); - closure_set_args(x, args); - closure_set_let(x, sc->curlet); - closure_set_setter(x, sc->F); - closure_set_arity(x, arity); - closure_set_body(x, code); /* in case add_trace triggers GC, new func (x) needs some legit body for mark_closure */ - if (sc->debug_or_profile) - { - gc_protect_via_stack(sc, x); /* GC protect func during add_trace */ - closure_set_body(x, (sc->debug > 1) ? add_trace(sc, code) : add_profile(sc, code)); - set_closure_has_multiform(x); - unstack(sc); - } - else - if (is_pair(cdr(code))) - set_closure_has_multiform(x); - else set_closure_has_one_form(x); - sc->capture_let_counter++; - return(x); -} - -static int32_t closure_length(s7_scheme *sc, s7_pointer e) -{ - /* we can't use let_length(sc, closure_let(e)) because the closure_let(closure) - * changes. So the open bit is not always on. Besides, the fallbacks need to be for closures, not lets. - */ - s7_pointer length_func = find_method(sc, closure_let(e), sc->length_symbol); - if (length_func != sc->undefined) - return((int32_t)s7_integer(s7_apply_function(sc, length_func, set_plist_1(sc, e)))); - /* there are cases where this should raise a wrong-type-arg error, but for now... */ - return(-1); -} - -static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b) /* (used only in copy_tree_with_type) */ -{ - s7_pointer x; - new_cell_no_check(sc, x, full_type(p) & (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE)); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer copy_tree_with_type(s7_scheme *sc, s7_pointer tree) -{ - /* if sc->safety > NO_SAFETY, '(1 2) is set immutable by the reader, but eval (in that safety case) calls - * copy_body on the incoming tree, so we have to preserve T_IMMUTABLE in that case. - * if tree is something like (+ 1 (car '#1=(2 . #1#))), we have to see the quoted list and not copy it. - * Before getting here, we have checked that there is room for the entire tree (in copy_body), or 8192 cells (in list_values) in the free heap. - */ -#if WITH_GCC - #define COPY_TREE_WITH_TYPE(P) ({s7_pointer _p; _p = P; \ - cons_unchecked_with_type(sc, _p, (is_unquoted_pair(car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \ - (is_unquoted_pair(cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));}) -#else - #define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P) -#endif - return(cons_unchecked_with_type(sc, tree, - (is_unquoted_pair(car(tree))) ? COPY_TREE_WITH_TYPE(car(tree)) : car(tree), - (is_unquoted_pair(cdr(tree))) ? COPY_TREE_WITH_TYPE(cdr(tree)) : cdr(tree))); -} - -static inline s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree) -{ -#if WITH_GCC - #define COPY_TREE(P) ({s7_pointer _p; _p = P; \ - cons_unchecked(sc, (is_unquoted_pair(car(_p))) ? copy_tree(sc, car(_p)) : car(_p), \ - (is_pair(cdr(_p))) ? copy_tree(sc, cdr(_p)) : cdr(_p));}) -#else - #define COPY_TREE(P) copy_tree(sc, P) -#endif - return(cons_unchecked(sc, - (is_unquoted_pair(car(tree))) ? COPY_TREE(car(tree)) : car(tree), - (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree))); -} - - -/* -------------------------------- tree-cyclic? -------------------------------- */ -#define TREE_NOT_CYCLIC 0 -#define TREE_CYCLIC 1 -#define TREE_HAS_PAIRS 2 - -static int32_t tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree) -{ - s7_pointer fast = tree, slow = tree; /* we assume tree is a pair */ - bool has_pairs = false; - while (true) - { - if (tree_is_collected(fast)) return(TREE_CYCLIC); - if ((!has_pairs) && (is_unquoted_pair(car(fast)))) - has_pairs = true; - fast = cdr(fast); - if (!is_pair(fast)) - { - if (!has_pairs) return(TREE_NOT_CYCLIC); - break; - } - if (tree_is_collected(fast)) return(TREE_CYCLIC); - if ((!has_pairs) && (is_unquoted_pair(car(fast)))) - has_pairs = true; - fast = cdr(fast); - if (!is_pair(fast)) - { - if (!has_pairs) return(TREE_NOT_CYCLIC); - break; - } - slow = cdr(slow); - if (fast == slow) return(TREE_CYCLIC); - } - return(TREE_HAS_PAIRS); -} - -/* we can't use shared_info here because tree_is_cyclic may be called in the midst of output that depends on sc->circle_info */ - -static bool tree_is_cyclic_1(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - { - tree_set_collected(p); - if (sc->tree_pointers_top == sc->tree_pointers_size) - { - if (sc->tree_pointers_size == 0) - { - sc->tree_pointers_size = 8; - sc->tree_pointers = (s7_pointer *)Malloc(sc->tree_pointers_size * sizeof(s7_pointer)); - } - else - { - sc->tree_pointers_size *= 2; - sc->tree_pointers = (s7_pointer *)Realloc(sc->tree_pointers, sc->tree_pointers_size * sizeof(s7_pointer)); - }} - sc->tree_pointers[sc->tree_pointers_top++] = p; - if (is_unquoted_pair(car(p))) - { - int32_t old_top = sc->tree_pointers_top, result; - result = tree_is_cyclic_or_has_pairs(sc, car(p)); - if ((result == TREE_CYCLIC) || - (tree_is_cyclic_1(sc, car(p)))) - return(true); - for (int32_t i = old_top; i < sc->tree_pointers_top; i++) - tree_clear_collected(sc->tree_pointers[i]); - sc->tree_pointers_top = old_top; - }} - return(false); -} - -static bool tree_is_cyclic(s7_scheme *sc, s7_pointer tree) -{ - int32_t result; - if (!is_pair(tree)) return(false); - result = tree_is_cyclic_or_has_pairs(sc, tree); - if (result == TREE_NOT_CYCLIC) return(false); - if (result == TREE_CYCLIC) return(true); - result = tree_is_cyclic_1(sc, tree); - for (int32_t i = 0; i < sc->tree_pointers_top; i++) - tree_clear_collected(sc->tree_pointers[i]); - sc->tree_pointers_top = 0; - return(result); -} - -static s7_pointer g_tree_is_cyclic(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle." - #define Q_tree_is_cyclic sc->pl_bt - return(make_boolean(sc, tree_is_cyclic(sc, car(args)))); -} - -static inline s7_int tree_len(s7_scheme *sc, s7_pointer p); - -static s7_pointer copy_body(s7_scheme *sc, s7_pointer p) -{ - sc->w = p; - if (tree_is_cyclic(sc, p)) /* don't wrap this in is_safety_checked */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "copy: tree is cyclic: ~S", 24), p)); - check_free_heap_size(sc, tree_len(sc, p) * 2); - return((sc->safety > NO_SAFETY) ? copy_tree_with_type(sc, p) : copy_tree(sc, p)); -} - -static s7_pointer copy_closure(s7_scheme *sc, s7_pointer fnc) -{ - /* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */ - s7_pointer x, body = copy_body(sc, closure_body(fnc)); - if ((is_any_macro(fnc)) && (has_pair_macro(fnc))) - { - set_pair_macro(body, pair_macro(closure_body(fnc))); - set_has_pair_macro(fnc); - } - new_cell(sc, x, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */ - closure_set_args(x, closure_args(fnc)); - closure_set_body(x, body); - closure_set_setter(x, closure_setter(fnc)); - closure_set_arity(x, closure_arity(fnc)); - closure_set_let(x, closure_let(fnc)); - return(x); -} - - -/* -------------------------------- defined? -------------------------------- */ -static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args) -{ - #define H_is_defined "(defined? symbol (let (curlet)) ignore-globals) returns #t if symbol has a binding (a value) in the let. \ -Only the let is searched if ignore-globals is not #f." - #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, \ - s7_make_signature(sc, 5, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_macro_symbol, \ - sc->is_c_object_symbol, sc->is_c_pointer_symbol), sc->is_boolean_symbol) - /* if the symbol has a global slot and e is unset or rootlet, this returns #t */ - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(method_or_bust(sc, sym, sc->is_defined_symbol, args, sc->type_names[T_SYMBOL], 1)); - - if (is_pair(cdr(args))) - { - s7_pointer e = cadr(args), b, x; - if (!is_let(e)) - { - bool nil_is_rootlet = is_any_procedure(e); /* (defined? 'abs (lambda () 1)) -- unsure about this */ - e = find_let(sc, e); - if ((is_null(e)) && (nil_is_rootlet)) - e = sc->rootlet; - else - if (!is_let(e)) - wrong_type_error_nr(sc, sc->is_defined_symbol, 2, cadr(args), a_let_string); - } - if (is_keyword(sym)) /* if no "e", is global -> #t */ - sym = keyword_symbol(sym); /* (defined? :print-length *s7*) */ - if (e == sc->s7_starlet) - return(make_boolean(sc, s7_starlet_symbol(sym) != SL_NO_FIELD)); - if (is_pair(cddr(args))) - { - b = caddr(args); - if (!is_boolean(b)) - return(method_or_bust(sc, b, sc->is_defined_symbol, args, a_boolean_string, 3)); - } - else b = sc->F; - if (e == sc->rootlet) /* we checked (let? e) above */ - { - if (b == sc->F) - return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to # */ - return(sc->F); - } - x = symbol_to_local_slot(sc, sym, e); - if (is_slot(x)) - return(sc->T); - return((b == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); - } - return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(lookup_slot_from(sym, sc->curlet)))); -} - -static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) -{ - /* here we know arg2=(rootlet), and no arg3, arg1 is a symbol (see chooser below) */ - s7_pointer sym = lookup(sc, car(args)); /* args are unevalled because the chooser calls us through op_safe_c_nc?? */ - if (!is_symbol(sym)) /* if sym is openlet with defined? perhaps it makes sense to call it, but we need to include the rootlet arg */ - return(method_or_bust_pp(sc, sym, sc->is_defined_symbol, sym, sc->rootlet, sc->type_names[T_SYMBOL], 1)); - return(make_boolean(sc, is_slot(global_slot(sym)))); -} - -static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args == 2) && (is_symbol(cadr(expr)))) - { - s7_pointer e = caddr(expr); - if ((is_pair(e)) && (is_null(cdr(e))) && (car(e) == sc->rootlet_symbol)) - { - set_safe_optimize_op(expr, HOP_SAFE_C_NC); - return(sc->is_defined_in_rootlet); - }} - return(f); -} - -bool s7_is_defined(s7_scheme *sc, const char *name) -{ - s7_pointer x = s7_symbol_table_find_name(sc, name); - if (!x) return(false); - x = lookup_slot_from(x, sc->curlet); - return(is_slot(x)); -} - -static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_symbol(p)) return(method_or_bust(sc, p, sc->is_defined_symbol, set_plist_1(sc, p), sc->type_names[T_SYMBOL], 1) != sc->F); - return(is_slot(lookup_slot_from(p, sc->curlet))); -} - -static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer p, s7_pointer e) {return(g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F);} - - -void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer x; - if ((let == sc->nil) || (let == sc->rootlet)) - let = sc->shadow_rootlet; - x = symbol_to_local_slot(sc, symbol, let); - if (is_slot(x)) - slot_set_value_with_hook(x, value); - else - { - s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */ - /* if let is sc->nil or rootlet, s7_make_slot makes a semipermanent_slot */ - if ((let == sc->shadow_rootlet) && - (!is_slot(global_slot(symbol)))) - { - set_global(symbol); /* is_global => global_slot is usable -- is this a good idea? */ - set_global_slot(symbol, local_slot(symbol)); - }} -} - -s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value) -{ - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, value); - return(sym); -} - -s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help) -{ - s7_pointer sym = s7_define_variable(sc, name, value); - symbol_set_has_help(sym); - symbol_set_help(sym, copy_string(help)); - add_saved_pointer(sc, symbol_help(sym)); - return(sym); -} - -s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value) -{ - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, envir, sym, value); - set_immutable(sym); - set_possibly_constant(sym); - set_immutable(global_slot(sym)); - set_immutable(local_slot(sym)); - return(sym); -} - -s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value) -{ - return(s7_define_constant_with_environment(sc, sc->nil, name, value)); -} - -/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar - * (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa - */ - -s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help) -{ - s7_pointer sym = s7_define_constant(sc, name, value); - symbol_set_has_help(sym); - symbol_set_help(sym, copy_string(help)); - add_saved_pointer(sc, symbol_help(sym)); - return(value); /* inconsistent with variable above, but consistent with define_function? */ -} - - -/* -------------------------------- keyword? -------------------------------- */ -bool s7_is_keyword(s7_pointer obj) {return(is_symbol_and_keyword(obj));} - -static s7_pointer g_is_keyword(s7_scheme *sc, s7_pointer args) -{ - #define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" - #define Q_is_keyword sc->pl_bt - check_boolean_method(sc, is_symbol_and_keyword, sc->is_keyword_symbol, args); -} - - -/* -------------------------------- string->keyword -------------------------------- */ -s7_pointer s7_make_keyword(s7_scheme *sc, const char *key) -{ - s7_pointer sym; - size_t slen = (size_t)safe_strlen(key); - block_t *b = inline_mallocate(sc, slen + 2); - char *name = (char *)block_data(b); - name[0] = ':'; - memcpy((void *)(name + 1), (void *)key, slen); - name[slen + 1] = '\0'; - sym = inline_make_symbol(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */ - liberate(sc, b); - return(sym); -} - -static s7_pointer g_string_to_keyword(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_keyword "(string->keyword str) prepends ':' to str and defines that as a keyword" - #define Q_string_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol) - - s7_pointer str = car(args); - if (!is_string(str)) - return(sole_arg_method_or_bust(sc, str, sc->string_to_keyword_symbol, args, sc->type_names[T_STRING])); - if ((string_length(str) == 0) || - (string_value(str)[0] == '\0')) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "string->keyword wants a non-null string: ~S", 43), str)); - return(s7_make_keyword(sc, string_value(str))); -} - - -/* -------------------------------- keyword->symbol -------------------------------- */ -static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon" - #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) - - s7_pointer sym = car(args); - if (!is_symbol_and_keyword(sym)) - return(sole_arg_method_or_bust_p(sc, sym, sc->keyword_to_symbol_symbol, wrap_string(sc, "a keyword", 9))); - return(keyword_symbol(sym)); -} - -s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key) {return(keyword_symbol(key));} - - -/* -------------------------------- symbol->keyword -------------------------------- */ -#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym)) - -static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended" - #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol) - - if (!is_symbol(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->symbol_to_keyword_symbol, args, sc->type_names[T_SYMBOL])); - return(symbol_to_keyword(sc, car(args))); -} - - -/* -------------------------------- c-pointer? -------------------------------- */ -bool s7_is_c_pointer(s7_pointer arg) {return(is_c_pointer(arg));} - -bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type) {return((is_c_pointer(arg)) && (c_pointer_type(arg) == type));} - -static s7_pointer g_is_c_pointer(s7_scheme *sc, s7_pointer args) -{ - #define H_is_c_pointer "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7. \ -If type is given, the c_pointer's type is also checked." - #define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - - s7_pointer p = car(args); - if (is_c_pointer(p)) - return((is_pair(cdr(args))) ? make_boolean(sc, c_pointer_type(p) == cadr(args)) : sc->T); - if (!has_active_methods(sc, p)) return(sc->F); - return(apply_boolean_method(sc, p, sc->is_c_pointer_symbol)); -} - - -/* -------------------------------- c-pointer -------------------------------- */ -void *s7_c_pointer(s7_pointer p) {return(c_pointer(p));} - -void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum) -{ - if (!is_c_pointer(p)) - wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), argnum, p, sc->type_names[T_C_POINTER]); - if ((c_pointer(p) != NULL) && - (c_pointer_type(p) != expected_type)) - error_nr(sc, sc->wrong_type_arg_symbol, - (argnum == 0) ? - set_elist_4(sc, wrap_string(sc, "~S argument is a pointer of type ~S, but expected ~S", 52), - wrap_string(sc, caller, safe_strlen(caller)), c_pointer_type(p), expected_type) : - set_elist_5(sc, wrap_string(sc, "~S ~:D argument got a pointer of type ~S, but expected ~S", 57), - wrap_string(sc, caller, safe_strlen(caller)), - wrap_integer(sc, argnum), c_pointer_type(p), expected_type)); - return(c_pointer(p)); -} - -s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) -{ - s7_pointer x; - new_cell(sc, x, T_C_POINTER); - c_pointer(x) = ptr; - c_pointer_type(x) = type; - c_pointer_info(x) = info; - c_pointer_weak1(x) = sc->F; - c_pointer_weak2(x) = sc->F; - return(x); -} - -s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));} - -static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer "(c-pointer int type info weak1 weak2) returns a c-pointer object. The type and info args are optional, defaulting to #f." - #define Q_c_pointer s7_make_circular_signature(sc, 2, 3, sc->is_c_pointer_symbol, sc->is_integer_symbol, sc->T) - - s7_pointer arg = car(args), type = sc->F, info = sc->F, weak1 = sc->F, weak2 = sc->F, cp; - intptr_t p; - - if (!s7_is_integer(arg)) - return(method_or_bust(sc, arg, sc->c_pointer_symbol, args, sc->type_names[T_INTEGER], 1)); - p = (intptr_t)s7_integer_clamped_if_gmp(sc, arg); /* (c-pointer (bignum "1234")) */ - args = cdr(args); - if (is_pair(args)) - { - type = car(args); - args = cdr(args); - if (is_pair(args)) - { - info = car(args); - args = cdr(args); - if (is_pair(args)) - { - weak1 = car(args); - args = cdr(args); - if (is_pair(args)) - weak2 = car(args); - }}} - cp = s7_make_c_pointer_with_type(sc, (void *)p, type, info); - c_pointer_set_weak1(cp, weak1); - c_pointer_set_weak2(cp, weak2); - if ((weak1 != sc->F) || (weak2 != sc->F)) - add_weak_ref(sc, cp); - return(cp); -} - - -/* -------------------------------- c-pointer-info -------------------------------- */ -static s7_pointer c_pointer_info_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_c_pointer(p)) - return(method_or_bust_p(sc, p, sc->c_pointer_info_symbol, sc->type_names[T_C_POINTER])); - return(c_pointer_info(p)); -} - -static s7_pointer g_c_pointer_info(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_info "(c-pointer-info obj) returns the c-pointer info field" - #define Q_c_pointer_info s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_info_p_p(sc, car(args))); -} - - -/* -------------------------------- c-pointer-type -------------------------------- */ -static s7_pointer method_or_bust_lp(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ) -{ /* weird -- overhead goes berserk in callgrind if using the simpler method_or_bust_p! */ - if (!has_active_methods(sc, obj)) - wrong_type_error_nr(sc, method, 1, obj, sc->type_names[typ]); - return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj))); -} - -s7_pointer s7_c_pointer_type(s7_pointer p) {return((is_c_pointer(p)) ? c_pointer_type(p) : NULL);} - -static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer p) -{ - return((is_c_pointer(p)) ? c_pointer_type(p) : method_or_bust_lp(sc, p, sc->c_pointer_type_symbol, T_C_POINTER)); -} - -static s7_pointer g_c_pointer_type(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_type "(c-pointer-type obj) returns the c-pointer type field" - #define Q_c_pointer_type s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_type_p_p(sc, car(args))); -} - - -/* -------------------------------- c-pointer-weak1/2 -------------------------------- */ -static s7_pointer c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer p) -{ - return((is_c_pointer(p)) ? c_pointer_weak1(p) : method_or_bust_lp(sc, p, sc->c_pointer_weak1_symbol, T_C_POINTER)); -} - -static s7_pointer g_c_pointer_weak1(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_weak1 "(c-pointer-weak1 obj) returns the c-pointer weak1 field" - #define Q_c_pointer_weak1 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_weak1_p_p(sc, car(args))); -} - -static s7_pointer c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer p) -{ - return((is_c_pointer(p)) ? c_pointer_weak2(p) : method_or_bust_lp(sc, p, sc->c_pointer_weak2_symbol, T_C_POINTER)); -} - -static s7_pointer g_c_pointer_weak2(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_weak2 "(c-pointer-weak2 obj) returns the c-pointer weak2 field" - #define Q_c_pointer_weak2 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_weak2_p_p(sc, car(args))); -} - - -/* -------------------------------- c-pointer->list -------------------------------- */ -static s7_pointer g_c_pointer_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_to_list "(c-pointer->list obj) returns the c-pointer data as (list pointer-as-int type info)" - #define Q_c_pointer_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_c_pointer_symbol) - - s7_pointer p = car(args); - if (!is_c_pointer(p)) - return(method_or_bust(sc, p, sc->c_pointer_to_list_symbol, args, sc->type_names[T_C_POINTER], 1)); - return(list_3(sc, make_integer(sc, (s7_int)((intptr_t)c_pointer(p))), c_pointer_type(p), c_pointer_info(p))); -} - - -/* -------------------------------- continuations and gotos -------------------------------- */ -enum {NO_JUMP, CALL_WITH_EXIT_JUMP, THROW_JUMP, CATCH_JUMP, ERROR_JUMP, ERROR_QUIT_JUMP}; -enum {NO_SET_JUMP, READ_SET_JUMP, LOAD_SET_JUMP, DYNAMIC_WIND_SET_JUMP, S7_CALL_SET_JUMP, EVAL_SET_JUMP}; - - -/* ----------------------- continuation? -------------------------------- */ -static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args) -{ - #define H_is_continuation "(continuation? obj) returns #t if obj is a continuation" - #define Q_is_continuation sc->pl_bt - check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, args); - /* is this the right thing? It returns #f for call-with-exit ("goto") because - * that form of continuation can't continue (via a jump back to its context). - */ -} - -static bool is_continuation_b_p(s7_pointer p) {return(is_continuation(p));} - -#if S7_DEBUGGING -static s7_pointer check_wrap_return(s7_pointer lst) -{ - for (s7_pointer fast = lst, slow = lst; is_pair(fast); slow = cdr(slow), fast = cdr(fast)) - { - if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n"); - fast = cdr(fast); - if (!is_pair(fast)) return(lst); - if (fast == slow) return(lst); - if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n"); - } - return(lst); -} -#endif - -static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a) -{ - s7_pointer slow = cdr(a); - s7_pointer fast = slow; - s7_pointer p; -#if S7_DEBUGGING - #define wrap_return(W) do {fast = W; W = sc->unused; sc->y = sc->unused; return(check_wrap_return(fast));} while (0) -#else - #define wrap_return(W) do {fast = W; W = sc->unused; sc->y = sc->unused; return(fast);} while (0) -#endif - init_temp(sc->y, a); /* gc_protect_via_stack doesn't work here because we're called in copy_stack, I think (trouble is in call/cc stuff) */ - sc->w = list_1(sc, car(a)); - p = sc->w; - while (true) - { - if (!is_pair(fast)) - { - if (is_null(fast)) - wrap_return(sc->w); - set_cdr(p, fast); - wrap_return(sc->w); - } - - set_cdr(p, list_1(sc, car(fast))); - p = cdr(p); - fast = cdr(fast); - if (!is_pair(fast)) - { - if (is_null(fast)) - wrap_return(sc->w); - set_cdr(p, fast); - wrap_return(sc->w); - } - /* if unrolled further, it's a lot slower? */ - set_cdr(p, list_1_unchecked(sc, car(fast))); - p = cdr(p); - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) - { - /* try to preserve the original cyclic structure */ - s7_pointer p1, f1, p2, f2; - set_match_pair(a); - for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); f1 = cdr(f1), p1 = cdr(p1)) - set_match_pair(f1); - for (p2 = sc->w, f2 = a; cdr(f1) != f2; f2 = cdr(f2), p2 = cdr(p2)) - clear_match_pair(f2); - for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2)) - { - clear_match_pair(f1); - f1 = cdr(f1); - clear_match_pair(f1); - if (f1 == f2) break; - } - clear_match_pair(a); - if (is_null(p1)) - set_cdr(p2, p2); - else set_cdr(p1, p2); - wrap_return(sc->w); - }} - wrap_return(sc->w); -} - -static s7_pointer copy_counter(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer nobj; - new_cell(sc, nobj, T_COUNTER); - counter_set_result(nobj, counter_result(obj)); - counter_set_list(nobj, counter_list(obj)); - counter_set_capture(nobj, counter_capture(obj)); - counter_set_let(nobj, counter_let(obj)); - counter_set_slots(nobj, counter_slots(obj)); - return(nobj); -} - -static void copy_stack_list_set_immutable(s7_scheme *unused_sc, s7_pointer pold, s7_pointer pnew) -{ - for (s7_pointer p1 = pold, p2 = pnew, slow = pold; is_pair(p2); p1 = cdr(p1), p2 = cdr(p2)) - { - if (is_immutable(p1)) set_immutable(p2); - if (is_pair(cdr(p1))) - { - p1 = cdr(p1); - p2 = cdr(p2); - if (is_immutable(p1)) set_immutable(p2); - if (p1 == slow) break; - slow = cdr(slow); - }} -} - -static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, int64_t top) -{ - bool has_pairs = false; - s7_pointer *nv = stack_elements(new_v); - s7_pointer *ov = stack_elements(old_v); - memcpy((void *)nv, (void *)ov, top * sizeof(s7_pointer)); - stack_clear_flags(new_v); - - s7_gc_on(sc, false); - if (stack_has_counters(old_v)) - { - for (int64_t i = 2; i < top; i += 4) - { - s7_pointer p = ov[i]; /* args */ - /* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */ - if (is_pair(p)) /* args need not be a list (it can be a port or #f, etc) */ - { - has_pairs = true; - if (is_null(cdr(p))) - nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */ - else - if ((is_pair(cdr(p))) && (is_null(cddr(p)))) - nv[i] = list_2_unchecked(sc, car(p), cadr(p)); - else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ - /* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */ - copy_stack_list_set_immutable(sc, p, nv[i]); - } - /* lst can be dotted or circular here. The circular list only happens in a case like: - * (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f)) - * proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let - */ - else - if (is_counter(p)) /* these can only occur in this context (not in a list etc) */ - { - stack_set_has_counters(new_v); - nv[i] = copy_counter(sc, p); - }}} - else - for (int64_t i = 2; i < top; i += 4) - if (is_pair(ov[i])) - { - s7_pointer p = ov[i]; - has_pairs = true; - if (is_null(cdr(p))) - nv[i] = cons_unchecked(sc, car(p), sc->nil); - else - if ((is_pair(cdr(p))) && (is_null(cddr(p)))) - nv[i] = list_2_unchecked(sc, car(p), cadr(p)); - else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ - copy_stack_list_set_immutable(sc, p, nv[i]); - } - if (has_pairs) stack_set_has_pairs(new_v); - s7_gc_on(sc, true); - return(new_v); -} - -static s7_pointer copy_op_stack(s7_scheme *sc) -{ - int32_t len = (int32_t)(sc->op_stack_now - sc->op_stack); - s7_pointer nv = make_simple_vector(sc, len); /* not sc->op_stack_size */ - if (len > 0) - { - s7_pointer *src = sc->op_stack; - s7_pointer *dst = (s7_pointer *)vector_elements(nv); - for (int32_t i = len; i > 0; i--) *dst++ = *src++; - } - return(nv); -} - -/* -------------------------------- with-baffle -------------------------------- */ -/* (with-baffle . body) calls body guaranteeing that there can be no jumps into the - * middle of it from outside -- no outer evaluation of a continuation can jump across this - * barrier: The flip-side of call-with-exit. - */ - -static bool find_baffle(s7_scheme *sc, s7_int key) -{ - /* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */ - if (sc->baffle_ctr > 0) - for (s7_pointer x = sc->curlet; is_let(x); x = let_outlet(x)) - if ((is_baffle_let(x)) && - (let_baffle_key(x) == key)) - return(true); - return(false); -} - -#define NOT_BAFFLED -1 - -static s7_int find_any_baffle(s7_scheme *sc) -{ - /* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */ - if (sc->baffle_ctr > 0) - for (s7_pointer x = sc->curlet; is_let(x); x = let_outlet(x)) - if (is_baffle_let(x)) - return(let_baffle_key(x)); - return(NOT_BAFFLED); -} - -static void check_with_baffle(s7_scheme *sc) -{ - if (!s7_is_proper_list(sc, sc->code)) - syntax_error_nr(sc, "with-baffle: unexpected dot? ~A", 31, sc->code); - pair_set_syntax_op(sc->code, OP_WITH_BAFFLE_UNCHECKED); -} - -static bool op_with_baffle_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - if (is_null(sc->code)) - { - sc->value = sc->nil; - return(true); - } - sc->curlet = make_let(sc, sc->curlet); - set_baffle_let(sc->curlet); - set_let_baffle_key(sc->curlet, sc->baffle_ctr++); - return(false); -} - - -/* -------------------------------- call/cc -------------------------------- */ -static void make_room_for_cc_stack(s7_scheme *sc) -{ - if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) /* we probably never need this much space */ - { - call_gc(sc); - if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) - resize_heap(sc); - } -} - -s7_pointer s7_make_continuation(s7_scheme *sc) -{ - s7_pointer x, stack; - int64_t loc; - block_t *block; - - sc->continuation_counter++; - make_room_for_cc_stack(sc); - if (sc->continuation_counter > 2000) call_gc(sc); /* call_gc zeros cc counter, gc time up, but run time down -- try big cache */ - - loc = current_stack_top(sc); - stack = make_simple_vector(sc, loc); - set_full_type(stack, T_STACK); - temp_stack_top(stack) = loc; - sc->temp7 = stack; - copy_stack(sc, stack, sc->stack, loc); - - new_cell(sc, x, T_CONTINUATION); - block = mallocate_block(sc); - continuation_block(x) = block; - continuation_set_stack(x, stack); - continuation_stack_size(x) = vector_length(continuation_stack(x)); - continuation_stack_start(x) = stack_elements(continuation_stack(x)); - continuation_stack_end(x) = (s7_pointer *)(continuation_stack_start(x) + loc); - continuation_op_stack(x) = copy_op_stack(sc); - continuation_op_loc(x) = (int32_t)(sc->op_stack_now - sc->op_stack); - continuation_op_size(x) = sc->op_stack_size; - continuation_key(x) = find_any_baffle(sc); - continuation_name(x) = sc->F; - sc->temp7 = sc->unused; - - add_continuation(sc, x); - return(x); -} - -static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let); -static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value); -static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e); -static s7_pointer eval(s7_scheme *sc, opcode_t first_op); - -static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) -{ - /* called only from call_with_current_continuation. - * if call/cc jumps into a dynamic-wind, the init/finish funcs are wrapped in with-baffle - * so they'll complain. Otherwise we're supposed to re-run the init func before diving - * into the body. Similarly for let-temporarily. If a call/cc jumps out of a dynamic-wind - * body-func, we're supposed to call the finish-func. The continuation is called at - * current_stack_top(sc); the continuation form is at continuation_stack_top(c). - * - * check sc->stack for dynamic-winds we're jumping out of - * we need to check from the current stack top down to where the continuation stack matches the current stack?? - * this was (i > 0), but that goes too far back; perhaps s7 should save the position of the call/cc invocation. - * also the two stacks can be different sizes (either can be larger) - */ - int64_t top1 = current_stack_top(sc), top2 = continuation_stack_top(c); - for (int64_t i = top1 - 1; (i > 0) && ((i >= top2) || (stack_code(sc->stack, i) != stack_code(continuation_stack(c), i))); i -= 4) - { - opcode_t op = stack_op(sc->stack, i); - switch (op) - { - case OP_DYNAMIC_WIND: - case OP_LET_TEMP_DONE: - { - s7_pointer x = stack_code(sc->stack, i); - int64_t s_base = 0; - for (int64_t j = 3; j < top2; j += 4) - if (((stack_op(continuation_stack(c), j) == OP_DYNAMIC_WIND) || - (stack_op(continuation_stack(c), j) == OP_LET_TEMP_DONE)) && - (x == stack_code(continuation_stack(c), j))) - { - s_base = i; - break; - } - if (s_base == 0) - { - if (op == OP_DYNAMIC_WIND) - { - if (dynamic_wind_state(x) == DWIND_BODY) - { - dynamic_wind_state(x) = DWIND_FINISH; - if (dynamic_wind_out(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); - }} - else let_temp_done(sc, stack_args(sc->stack, i), stack_let(sc->stack, i)); - }} - break; - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - break; - - case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_UNWIND: - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_DIRECT_UNWIND: - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - break; - - case OP_BARRIER: - if (i > top2) /* otherwise it's some unproblematic outer eval-string? */ - return(false); /* but what if we've already evaluated a dynamic-wind closer? */ - break; - - case OP_DEACTIVATE_GOTO: /* here we're jumping out of an unrelated call-with-exit block */ - if (i > top2) - call_exit_active(stack_args(sc->stack, i)) = false; - break; - - case OP_UNWIND_INPUT: - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - case OP_UNWIND_OUTPUT: - if (stack_args(sc->stack, i) != sc->unused) - set_current_output_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - default: - if ((S7_DEBUGGING) && (op == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - break; - }} - - /* check continuation-stack for dynamic-winds we're jumping into */ - for (int64_t i = current_stack_top(sc) - 1; i < top2; i += 4) - { - opcode_t op = stack_op(continuation_stack(c), i); - if (op == OP_DYNAMIC_WIND) - { - s7_pointer x = T_Dyn(stack_code(continuation_stack(c), i)); - if (dynamic_wind_in(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_in(x), sc->nil); - dynamic_wind_state(x) = DWIND_BODY; - } - else - if (op == OP_DEACTIVATE_GOTO) - call_exit_active(stack_args(continuation_stack(c), i)) = true; - /* not let_temp_done here! */ - /* if op == OP_LET_TEMP_DONE, we're jumping back into a let-temporarily. MIT and Chez scheme say they remember the - * let-temp vars (fluid-let or parameters in their terminology) at the point of the call/cc, and restore them - * on re-entry; that strikes me as incoherently complex -- they've wrapped a hidden dynamic-wind around the - * call/cc to restore all let-temp vars! I think let-temp here should be the same as let -- if you jump back - * in, nothing hidden happens. So, - * (let ((x #f) (cc #f)) - * (let-temporarily ((x 1)) - * (set! x 2) (call/cc (lambda (r) (set! cc r))) (display x) (unless (= x 2) (newline) (exit)) (set! x 3) (cc))) - * behaves the same (in this regard) if let-temp is replaced with let. - */ - } - return(true); -} - -static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args); - -static void call_with_current_continuation(s7_scheme *sc) -{ - s7_pointer c = sc->code; /* sc->args are the returned values */ - - /* check for (baffle ...) blocking the current attempt to continue */ - if ((continuation_key(c) != NOT_BAFFLED) && - (!(find_baffle(sc, continuation_key(c))))) - error_nr(sc, sc->baffled_symbol, - (is_symbol(continuation_name(sc->code))) ? - set_elist_2(sc, wrap_string(sc, "continuation ~S can't jump into with-baffle", 43), continuation_name(sc->code)) : - set_elist_1(sc, wrap_string(sc, "continuation can't jump into with-baffle", 40))); - - if (check_for_dynamic_winds(sc, c)) - { - /* make_room_for_cc_stack(sc); */ /* 28-May-21 */ - /* we push_stack sc->code before calling an embedded eval above, so sc->code should still be c here, etc */ - if ((stack_has_pairs(continuation_stack(c))) || - (stack_has_counters(continuation_stack(c)))) - { - make_room_for_cc_stack(sc); - copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); - } - else - { - s7_pointer *nv = stack_elements(sc->stack); - s7_pointer *ov = stack_elements(continuation_stack(c)); - memcpy((void *)nv, (void *)ov, continuation_stack_top(c) * sizeof(s7_pointer)); - } - /* copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); */ - sc->stack_end = (s7_pointer *)(sc->stack_start + continuation_stack_top(c)); - - { - int32_t top = continuation_op_loc(c); - s7_pointer *src, *dst; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + top); - sc->op_stack_size = continuation_op_size(c); - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); - src = (s7_pointer *)vector_elements(continuation_op_stack(c)); - dst = sc->op_stack; - for (int32_t i = 0; i < top; i++) dst[i] = src[i]; - } - sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args)); - } -} - -static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args) -{ - #define H_call_cc "(call-with-current-continuation (lambda (continuer)...)) is always a mistake!" - #define Q_call_cc s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol) - - s7_pointer p = car(args); /* this is the procedure passed to call/cc */ - if (!is_t_procedure(p)) /* this includes continuations */ - { - check_method(sc, p, sc->call_cc_symbol, args); - check_method(sc, p, sc->call_with_current_continuation_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->call_cc_symbol, p, a_procedure_string); - } - if (((!is_closure(p)) || - (closure_arity(p) != 1)) && - (!s7_is_aritable(sc, p, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call/cc procedure, ~A, should take one argument", 47), p)); - - sc->w = s7_make_continuation(sc); - if ((is_any_closure(p)) && (is_pair(closure_args(p))) && (is_symbol(car(closure_args(p))))) - continuation_name(sc->w) = car(closure_args(p)); - push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->w), p); /* apply function p to continuation sc->w */ - sc->w = sc->unused; - return(sc->nil); -} - -/* we can't naively optimize call/cc to call-with-exit if the continuation is only - * used as a function in the call/cc body because it might (for example) be wrapped - * in a lambda form that is being exported. See b-func in s7test for an example. - */ - -static void op_call_cc(s7_scheme *sc) -{ - sc->w = s7_make_continuation(sc); - continuation_name(sc->w) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, continuation_name(sc->w), sc->w); - sc->w = sc->unused; - sc->code = cdr(opt2_pair(sc->code)); /* cddadr(sc->code) */ -} - -static bool op_implicit_continuation_a(s7_scheme *sc) -{ - s7_pointer code = sc->code; /* dumb-looking code, but it's faster than the pretty version, according to callgrind */ - s7_pointer s = lookup_checked(sc, car(code)); - if (!is_continuation(s)) {sc->last_function = s; return(false);} - sc->code = s; - sc->args = set_plist_1(sc, fx_call(sc, cdr(code))); - call_with_current_continuation(sc); - return(true); -} - - -/* -------------------------------- call-with-exit -------------------------------- */ -static void pop_input_port(s7_scheme *sc); - -static void call_with_exit(s7_scheme *sc) -{ - int64_t i, new_stack_top, quit = 0; - - if (!call_exit_active(sc->code)) - error_nr(sc, sc->invalid_escape_function_symbol, - set_elist_1(sc, wrap_string(sc, "call-with-exit escape procedure called outside its block", 56))); - - call_exit_active(sc->code) = false; - new_stack_top = call_exit_goto_loc(sc->code); - sc->op_stack_now = (s7_pointer *)(sc->op_stack + call_exit_op_loc(sc->code)); - - /* look for dynamic-wind in the stack section that we are jumping out of */ - i = current_stack_top(sc) - 1; - do { - switch (stack_op(sc->stack, i)) /* avoidable if we group these ops at the end and use op< */ - { - case OP_DYNAMIC_WIND: - { - s7_pointer lx = T_Dyn(stack_code(sc->stack, i)); - if (dynamic_wind_state(lx) == DWIND_BODY) - { - dynamic_wind_state(lx) = DWIND_FINISH; - if (dynamic_wind_out(lx) != sc->F) - { - s7_pointer arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused; /* might also need GC protection here */ - /* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */ - sc->value = s7_call(sc, dynamic_wind_out(lx), sc->nil); - if (arg != sc->unused) set_plist_1(sc, arg); - }}} - break; - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - dynamic_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_EVAL_STRING: - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - break; - - case OP_BARRIER: /* oops -- we almost certainly went too far */ - goto SET_VALUE; - - case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */ - call_exit_active(stack_args(sc->stack, i)) = false; - break; - - case OP_LET_TEMP_DONE: - { - s7_pointer old_args = sc->args; - let_temp_done(sc, stack_args(sc->stack, i), stack_let(sc->stack, i)); - sc->args = old_args; - } - break; - - case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_UNWIND: - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_DIRECT_UNWIND: - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - break; - - /* call/cc does not close files, but I think call-with-exit should */ - case OP_GET_OUTPUT_STRING: - case OP_UNWIND_OUTPUT: - { - s7_pointer x = T_Prt(stack_code(sc->stack, i)); /* "code" = port that we opened */ - s7_close_output_port(sc, x); - x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not # */ - if (x != sc->unused) - set_current_output_port(sc, x); - } - break; - - case OP_UNWIND_INPUT: - s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */ - quit++; - break; - - default: - if ((S7_DEBUGGING) && (stack_op(sc->stack, i) == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - break; - } - i -= 4; - } while (i > new_stack_top); - - SET_VALUE: - sc->stack_end = (s7_pointer *)(sc->stack_start + new_stack_top); - - /* the return value should have an implicit values call, just as in call/cc */ - sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args)); - if (quit > 0) - { - if (sc->longjmp_ok) - { - pop_stack(sc); - LongJmp(*(sc->goto_start), CALL_WITH_EXIT_JUMP); - } - for (i = 0; i < quit; i++) - push_stack_op_let(sc, OP_EVAL_DONE); - } -} - -static s7_pointer g_is_goto(s7_scheme *sc, s7_pointer args) -{ - #define H_is_goto "(goto? obj) returns #t if obj is a call-with-exit exit function" - #define Q_is_goto sc->pl_bt - return(make_boolean(sc, is_goto(car(args)))); -} - -static inline s7_pointer make_goto(s7_scheme *sc, s7_pointer name) /* inline for 73=1% in tgc */ -{ - s7_pointer x; - new_cell(sc, x, T_GOTO); - call_exit_goto_loc(x) = current_stack_top(sc); - call_exit_op_loc(x) = (int32_t)(sc->op_stack_now - sc->op_stack); - call_exit_active(x) = true; - call_exit_name(x) = name; - return(x); -} - -static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args) /* (call-with-exit (lambda (return) ...)) */ -{ - #define H_call_with_exit "(call-with-exit (lambda (exiter) ...)) is call/cc without the ability to jump back into a previous computation." - #define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol) - - s7_pointer p = car(args), x; - if (is_any_closure(p)) - { - x = make_goto(sc, ((is_pair(closure_args(p))) && (is_symbol(car(closure_args(p))))) ? car(closure_args(p)) : sc->F); - push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */ - push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p); - return(sc->nil); - } - /* maybe just return an error here -- these gotos as args are stupid; also an error above if closure not aritable 1 */ - if (!is_t_procedure(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->call_with_exit_symbol, a_procedure_string)); - if (!s7_is_aritable(sc, p, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a function of one argument: ~S", 64), p)); - x = make_goto(sc, sc->F); - call_exit_active(x) = false; - return((is_c_function(p)) ? c_function_call(p)(sc, set_plist_1(sc, x)) : s7_apply_function_star(sc, p, set_plist_1(sc, x))); -} - -static inline void op_call_with_exit(s7_scheme *sc) -{ - s7_pointer args = opt2_pair(sc->code); - s7_pointer go = make_goto(sc, caar(args)); - push_stack_no_let_no_code(sc, OP_DEACTIVATE_GOTO, go); /* was also pushing code */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(args), go); - sc->code = T_Pair(cdr(args)); -} - -static void op_call_with_exit_o(s7_scheme *sc) -{ - op_call_with_exit(sc); - sc->code = car(sc->code); -} - -static bool op_implicit_goto(s7_scheme *sc) -{ - s7_pointer g = lookup_checked(sc, car(sc->code)); - if (!is_goto(g)) {sc->last_function = g; return(false);} - sc->args = sc->nil; - sc->code = g; - call_with_exit(sc); - return(true); -} - -static bool op_implicit_goto_a(s7_scheme *sc) -{ - s7_pointer g = lookup_checked(sc, car(sc->code)); - if (!is_goto(g)) {sc->last_function = g; return(false);} - sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); - sc->code = g; - call_with_exit(sc); - return(true); -} - - -/* -------------------------------- numbers -------------------------------- */ -static block_t *string_to_block(s7_scheme *sc, const char *p, s7_int len) -{ - block_t *b = inline_mallocate(sc, len + 1); - char *bp = (char *)block_data(b); - memcpy((void *)bp, (void *)p, len); - bp[len] = '\0'; - return(b); -} - -static Inline s7_pointer inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len) -{ - s7_pointer x; - new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE); - string_block(x) = block; - string_value(x) = (char *)block_data(block); - string_length(x) = len; - string_value(x)[len] = '\0'; - string_hash(x) = 0; - add_string(sc, x); - return(x); -} - -static s7_pointer block_to_string(s7_scheme *sc, block_t *block, s7_int len) {return(inline_block_to_string(sc, block, len));} - -static inline s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den) -{ - s7_pointer x; - if (den == 1) - return(make_integer(sc, num)); - if (den == -1) - return(make_integer(sc, -num)); - if ((den == S7_INT64_MIN) && ((num & 1) != 0)) - return(make_real(sc, (long_double)num / (long_double)den)); - new_cell(sc, x, T_RATIO); - if (den < 0) /* this is noticeably faster in callgrind than using (den < 0) ? ... twice */ - { - numerator(x) = -num; - denominator(x) = -den; - } - else - { - numerator(x) = num; - denominator(x) = den; - } - return(x); -} - -static bool is_zero(s7_pointer x); -static bool is_positive(s7_scheme *sc, s7_pointer x); -static bool is_negative(s7_scheme *sc, s7_pointer x); -static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b); - -static bool is_NaN(s7_double x) {return(x != x);} -/* callgrind says this is faster than isnan, I think (very confusing data...) */ - -#if defined(__sun) && defined(__SVR4) - static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* there's no isinf in Solaris */ -#else -#if (!MS_WINDOWS) - #if __cplusplus - #define is_inf(x) std::isinf(x) - #else - #define is_inf(x) isinf(x) - #endif -#else - static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* Another possibility: (x * 0) != 0 */ - -#if (_MSC_VER < 1700) - /* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */ - static double asinh(double x) {return(log(x + sqrt(1.0 + x * x)));} - static double acosh(double x) {return(log(x + sqrt(x * x - 1.0)));} - /* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */ - static double atanh(double x) {return(log((1.0 + x) / (1.0 - x)) / 2.0);} - static double cbrt(double x) {if (x >= 0.0) return(pow(x, 1.0 / 3.0)); return(-pow(-x, 1.0 / 3.0));} -#endif -#endif /* windows */ -#endif /* not sun */ - - -/* -------------------------------- NaN payloads -------------------------------- */ -typedef union {int64_t ix; double fx;} decode_float_t; - -static double nan_with_payload(int64_t payload) -{ - decode_float_t num; - if (payload <= 0) return(NAN); - num.fx = NAN; - num.ix = num.ix | payload; - return(num.fx); -} - -static s7_pointer make_nan_with_payload(s7_scheme *sc, s7_int payload) -{ - s7_pointer x = make_real(sc, nan_with_payload(payload)); - char buf[32]; - s7_int nlen = 0; - nlen = snprintf(buf, 32, "+nan.%" ld64, payload); - set_number_name(x, buf, nlen); - return(x); -} - -static s7_pointer g_nan(s7_scheme *sc, s7_pointer args) -{ - #define H_nan "(nan int) returns a NaN with payload int" - #define Q_nan s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_integer_symbol) - #define NAN_PAYLOAD_LIMIT (1LL << 51LL) /* 53 is probably ok, (nan (- (ash 1 53) 1)): +nan.9007199254740991 -- 52 bits available? */ - s7_pointer x; - if (is_null(args)) return(real_NaN); - x = car(args); - if (!is_t_integer(x)) - sole_arg_wrong_type_error_nr(sc, sc->nan_symbol, x, sc->type_names[T_INTEGER]); - if (integer(x) < 0) - sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, x), it_is_negative_string); - if (integer(x) >= NAN_PAYLOAD_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, x), it_is_too_large_string); - return(make_nan_with_payload(sc, integer(x))); -} - -static s7_int nan_payload(double x) -{ - decode_float_t num; - num.fx = x; - return(num.ix & 0xffffffffffff); -} - -static s7_pointer g_nan_payload(s7_scheme *sc, s7_pointer args) -{ - #define H_nan_payload "(nan-payload x) returns the payload associated with the NaN x" - #define Q_nan_payload s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - s7_pointer x = car(args); - if ((!is_t_real(x)) || (!is_NaN(real(x)))) /* for complex case, use real-part etc (see s7test.scm) */ - sole_arg_wrong_type_error_nr(sc, sc->nan_payload_symbol, x, wrap_string(sc, "a NaN", 5)); - return(make_integer(sc, nan_payload(real(x)))); -} - -/* no similar support for +inf.0 because inf is just a single bit pattern in ieee754 */ - - -/* -------- gmp stuff -------- */ -#if WITH_GMP -static mp_prec_t mpc_precision = DEFAULT_BIGNUM_PRECISION; -static mp_prec_t mpc_set_default_precision(mp_prec_t prec) {mpc_precision = prec; return(prec);} -#define mpc_init(Z) mpc_init2(Z, mpc_precision) - -static bigint *alloc_bigint(s7_scheme *sc) -{ - bigint *p; - if (sc->bigints) - { - p = sc->bigints; - sc->bigints = p->nxt; - } - else - { - p = (bigint *)Malloc(sizeof(bigint)); - /* not permalloc here: gmp must be playing tricky games with realloc or something. permalloc can lead - * to mpz_set_si overwriting adjacent memory (valgrind does not catch this), clobbering at least the - * bigint nxt field. Someday I need to look at the source. - */ - mpz_init(p->n); - } - return(p); -} - -static bigrat *alloc_bigrat(s7_scheme *sc) -{ - bigrat *p; - if (sc->bigrats) - { - p = sc->bigrats; - sc->bigrats = p->nxt; - } - else - { - p = (bigrat *)Malloc(sizeof(bigrat)); - mpq_init(p->q); - } - return(p); -} - -static bigflt *alloc_bigflt(s7_scheme *sc) -{ - bigflt *p; - if (sc->bigflts) - { - p = sc->bigflts; - sc->bigflts = p->nxt; - mpfr_set_prec(p->x, sc->bignum_precision); - } - else - { - p = (bigflt *)Malloc(sizeof(bigflt)); - mpfr_init2(p->x, sc->bignum_precision); - } - return(p); -} - -static bigcmp *alloc_bigcmp(s7_scheme *sc) -{ - bigcmp *p; - if (sc->bigcmps) - { - p = sc->bigcmps; - sc->bigcmps = p->nxt; - mpc_set_prec(p->z, sc->bignum_precision); - } - else - { - p = (bigcmp *)Malloc(sizeof(bigcmp)); - mpc_init(p->z); - } - return(p); -} - -static s7_pointer mpz_to_big_integer(s7_scheme *sc, mpz_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_INTEGER); - big_integer_bgi(x) = alloc_bigint(sc); - mpz_set(big_integer(x), val); - add_big_integer(sc, x); - return(x); -} - -static s7_pointer mpz_to_integer(s7_scheme *sc, mpz_t val) -{ - if (mpz_fits_slong_p(val)) - return(make_integer(sc, mpz_get_si(val))); - return(mpz_to_big_integer(sc, val)); -} - -#if (!WITH_PURE_S7) -static s7_pointer mpz_to_big_real(s7_scheme *sc, mpz_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_z(big_real(x), val, MPFR_RNDN); - return(x); -} -#endif - -static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set(big_ratio(x), val); - return(x); -} - -static s7_pointer mpq_to_rational(s7_scheme *sc, mpq_t val) -{ - if (mpz_cmp_ui(mpq_denref(val), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(val))); -#if S7_DEBUGGING - mpq_canonicalize(val); - if (mpz_cmp_ui(mpq_denref(val), 1) == 0) - { - fprintf(stderr, "mpq_to_rational: missing canonicalize\n"); - return(mpz_to_integer(sc, mpq_numref(val))); - } -#endif - if ((mpz_fits_slong_p(mpq_numref(val))) && (mpz_fits_slong_p(mpq_denref(val)))) - return(make_simple_ratio(sc, mpz_get_si(mpq_numref(val)), mpz_get_si(mpq_denref(val)))); - return(mpq_to_big_ratio(sc, val)); -} - -static s7_pointer mpq_to_canonicalized_rational(s7_scheme *sc, mpq_t mpq) -{ - mpq_canonicalize(mpq); - return(mpq_to_rational(sc, mpq)); -} - -static s7_pointer mpz_to_rational(s7_scheme *sc, mpz_t n, mpz_t d) /* mpz_3 and mpz_4 */ -{ - if (mpz_cmp_ui(d, 1) == 0) - return(mpz_to_integer(sc, n)); - mpq_set_num(sc->mpq_1, n); - mpq_set_den(sc->mpq_1, d); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); -} - -#if (!WITH_PURE_S7) -static s7_pointer mpq_to_big_real(s7_scheme *sc, mpq_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_q(big_real(x), val, MPFR_RNDN); - return(x); -} -#endif - -static s7_pointer any_rational_to_mpq(s7_scheme *sc, s7_pointer z, mpq_t bigq) -{ - switch (type(z)) - { - case T_INTEGER: mpq_set_si(bigq, integer(z), 1); break; - case T_BIG_INTEGER: mpq_set_z(bigq, big_integer(z)); break; - case T_RATIO: mpq_set_si(bigq, numerator(z), denominator(z)); break; - case T_BIG_RATIO: mpq_set(bigq, big_ratio(z)); break; - } - return(z); -} - -static s7_pointer mpfr_to_integer(s7_scheme *sc, mpfr_t val) -{ - mpfr_get_z(sc->mpz_4, val, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_4)); -} - -static s7_pointer mpfr_to_big_real(s7_scheme *sc, mpfr_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - add_big_real(sc, x); - big_real_bgf(x) = alloc_bigflt(sc); - mpfr_set(big_real(x), val, MPFR_RNDN); - return(x); -} - -static s7_pointer mpc_to_number(s7_scheme *sc, mpc_t val) -{ - s7_pointer x; - if (mpfr_zero_p(mpc_imagref(val))) - return(mpfr_to_big_real(sc, mpc_realref(val))); - new_cell(sc, x, T_BIG_COMPLEX); - big_complex_bgc(x) = alloc_bigcmp(sc); - add_big_complex(sc, x); - mpc_set(big_complex(x), val, MPC_RNDNN); - return(x); -} - -/* s7.h */ -mpz_t *s7_big_integer(s7_pointer x) {return(&big_integer(x));} -mpq_t *s7_big_ratio(s7_pointer x) {return(&big_ratio(x));} -mpfr_t *s7_big_real(s7_pointer x) {return(&big_real(x));} -mpc_t *s7_big_complex(s7_pointer x) {return(&big_complex(x));} - -bool s7_is_big_integer(s7_pointer x) {return(is_t_big_integer(x));} -bool s7_is_big_ratio(s7_pointer x) {return(is_t_big_ratio(x));} -bool s7_is_big_real(s7_pointer x) {return(is_t_big_real(x));} -bool s7_is_big_complex(s7_pointer x) {return(is_t_big_complex(x));} - -s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val) {return(mpz_to_integer(sc, *val));} -s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val) {return(mpq_to_rational(sc, *val));} -s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val) {return(mpfr_to_big_real(sc, *val));} -s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val) {return(mpc_to_number(sc, *val));} - -#if (!WITH_PURE_S7) -static s7_pointer big_integer_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpz_to_big_real(sc, big_integer(x)));} -static s7_pointer big_ratio_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpq_to_big_real(sc, big_ratio(x)));} -#endif - -static s7_pointer s7_int_to_big_integer(s7_scheme *sc, s7_int val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_INTEGER); - big_integer_bgi(x) = alloc_bigint(sc); - mpz_set_si(big_integer(x), val); - add_big_integer(sc, x); - return(x); -} - -static s7_pointer s7_int_to_big_ratio(s7_scheme *sc, s7_int num, s7_int den) -{ - /* (called only in g_bignum), den here always comes from denominator(x) or some positive constant so it is not negative */ - s7_pointer x; - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set_si(big_ratio(x), num, den); - return(x); -} - -static s7_pointer s7_double_to_big_real(s7_scheme *sc, s7_double rl) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_d(big_real(x), rl, MPFR_RNDN); - return(x); -} - -static s7_pointer s7_double_to_big_complex(s7_scheme *sc, s7_double rl, s7_double im) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_COMPLEX); - add_big_complex(sc, x); - big_complex_bgc(x) = alloc_bigcmp(sc); - mpc_set_d_d(big_complex(x), rl, im, MPC_RNDNN); - return(x); -} - -static s7_pointer big_pi(s7_scheme *sc) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL | T_IMMUTABLE); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_const_pi(big_real(x), MPFR_RNDN); - return(x); -} - -static bool is_integer_via_method(s7_scheme *sc, s7_pointer p) -{ - if (s7_is_integer(p)) - return(true); - if (has_active_methods(sc, p)) - { - s7_pointer f = find_method_with_let(sc, p, sc->is_integer_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -#if (!WITH_PURE_S7) -static s7_pointer s7_number_to_big_real(s7_scheme *sc, s7_pointer p) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - - switch (type(p)) - { - case T_INTEGER: - mpfr_set_si(big_real(x), integer(p), MPFR_RNDN); - break; - case T_RATIO: - /* here we can't use fraction(number(p)) even though that uses long_double division because - * there are lots of int64_t ratios that will still look the same. - * We have to do the actual bignum divide by hand. - */ - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpfr_set_q(big_real(x), sc->mpq_1, MPFR_RNDN); - break; - default: - mpfr_set_d(big_real(x), s7_real(p), MPFR_RNDN); - break; - } - return(x); -} -#endif - -static s7_pointer s7_number_to_big_complex(s7_scheme *sc, s7_pointer p) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_COMPLEX); - big_complex_bgc(x) = alloc_bigcmp(sc); - add_big_complex(sc, x); - - switch (type(p)) - { - case T_INTEGER: - mpc_set_si(big_complex(x), integer(p), MPC_RNDNN); - break; - case T_RATIO: - /* can't use fraction here */ - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpc_set_fr(big_complex(x), sc->mpfr_1, MPC_RNDNN); - break; - case T_REAL: - mpc_set_d(big_complex(x), s7_real(p), MPC_RNDNN); - break; - default: - mpc_set_d_d(big_complex(x), real_part(p), imag_part(p), MPC_RNDNN); - break; - } - return(x); -} - -static s7_pointer any_real_to_mpfr(s7_scheme *sc, s7_pointer p, mpfr_t bigx) -{ - switch (type(p)) - { - case T_INTEGER: - mpfr_set_si(bigx, integer(p), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpfr_set_q(bigx, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - mpfr_set_d(bigx, real(p), MPFR_RNDN); - if (is_NaN(real(p))) return(real_NaN); - if (is_inf(real(p))) return(real_infinity); - break; - case T_BIG_INTEGER: - mpfr_set_z(bigx, big_integer(p), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(bigx, big_ratio(p), MPFR_RNDN); - break; - case T_BIG_REAL: - mpfr_set(bigx, big_real(p), MPFR_RNDN); - if (mpfr_nan_p(big_real(p))) return(real_NaN); - if (mpfr_inf_p(big_real(p))) return(real_infinity); - break; - } - return(NULL); -} - -#define mpc_zero_p(z) ((mpfr_zero_p(mpc_realref(z))) && (mpfr_zero_p(mpc_imagref(z)))) - -static s7_pointer any_number_to_mpc(s7_scheme *sc, s7_pointer p, mpc_t bigz) -{ - switch (type(p)) - { - case T_INTEGER: - mpc_set_si(bigz, integer(p), MPC_RNDNN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpc_set_q(bigz, sc->mpq_1, MPC_RNDNN); - break; - case T_REAL: - if (is_NaN(real(p))) return(real_NaN); - if (is_inf(real(p))) return(real_infinity); - mpc_set_d(bigz, real(p), MPC_RNDNN); - break; - case T_COMPLEX: - if (is_NaN(imag_part(p))) return(complex_NaN); - if (is_NaN(real_part(p))) return(real_NaN); - mpc_set_d_d(bigz, real_part(p), imag_part(p), MPC_RNDNN); - break; - case T_BIG_INTEGER: - mpc_set_z(bigz, big_integer(p), MPC_RNDNN); - break; - case T_BIG_RATIO: - mpc_set_q(bigz, big_ratio(p), MPC_RNDNN); - break; - case T_BIG_REAL: - mpc_set_fr(bigz, big_real(p), MPC_RNDNN); - if (mpfr_nan_p(big_real(p))) return(real_NaN); - if (mpfr_inf_p(big_real(p))) return(real_infinity); - break; - case T_BIG_COMPLEX: - if (mpfr_nan_p(mpc_imagref(big_complex(p)))) return(complex_NaN); - if (mpfr_nan_p(mpc_realref(big_complex(p)))) return(real_NaN); - mpc_set(bigz, big_complex(p), MPC_RNDNN); - break; - } - return(NULL); -} - -static s7_pointer make_big_complex(s7_scheme *sc, mpfr_t rl, mpfr_t im) -{ - /* there is no mpc_get_str equivalent, so we need to split up str, use make_big_real to get the 2 halves, then mpc_init, then mpc_set_fr_fr */ - s7_pointer x; - new_cell(sc, x, T_BIG_COMPLEX); - big_complex_bgc(x) = alloc_bigcmp(sc); - add_big_complex(sc, x); - mpc_set_fr_fr(big_complex(x), rl ,im, MPC_RNDNN); - return(x); -} - -static block_t *mpfr_to_string(s7_scheme *sc, mpfr_t val, int32_t radix) -{ - char *str; - mp_exp_t expptr; - int32_t ep; - s7_int i, len; - block_t *b, *btmp; - - if (mpfr_zero_p(val)) - return(string_to_block(sc, "0.0", 3)); - if (mpfr_nan_p(val)) - return(string_to_block(sc, "+nan.0", 6)); - if (mpfr_inf_p(val)) - return((mpfr_signbit(val) == 0) ? string_to_block(sc, "+inf.0", 6) : string_to_block(sc, "-inf.0", 6)); - - b = callocate(sc, sc->bignum_precision + 32); - str = mpfr_get_str((char *)block_data(b), &expptr, radix, 0, val, MPFR_RNDN); - ep = (int32_t)expptr; - len = safe_strlen(str); - - /* remove trailing 0's */ - for (i = len - 1; i > 3; i--) - if (str[i] != '0') - break; - if (i < len - 1) - str[i + 1] = '\0'; - - btmp = mallocate(sc, len + 64); - if (str[0] == '-') - snprintf((char *)block_data(btmp), len + 64, "-%c.%s%c%d", str[1], (char *)(str + 2), (radix <= 10) ? 'E' : '@', ep - 1); - else snprintf((char *)block_data(btmp), len + 64, "%c.%s%c%d", str[0], (char *)(str + 1), (radix <= 10) ? 'E' : '@', ep - 1); - - liberate(sc, b); - return(btmp); -} - -static block_t *mpc_to_string(s7_scheme *sc, mpc_t val, int32_t radix, use_write_t use_write) -{ - block_t *rl, *im, *tmp; - s7_int len; - - mpc_real(sc->mpfr_1, val, MPFR_RNDN); - rl = mpfr_to_string(sc, sc->mpfr_1, radix); - mpc_imag(sc->mpfr_2, val, MPFR_RNDN); - im = mpfr_to_string(sc, sc->mpfr_2, radix); - - len = safe_strlen((char *)block_data(rl)) + safe_strlen((char *)block_data(im)) + 128; - tmp = mallocate(sc, len); - snprintf((char *)block_data(tmp), len, "%s%s%si", - (char *)block_data(rl), - ((((char *)block_data(im))[0] == '-') || (((char *)block_data(im))[0] == '+')) ? "" : "+", (char *)block_data(im)); - - liberate(sc, rl); - liberate(sc, im); - return(tmp); -} - -static block_t *big_number_to_string_with_radix(s7_scheme *sc, s7_pointer p, int32_t radix, s7_int width, s7_int *nlen, use_write_t use_write) -{ - block_t *str; - switch (type(p)) - { - case T_BIG_INTEGER: - str = callocate(sc, mpz_sizeinbase(big_integer(p), radix) + 64); - mpz_get_str((char *)block_data(str), radix, big_integer(p)); - break; - case T_BIG_RATIO: - mpz_set(sc->mpz_1, mpq_numref(big_ratio(p))); - mpz_set(sc->mpz_2, mpq_denref(big_ratio(p))); - str = callocate(sc, mpz_sizeinbase(sc->mpz_1, radix) + mpz_sizeinbase(sc->mpz_2, radix) + 64); - mpq_get_str((char *)block_data(str), radix, big_ratio(p)); - break; - case T_BIG_REAL: - str = mpfr_to_string(sc, big_real(p), radix); - break; - default: - str = mpc_to_string(sc, big_complex(p), radix, use_write); - break; - } - if (width > 0) - { - s7_int len = safe_strlen((char *)block_data(str)); - if (width > len) - { - int32_t spaces = width - len; - block_t *tmp = (block_t *)mallocate(sc, width + 1); - ((char *)block_data(tmp))[width] = '\0'; - memmove((void *)((char *)block_data(tmp) + spaces), (void *)block_data(str), len); - local_memset((void *)block_data(tmp), (int)' ', spaces); - (*nlen) = width; - liberate(sc, str); - return(tmp); - } - (*nlen) = len; - } - else (*nlen) = safe_strlen((char *)block_data(str)); - return(str); -} - -static s7_pointer string_to_big_integer(s7_scheme *sc, const char *str, int32_t radix) -{ - mpz_set_str(sc->mpz_4, (str[0] == '+') ? (const char *)(str + 1) : str, radix); - return(mpz_to_integer(sc, sc->mpz_4)); -} - -static s7_pointer string_to_big_ratio(s7_scheme *sc, const char *str, int32_t radix) -{ - s7_pointer x; - mpq_set_str(sc->mpq_1, str, radix); - mpq_canonicalize(sc->mpq_1); - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set(big_ratio(x), sc->mpq_1); - return(x); -} - -static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int32_t radix) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_str(big_real(x), str, radix, MPFR_RNDN); - return(x); -} - -static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow); - -static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int32_t radix) -{ - bool overflow = false; - s7_int val = string_to_integer(str, radix, &overflow); - if (!overflow) - return(make_integer(sc, val)); - return(string_to_big_integer(sc, str, radix)); -} - -static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const char *dstr, int32_t radix) -{ - bool overflow = false; - /* gmp segfaults if passed a bignum/0 so this needs to check first that the denominator is not 0 before letting gmp screw up. - * Also, if the first character is '+', gmp returns 0! - */ - s7_int d = string_to_integer(dstr, radix, &overflow); - if (!overflow) - { - s7_int n; - if (d == 0) return(real_NaN); - n = string_to_integer(nstr, radix, &overflow); - if (!overflow) - return(make_ratio(sc, n, d)); - } - if (nstr[0] == '+') - return(string_to_big_ratio(sc, (const char *)(nstr + 1), radix)); - return(string_to_big_ratio(sc, nstr, radix)); -} - -static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow); -static s7_pointer string_to_either_real(s7_scheme *sc, const char *str, int32_t radix) -{ - bool overflow = false; - s7_double val = string_to_double_with_radix((char *)str, radix, &overflow); - if (!overflow) return(make_real(sc, val)); - return(string_to_big_real(sc, str, radix)); -} - -static s7_pointer string_to_either_complex_1(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, int32_t radix, s7_double *d_rl) -{ - bool overflow = false; - /* there's a real problem here -- we don't want to promote s7_double .1 to a bignum because - * its low order digits are garbage, causing (rationalize .1 0) to return 3602879701896397/36028797018963968 - * no matter what the bignum-precision. But we can't just fallback on gmp's reader because (for example) - * it reads 1/2+i or 1+0/0i as 1.0. Also format gets screwed up. And string->number signals an error - * where it should return #f. I wonder what to do. - */ - if ((has_dec_point1) || - (ex1)) - { - (*d_rl) = string_to_double_with_radix(q, radix, &overflow); - if (overflow) return(string_to_big_real(sc, q, radix)); - } - else - { - if (slash1) - { - s7_int d, n = string_to_integer(q, radix, &overflow); /* q can include the slash and denominator */ - if (overflow) return(string_to_big_ratio(sc, q, radix)); - d = string_to_integer(slash1, radix, &overflow); - if (overflow) return(string_to_big_ratio(sc, q, radix)); - (*d_rl) = (s7_double)n / (s7_double)d; - } - else - { - s7_int val = string_to_integer(q, radix, &overflow); - if (overflow) return(string_to_big_integer(sc, q, radix)); - (*d_rl) = (s7_double)val; - }} - if ((*d_rl) == -0.0) (*d_rl) = 0.0; - return(NULL); -} - -static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, - char *plus, char *slash2, char *ex2, bool has_dec_point2, - int32_t radix, int32_t has_plus_or_minus) -{ - /* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */ - double d_rl = 0.0, d_im = 0.0; - s7_pointer p_rl = string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, radix, &d_rl); - s7_pointer p_im = string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, radix, &d_im); - - if ((d_im == 0.0) && /* 1.0+0.0000000000000000000000000000i */ - ((!p_im) || (is_zero(p_im)))) - return((p_rl) ? p_rl : make_real(sc, d_rl)); - - if ((!p_rl) && (!p_im)) - return(s7_make_complex(sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im)); - - if (p_rl) - any_real_to_mpfr(sc, p_rl, sc->mpfr_1); - else mpfr_set_d(sc->mpfr_1, d_rl, MPFR_RNDN); - - if (p_im) - any_real_to_mpfr(sc, p_im, sc->mpfr_2); - else mpfr_set_d(sc->mpfr_2, d_im, MPFR_RNDN); - - if (has_plus_or_minus == -1) - mpfr_neg(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - return(make_big_complex(sc, sc->mpfr_1, sc->mpfr_2)); -} - -static bool big_numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* either or both can be big here, but not neither, and types might not match at all */ - switch (type(a)) - { - case T_INTEGER: - return((is_t_big_integer(b)) && (mpz_cmp_si(big_integer(b), integer(a)) == 0)); - case T_BIG_INTEGER: - if (is_t_big_integer(b)) return(mpz_cmp(big_integer(a), big_integer(b)) == 0); - return((is_t_integer(b)) && (mpz_cmp_si(big_integer(a), integer(b)) == 0)); - case T_RATIO: - if (!is_t_big_ratio(b)) return(false); - mpq_set_si(sc->mpq_1, numerator(a), denominator(a)); - return(mpq_equal(sc->mpq_1, big_ratio(b))); - case T_BIG_RATIO: - if (is_t_big_ratio(b)) return(mpq_equal(big_ratio(a), big_ratio(b))); - if (!is_t_ratio(b)) return(false); - mpq_set_si(sc->mpq_1, numerator(b), denominator(b)); - return(mpq_equal(sc->mpq_1, big_ratio(a))); - case T_REAL: - if (is_NaN(real(a))) return(false); - return((is_t_big_real(b)) && (!mpfr_nan_p(big_real(b))) && (mpfr_cmp_d(big_real(b), real(a)) == 0)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(a))) return(false); - if (is_t_big_real(b)) return((!mpfr_nan_p(big_real(b))) && (mpfr_equal_p(big_real(a), big_real(b)))); - return((is_t_real(b)) && (!is_NaN(real(b))) && (mpfr_cmp_d(big_real(a), real(b)) == 0)); - case T_COMPLEX: - if ((is_NaN(real_part(a))) || (is_NaN(imag_part(a)))) return(false); - if (!is_t_big_complex(b)) return(false); - if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(a), imag_part(a), MPC_RNDNN); - return(mpc_cmp(sc->mpc_1, big_complex(b)) == 0); - case T_BIG_COMPLEX: - if ((mpfr_nan_p(mpc_realref(big_complex(a)))) || (mpfr_nan_p(mpc_imagref(big_complex(a))))) - return(false); - if (is_t_big_complex(b)) - { - if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) - return(false); - return(mpc_cmp(big_complex(a), big_complex(b)) == 0); - } - if (is_t_complex(b)) - { - if ((is_NaN(real_part(b))) || (is_NaN(imag_part(b)))) return(false); - mpc_set_d_d(sc->mpc_2, real_part(b), imag_part(b), MPC_RNDNN); - return(mpc_cmp(big_complex(a), sc->mpc_1) == 0); - }} - return(false); -} - -static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n) -{ - if (!mpz_fits_slong_p(n)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "bigint does not fit in s7_int: ~S", 33), mpz_to_big_integer(sc, n))); - return(mpz_get_si(n)); -} -#endif - -#ifndef HAVE_OVERFLOW_CHECKS - #if ((defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || (defined(__GNUC__) && __GNUC__ >= 5)) - #define HAVE_OVERFLOW_CHECKS 1 - #else - #define HAVE_OVERFLOW_CHECKS 0 - #pragma message("no arithmetic overflow checks in this version of s7") - /* these are untested */ - static bool add_overflow(s7_int A, s7_int B, s7_int *C) {*C = A + B; return(false);} /* #define add_overflow(A, B, C) 0 */ - static bool subtract_overflow(s7_int A, s7_int B, s7_int *C) {*C = A - B; return(false);} /* #define subtract_overflow(A, B, C) 0 */ - static bool multiply_overflow(s7_int A, s7_int B, s7_int *C) {*C = A * B; return(false);} /* #define multiply_overflow(A, B, C) 0 */ - #endif -#endif - -#if (defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) - #define subtract_overflow(A, B, C) __builtin_ssubll_overflow((long long)A, (long long)B, (long long *)C) - #define add_overflow(A, B, C) __builtin_saddll_overflow((long long)A, (long long)B, (long long *)C) - #define multiply_overflow(A, B, C) __builtin_smulll_overflow((long long)A, (long long)B, (long long *)C) - #define int32_add_overflow(A, B, C) __builtin_sadd_overflow(A, B, C) - #define int32_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C) -#else -#if (defined(__GNUC__) && __GNUC__ >= 5) - #define subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C) - #define add_overflow(A, B, C) __builtin_add_overflow(A, B, C) - #define multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C) - #define int32_add_overflow(A, B, C) __builtin_add_overflow(A, B, C) - #define int32_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C) -#endif -#endif - -#if WITH_GCC -#define s7_int_abs(x) ({s7_int _X_; _X_ = x; _X_ >= 0 ? _X_ : -_X_;}) -#else -#define s7_int_abs(x) ((x) >= 0 ? (x) : -(x)) -#endif -/* can't use abs even in gcc -- it doesn't work with int64_ts! */ - -#if (!__NetBSD__) - #define s7_fabsl(X) fabsl(X) -#else - static double s7_fabsl(long_double x) {return((signbit(x)) ? -x : x);} -#endif - -/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */ -double s7_round(double number) {return((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5));} - -#if HAVE_COMPLEX_NUMBERS -#if __cplusplus - #define _Complex_I (complex(0.0, 1.0)) - #define creal(x) Real(x) - #define cimag(x) Imag(x) - #define carg(x) arg(x) - #define cabs(x) abs(x) - #define csqrt(x) sqrt(x) - #define cpow(x, y) pow(x, y) - #define clog(x) log(x) - #define cexp(x) exp(x) - #define csin(x) sin(x) - #define ccos(x) cos(x) - #define ctan(x) tan(x) - #define csinh(x) sinh(x) - #define ccosh(x) cosh(x) - #define ctanh(x) tanh(x) - #define casin(x) asin(x) - #define cacos(x) acos(x) - #define catan(x) atan(x) - #define casinh(x) asinh(x) - #define cacosh(x) acosh(x) - #define catanh(x) atanh(x) -#else - typedef double complex s7_complex; -#endif - - -#if (!HAVE_COMPLEX_TRIG) -#if (__cplusplus) - - static s7_complex ctan(s7_complex z) {return(csin(z) / ccos(z));} - static s7_complex ctanh(s7_complex z) {return(csinh(z) / ccosh(z));} - static s7_complex casin(s7_complex z) {return(-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z)));} - static s7_complex cacos(s7_complex z) {return(-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z)));} - static s7_complex catan(s7_complex z) {return(_Complex_I * clog((_Complex_I + z) / (_Complex_I - z)) / 2.0);} - static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} - static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));} - static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} -#else - -#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 12) -static s7_complex clog(s7_complex z) {return(log(fabs(cabs(z))) + carg(z) * _Complex_I);} -static s7_complex cpow(s7_complex x, s7_complex y) -{ - s7_double r = cabs(x); - s7_double theta = carg(x); - s7_double yre = creal(y); - s7_double yim = cimag(y); - s7_double nr = exp(yre * log(r) - yim * theta); - s7_double ntheta = yre * theta + yim * log(r); - return(nr * cos(ntheta) + (nr * sin(ntheta)) * _Complex_I); -} -#endif -#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */ - static s7_complex cexp(s7_complex z) {return(exp(creal(z)) * cos(cimag(z)) + (exp(creal(z)) * sin(cimag(z))) * _Complex_I);} -#endif - -#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 10) - static s7_complex csin(s7_complex z) {return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * _Complex_I);} - static s7_complex ccos(s7_complex z) {return(cos(creal(z)) * cosh(cimag(z)) + (-sin(creal(z)) * sinh(cimag(z))) * _Complex_I);} - static s7_complex csinh(s7_complex z) {return(sinh(creal(z)) * cos(cimag(z)) + (cosh(creal(z)) * sin(cimag(z))) * _Complex_I);} - static s7_complex ccosh(s7_complex z) {return(cosh(creal(z)) * cos(cimag(z)) + (sinh(creal(z)) * sin(cimag(z))) * _Complex_I);} - static s7_complex ctan(s7_complex z) {return(csin(z) / ccos(z));} - static s7_complex ctanh(s7_complex z) {return(csinh(z) / ccosh(z));} - static s7_complex casin(s7_complex z) {return(-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z)));} - static s7_complex cacos(s7_complex z) {return(-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z)));} - static s7_complex catan(s7_complex z) {return(_Complex_I * clog((_Complex_I + z) / (_Complex_I - z)) / 2.0);} - static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} - static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} - static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));} -#endif /* not FreeBSD 10 */ -#endif /* not c++ */ -#endif /* not HAVE_COMPLEX_TRIG */ - -#else /* not HAVE_COMPLEX_NUMBERS */ - typedef double s7_complex; - #define _Complex_I 1 - #define creal(x) x - #define cimag(x) x - #define csin(x) sin(x) - #define casin(x) x - #define ccos(x) cos(x) - #define cacos(x) x - #define ctan(x) x - #define catan(x) x - #define csinh(x) x - #define casinh(x) x - #define ccosh(x) x - #define cacosh(x) x - #define ctanh(x) x - #define catanh(x) x - #define cexp(x) exp(x) - #define cpow(x, y) pow(x, y) - #define clog(x) log(x) - #define csqrt(x) sqrt(x) - #define conj(x) x -#endif - -#ifdef __OpenBSD__ - /* openbsd's builtin versions of these functions are not usable */ - static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} - static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} - static s7_complex cacosh_1(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));} -#endif -#ifdef __NetBSD__ - static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} - static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} -#endif - - -bool s7_is_number(s7_pointer p) {return(is_number(p));} -bool s7_is_complex(s7_pointer p) {return(is_number(p));} -bool s7_is_real(s7_pointer p) {return(is_real(p));} -bool s7_is_rational(s7_pointer p) {return(is_rational(p));} - -bool s7_is_integer(s7_pointer p) -{ -#if WITH_GMP - return((is_t_integer(p)) || (is_t_big_integer(p))); -#else - return(is_t_integer(p)); -#endif -} - -bool s7_is_ratio(s7_pointer p) -{ -#if WITH_GMP - return((is_t_ratio(p)) || (is_t_big_ratio(p))); -#else - return(is_t_ratio(p)); -#endif -} - -static s7_int c_gcd(s7_int u, s7_int v) -{ - s7_int a, b; - if ((u == s7_int_min) || (v == s7_int_min)) - { - /* can't take abs of these (below) so do it by hand */ - s7_int divisor = 1; - if (u == v) return(u); - while (((u & 1) == 0) && ((v & 1) == 0)) - { - u /= 2; - v /= 2; - divisor *= 2; - } - return(divisor); - } - a = s7_int_abs(u); - b = s7_int_abs(v); - /* there are faster gcd algorithms but does it ever matter? */ - while (b != 0) - { - s7_int temp = a % b; - a = b; - b = temp; - } - return(a); -} - -#define RATIONALIZE_LIMIT 1.0e12 - -static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int *denom) -{ - /* from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms" */ - double x0, x1; - s7_int i, p0, q0 = 1, p1, q1 = 1; - double e0, e1, e0p, e1p; - int32_t tries = 0; - /* don't use long_double: the loop below will hang */ - - /* #e1e19 is a killer -- it's bigger than most-positive-fixnum, but if we ceil(ux) below - * it turns into most-negative-fixnum. 1e19 is trouble in many places. - */ - if (fabs(ux) > RATIONALIZE_LIMIT) - { - /* (rationalize most-positive-fixnum) should not return most-negative-fixnum - * but any number > 1e14 here is so inaccurate that rationalize is useless - * for example, - * default: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 1185866354261165/4 - * gmp: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 9223372036854775807/31111 - * can't return false here because that confuses some of the callers! - */ - (*numer) = (s7_int)ux; - (*denom) = 1; - return(true); - } - - if (error < 0.0) error = -error; - x0 = ux - error; - x1 = ux + error; - i = (s7_int)ceil(x0); - - if (error >= 1.0) /* aw good grief! */ - { - if (x0 < 0.0) - (*numer) = (x1 < 0.0) ? (s7_int)floor(x1) : 0; - else (*numer) = i; - (*denom) = 1; - return(true); - } - if (x1 >= i) - { - (*numer) = (i >= 0) ? i : (s7_int)floor(x1); - (*denom) = 1; - return(true); - } - - p0 = (s7_int)floor(x0); - p1 = (s7_int)ceil(x1); - e0 = p1 - x0; - e1 = x0 - p0; - e0p = p1 - x1; - e1p = x1 - p0; - while (true) - { - s7_int old_p1, old_q1; - double old_e0, old_e1, old_e0p, r, r1; - double val = (double)p0 / (double)q0; - - if (((x0 <= val) && (val <= x1)) || (e1 == 0.0) || (e1p == 0.0) || (tries > 100)) - { - if ((q0 == s7_int_min) && (p0 == 1)) /* (rationalize 1.000000004297917e-12) when error is 1e-12 */ - { - (*numer) = 0; - (*denom) = 1; - } - else - { - (*numer) = p0; - (*denom) = q0; - if ((S7_DEBUGGING) && (q0 == 0)) fprintf(stderr, "%f %" ld64 "/0\n", ux, p0); - } - return(true); - } - tries++; - r = (s7_int)floor(e0 / e1); - r1 = (s7_int)ceil(e0p / e1p); - if (r1 < r) r = r1; - /* do handles all step vars in parallel */ - old_p1 = p1; - p1 = p0; - old_q1 = q1; - q1 = q0; - old_e0 = e0; - e0 = e1p; - old_e0p = e0p; - e0p = e1; - old_e1 = e1; - p0 = old_p1 + r * p0; - q0 = old_q1 + r * q0; - e1 = old_e0p - r * e1p; /* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */ - e1p = old_e0 - r * old_e1; - } - return(false); -} - -s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error) -{ - s7_int numer = 0, denom = 1; - if (c_rationalize(x, error, &numer, &denom)) - return(make_ratio(sc, numer, denom)); - return(make_real(sc, x)); -} - -s7_pointer s7_make_integer(s7_scheme *sc, s7_int n) -{ - s7_pointer x; - if (is_small_int(n)) - return(small_int(n)); - new_cell(sc, x, T_INTEGER); - integer(x) = n; - return(x); -} - -static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n) -{ - s7_pointer x; - new_cell(sc, x, T_INTEGER | T_MUTABLE | T_IMMUTABLE); - integer(x) = n; - return(x); -} - -s7_pointer s7_make_real(s7_scheme *sc, s7_double n) -{ - s7_pointer x; - new_cell(sc, x, T_REAL); - set_real(x, n); - return(x); -} - -s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n) -{ - s7_pointer x; - new_cell(sc, x, T_REAL | T_MUTABLE | T_IMMUTABLE); - set_real(x, n); - return(x); -} - -s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b) -{ - s7_pointer x; - if (b == 0.0) - { - new_cell(sc, x, T_REAL); - set_real(x, a); - } - else - { - new_cell(sc, x, T_COMPLEX); - set_real_part(x, a); - set_imag_part(x, b); - } - return(x); -} - -static s7_complex s7_to_c_complex(s7_pointer p) -{ -#if HAVE_COMPLEX_NUMBERS - return(CMPLX(s7_real_part(p), s7_imag_part(p))); -#else - return(0.0); -#endif -} - -static inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_complex(sc, creal(z), cimag(z)));} - -static noreturn void division_by_zero_error_1_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x) -{ - error_nr(sc, sc->division_by_zero_symbol, - set_elist_4(sc, wrap_string(sc, "~A: division by zero, (~A ~S)", 29), caller, caller, x)); -} - -static noreturn void division_by_zero_error_2_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x, s7_pointer y) -{ - error_nr(sc, sc->division_by_zero_symbol, - set_elist_5(sc, wrap_string(sc, "~A: division by zero, (~A ~S ~S)", 32), caller, caller, x, y)); -} - -static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) -{ - s7_pointer x; - if (b == s7_int_min) - { - /* This should not trigger an error during reading -- we might have the - * ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance. - */ - if (a & 1) - return(make_real(sc, (long_double)a / (long_double)b)); - a /= 2; - b /= 2; - } - if (b < 0) - { - a = -a; - b = -b; - } - if (a == s7_int_min) - { - while (((a & 1) == 0) && ((b & 1) == 0)) - { - a /= 2; - b /= 2; - }} - else - { - s7_int b1 = b, divisor = s7_int_abs(a); - do { - s7_int temp = divisor % b1; - divisor = b1; - b1 = temp; - } while (b1 != 0); - if (divisor != 1) - { - a /= divisor; - b /= divisor; - }} - if (b == 1) - return(make_integer(sc, a)); - - new_cell(sc, x, T_RATIO); - numerator(x) = a; - denominator(x) = b; - return(x); -} - -/* using "make-ratio" here is a desperate kludge trying to maintain backwards compatibility; internally we use make_ratio_with_div_check below */ -s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) -{ - if (b == 0) - division_by_zero_error_2_nr(sc, wrap_string(sc, "make-ratio", 10), wrap_integer(sc, a), int_zero); - return(make_ratio(sc, a, b)); -} - -static s7_pointer make_ratio_with_div_check(s7_scheme *sc, s7_pointer caller, s7_int a, s7_int b) -{ - if (b == 0) - division_by_zero_error_2_nr(sc, caller, wrap_integer(sc, a), int_zero); - return(make_ratio(sc, a, b)); -} - - -#define WITH_OVERFLOW_ERROR true -#define WITHOUT_OVERFLOW_ERROR false - -#define INT64_TO_DOUBLE_LIMIT (1LL << 53) -#define DOUBLE_TO_INT64_LIMIT (1LL << 53) - -/* 9007199254740991LL is where a truncated double starts to skip integers (expt 2 53) = ca 1e16 - * (ceiling (+ 1e16 1)) -> 10000000000000000 - * (> 9007199254740993.0 9007199254740992.0) -> #f ; in non-gmp 64-bit doubles - * but we can't fix this except in the gmp case because: - * (integer-decode-float (+ (expt 2.0 62) 100)) -> (4503599627370496 10 1) - * (integer-decode-float (+ (expt 2.0 62) 500)) -> (4503599627370496 10 1) - * (> (+ (expt 2.0 62) 500) (+ (expt 2.0 62) 100)) -> #f ; non-gmp again - * i.e. the bits are identical. We can't even detect when it has happened (without tedious effort), so should - * we just give an error for any floor (or whatever) of an arg>1e16? (sin has a similar problem)? - * I think in the non-gmp case I'll throw an error in these cases because the results are bogus: - * (floor (+ (expt 2.0 62) 512)) -> 4611686018427387904 - * (floor (+ (expt 2.0 62) 513)) -> 4611686018427388928 - * another case at the edge: (round 9007199254740992.51) -> 9007199254740992 - * This spells trouble for normal arithmetic in this range. If no gmp, - * (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0) - * but we don't currently give an error in this case -- not sure what the right thing is. - */ - -s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller) -{ - if (is_t_real(x)) return(real(x)); - switch (type(x)) - { - case T_INTEGER: return((s7_double)integer(x)); - case T_RATIO: return(fraction(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x))); - case T_BIG_RATIO: return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) / - (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); -#endif - default: - sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_REAL]); - } - return(0.0); -} - -s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller) -{ - if (is_t_real(x)) return(real(x)); - switch (type(x)) - { - case T_INTEGER: return((s7_double)integer(x)); - case T_RATIO: return(fraction(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x))); - case T_BIG_RATIO: return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) / - (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); -#endif - default: - sole_arg_wrong_type_error_nr(sc, caller, x, sc->type_names[T_REAL]); - } - return(0.0); -} - -s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x) {return(s7_number_to_real_with_location(sc, x, sc->number_to_real_symbol));} - -s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller) -{ - if (is_t_integer(x)) return(integer(x)); -#if WITH_GMP - if (is_t_big_integer(x)) return(big_integer_to_s7_int(sc, big_integer(x))); -#endif - sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_INTEGER]); - return(0); -} - -s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x) {return(s7_number_to_integer_with_caller(sc, x, "s7_number_to_integer"));} - -s7_int s7_numerator(s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x)); - case T_RATIO: return(numerator(x)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_get_si(big_integer(x))); /* big_integer_to_s7_int but no sc -- no error if out of range */ - case T_BIG_RATIO: return(mpz_get_si(mpq_numref(big_ratio(x)))); -#endif - } - return(0); -} - -s7_int s7_denominator(s7_pointer x) -{ - if (is_t_ratio(x)) return(denominator(x)); -#if WITH_GMP - if (is_t_big_ratio(x)) return(mpz_get_si(mpq_denref(big_ratio(x)))); -#endif - return(1); -} - -s7_int s7_integer(s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p)); -#if WITH_GMP - if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p))); -#endif - return(0); -} - -s7_double s7_real(s7_pointer x) -{ - if (is_t_real(x)) return(real(x)); - switch (type(x)) - { - case T_RATIO: return(fraction(x)); - case T_INTEGER: return((s7_double)integer(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); - case T_BIG_RATIO: - { - s7_double result; - mpfr_t bx; - mpfr_init2(bx, DEFAULT_BIGNUM_PRECISION); - mpfr_set_q(bx, big_ratio(x), MPFR_RNDN); - result = mpfr_get_d(bx, MPFR_RNDN); - mpfr_clear(bx); - return(result); - } -#endif - } - return(0.0); -} - -static bool is_one(s7_pointer x) -{ - return(((is_t_integer(x)) && (integer(x) == 1)) || - ((is_t_real(x)) && (real(x) == 1.0))); -} - - -/* -------- optimize exponents -------- */ - -#define MAX_POW 64 -static double **pepow = NULL; /* [17][MAX_POW * 2]; */ - -static void init_pows(void) -{ - pepow = (double **)Malloc(17 * sizeof(double *)); - pepow[0] = NULL; - pepow[1] = NULL; - for (int32_t i = 2; i < 17; i++) pepow[i] = (double *)Malloc((MAX_POW * 2) * sizeof(double)); - for (int32_t i = 2; i < 17; i++) /* radix between 2 and 16 */ - for (int32_t j = -MAX_POW; j < MAX_POW; j++) /* saved exponent between 0 and +/- MAX_POW */ - pepow[i][j + MAX_POW] = pow((double)i, (double)j); -} - -static inline double dpow(int32_t x, int32_t y) -{ - if ((y >= MAX_POW) || (y < -MAX_POW)) /* this can happen (once in a blue moon) */ - return(pow((double)x, (double)y)); - return(pepow[x][y + MAX_POW]); -} - - -/* -------------------------------- number->string -------------------------------- */ -#define WITH_DTOA 1 -#if WITH_DTOA -/* fpconv, revised to fit the local coding style - - The MIT License - -Copyright (c) 2013 Andreas Samoljuk - -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: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -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. -*/ - -#define dtoa_npowers 87 -#define dtoa_steppowers 8 -#define dtoa_firstpower -348 /* 10 ^ -348 */ -#define dtoa_expmax -32 -#define dtoa_expmin -60 - -typedef struct dtoa_np {uint64_t frac; int32_t exp;} dtoa_np; - -static const dtoa_np dtoa_powers_ten[] = { - { 18054884314459144840U, -1220 }, { 13451937075301367670U, -1193 }, { 10022474136428063862U, -1166 }, { 14934650266808366570U, -1140 }, - { 11127181549972568877U, -1113 }, { 16580792590934885855U, -1087 }, { 12353653155963782858U, -1060 }, { 18408377700990114895U, -1034 }, - { 13715310171984221708U, -1007 }, { 10218702384817765436U, -980 }, { 15227053142812498563U, -954 }, { 11345038669416679861U, -927 }, - { 16905424996341287883U, -901 }, { 12595523146049147757U, -874 }, { 9384396036005875287U, -847 }, { 13983839803942852151U, -821 }, - { 10418772551374772303U, -794 }, { 15525180923007089351U, -768 }, { 11567161174868858868U, -741 }, { 17236413322193710309U, -715 }, - { 12842128665889583758U, -688 }, { 9568131466127621947U, -661 }, { 14257626930069360058U, -635 }, { 10622759856335341974U, -608 }, - { 15829145694278690180U, -582 }, { 11793632577567316726U, -555 }, { 17573882009934360870U, -529 }, { 13093562431584567480U, -502 }, - { 9755464219737475723U, -475 }, { 14536774485912137811U, -449 }, { 10830740992659433045U, -422 }, { 16139061738043178685U, -396 }, - { 12024538023802026127U, -369 }, { 17917957937422433684U, -343 }, { 13349918974505688015U, -316 }, { 9946464728195732843U, -289 }, - { 14821387422376473014U, -263 }, { 11042794154864902060U, -236 }, { 16455045573212060422U, -210 }, { 12259964326927110867U, -183 }, - { 18268770466636286478U, -157 }, { 13611294676837538539U, -130 }, { 10141204801825835212U, -103 }, { 15111572745182864684U, -77 }, - { 11258999068426240000U, -50 }, { 16777216000000000000U, -24 }, { 12500000000000000000U, 3 }, { 9313225746154785156U, 30 }, - { 13877787807814456755U, 56 }, { 10339757656912845936U, 83 }, { 15407439555097886824U, 109 }, { 11479437019748901445U, 136 }, - { 17105694144590052135U, 162 }, { 12744735289059618216U, 189 }, { 9495567745759798747U, 216 }, { 14149498560666738074U, 242 }, - { 10542197943230523224U, 269 }, { 15709099088952724970U, 295 }, { 11704190886730495818U, 322 }, { 17440603504673385349U, 348 }, - { 12994262207056124023U, 375 }, { 9681479787123295682U, 402 }, { 14426529090290212157U, 428 }, { 10748601772107342003U, 455 }, - { 16016664761464807395U, 481 }, { 11933345169920330789U, 508 }, { 17782069995880619868U, 534 }, { 13248674568444952270U, 561 }, - { 9871031767461413346U, 588 }, { 14708983551653345445U, 614 }, { 10959046745042015199U, 641 }, { 16330252207878254650U, 667 }, - { 12166986024289022870U, 694 }, { 18130221999122236476U, 720 }, { 13508068024458167312U, 747 }, { 10064294952495520794U, 774 }, - { 14996968138956309548U, 800 }, { 11173611982879273257U, 827 }, { 16649979327439178909U, 853 }, { 12405201291620119593U, 880 }, - { 9242595204427927429U, 907 }, { 13772540099066387757U, 933 }, { 10261342003245940623U, 960 }, { 15290591125556738113U, 986 }, - { 11392378155556871081U, 1013 }, { 16975966327722178521U, 1039 }, - { 12648080533535911531U, 1066 }}; - -static dtoa_np dtoa_find_cachedpow10(int exp, int* k) -{ - const double one_log_ten = 0.30102999566398114; - int32_t approx = -(exp + dtoa_npowers) * one_log_ten; - int32_t idx = (approx - dtoa_firstpower) / dtoa_steppowers; - while (true) - { - int32_t current = exp + dtoa_powers_ten[idx].exp + 64; - if (current < dtoa_expmin) - { - idx++; - continue; - } - if (current > dtoa_expmax) - { - idx--; - continue; - } - *k = (dtoa_firstpower + idx * dtoa_steppowers); - return(dtoa_powers_ten[idx]); - } -} - -#define dtoa_fracmask 0x000FFFFFFFFFFFFFU -#define dtoa_expmask 0x7FF0000000000000U -#define dtoa_hiddenbit 0x0010000000000000U -#define dtoa_signmask 0x8000000000000000U -#define dtoa_expbias (1023 + 52) -#define dtoa_absv(n) ((n) < 0 ? -(n) : (n)) -#define dtoa_minv(a, b) ((a) < (b) ? (a) : (b)) - -static uint64_t dtoa_tens[] = - { 10000000000000000000U, 1000000000000000000U, 100000000000000000U, - 10000000000000000U, 1000000000000000U, 100000000000000U, - 10000000000000U, 1000000000000U, 100000000000U, - 10000000000U, 1000000000U, 100000000U, - 10000000U, 1000000U, 100000U, - 10000U, 1000U, 100U, - 10U, 1U}; - -static uint64_t dtoa_get_dbits(double d) -{ - union {double dbl; uint64_t i;} dbl_bits = {d}; - return(dbl_bits.i); -} - -static dtoa_np dtoa_build_np(double d) -{ - uint64_t bits = dtoa_get_dbits(d); - dtoa_np fp; - fp.frac = bits & dtoa_fracmask; - fp.exp = (bits & dtoa_expmask) >> 52; - if (fp.exp) - { - fp.frac += dtoa_hiddenbit; - fp.exp -= dtoa_expbias; - } - else fp.exp = -dtoa_expbias + 1; - return(fp); -} - -static void dtoa_normalize(dtoa_np* fp) -{ - int32_t shift = 64 - 52 - 1; - while ((fp->frac & dtoa_hiddenbit) == 0) - { - fp->frac <<= 1; - fp->exp--; - } - fp->frac <<= shift; - fp->exp -= shift; -} - -static void dtoa_get_normalized_boundaries(dtoa_np* fp, dtoa_np* lower, dtoa_np* upper) -{ - int32_t u_shift, l_shift; - upper->frac = (fp->frac << 1) + 1; - upper->exp = fp->exp - 1; - while ((upper->frac & (dtoa_hiddenbit << 1)) == 0) - { - upper->frac <<= 1; - upper->exp--; - } - u_shift = 64 - 52 - 2; - upper->frac <<= u_shift; - upper->exp = upper->exp - u_shift; - l_shift = fp->frac == dtoa_hiddenbit ? 2 : 1; - lower->frac = (fp->frac << l_shift) - 1; - lower->exp = fp->exp - l_shift; - lower->frac <<= lower->exp - upper->exp; - lower->exp = upper->exp; -} - -static dtoa_np dtoa_multiply(dtoa_np* a, dtoa_np* b) -{ - dtoa_np fp; - const uint64_t lomask = 0x00000000FFFFFFFF; - uint64_t ah_bl = (a->frac >> 32) * (b->frac & lomask); - uint64_t al_bh = (a->frac & lomask) * (b->frac >> 32); - uint64_t al_bl = (a->frac & lomask) * (b->frac & lomask); - uint64_t ah_bh = (a->frac >> 32) * (b->frac >> 32); - uint64_t tmp = (ah_bl & lomask) + (al_bh & lomask) + (al_bl >> 32); - /* round up */ - tmp += 1U << 31; - fp.frac = ah_bh + (ah_bl >> 32) + (al_bh >> 32) + (tmp >> 32); - fp.exp = a->exp + b->exp + 64; - return(fp); -} - -static void dtoa_round_digit(char* digits, int32_t ndigits, uint64_t delta, uint64_t rem, uint64_t kappa, uint64_t frac) -{ - while ((rem < frac) && (delta - rem >= kappa) && - ((rem + kappa < frac) || (frac - rem > rem + kappa - frac))) - { - digits[ndigits - 1]--; - rem += kappa; - } -} - -static int32_t dtoa_generate_digits(dtoa_np* fp, dtoa_np* upper, dtoa_np* lower, char* digits, int* K) -{ - uint64_t part1, part2, wfrac = upper->frac - fp->frac, delta = upper->frac - lower->frac; - uint64_t *unit; - int32_t idx = 0, kappa = 10; - dtoa_np one; - - one.frac = 1ULL << -upper->exp; - one.exp = upper->exp; - part1 = upper->frac >> -one.exp; - part2 = upper->frac & (one.frac - 1); - - /* 1000000000 */ - for (uint64_t *divp = dtoa_tens + 10; kappa > 0; divp++) - { - uint64_t tmp, div = *divp; - unsigned digit = part1 / div; - if (digit || idx) - digits[idx++] = digit + '0'; - part1 -= digit * div; - kappa--; - tmp = (part1 << -one.exp) + part2; - if (tmp <= delta) - { - *K += kappa; - dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp, wfrac); - return(idx); - }} - - /* 10 */ - unit = dtoa_tens + 18; - while(true) - { - unsigned digit; - part2 *= 10; - delta *= 10; - kappa--; - digit = part2 >> -one.exp; - if (digit || idx) - digits[idx++] = digit + '0'; - part2 &= one.frac - 1; - if (part2 < delta) - { - *K += kappa; - dtoa_round_digit(digits, idx, delta, part2, one.frac, wfrac * *unit); - return(idx); - } - unit--; - } -} - -static int32_t dtoa_grisu2(double d, char* digits, int* K) -{ - int32_t k; - dtoa_np cp, lower, upper; - dtoa_np w = dtoa_build_np(d); - dtoa_get_normalized_boundaries(&w, &lower, &upper); - dtoa_normalize(&w); - cp = dtoa_find_cachedpow10(upper.exp, &k); - w = dtoa_multiply(&w, &cp); - upper = dtoa_multiply(&upper, &cp); - lower = dtoa_multiply(&lower, &cp); - lower.frac++; - upper.frac--; - *K = -k; - return(dtoa_generate_digits(&w, &upper, &lower, digits, K)); -} - -static int32_t dtoa_emit_digits(char* digits, int32_t ndigits, char* dest, int32_t K, bool neg) -{ - int32_t idx, cent; - char sign; - int32_t exp = dtoa_absv(K + ndigits - 1); - - /* write plain integer */ - if ((K >= 0) && (exp < (ndigits + 7))) - { - memcpy(dest, digits, ndigits); - local_memset(dest + ndigits, '0', K); - dest[ndigits + K] = '.'; - dest[ndigits + K + 1] = '0'; - return(ndigits + K + 2); - } - - /* write decimal w/o scientific notation */ - if ((K < 0) && (K > -7 || exp < 4)) - { - int32_t offset = ndigits - dtoa_absv(K); - /* fp < 1.0 -> write leading zero */ - if (offset <= 0) - { - offset = -offset; - dest[0] = '0'; - dest[1] = '.'; - local_memset(dest + 2, '0', offset); - memcpy(dest + offset + 2, digits, ndigits); - return(ndigits + 2 + offset); - /* fp > 1.0 */ - } - else - { - memcpy(dest, digits, offset); - dest[offset] = '.'; - memcpy(dest + offset + 1, digits + offset, ndigits - offset); - return(ndigits + 1); - }} - - /* write decimal w/ scientific notation */ - ndigits = dtoa_minv(ndigits, 18 - neg); - idx = 0; - dest[idx++] = digits[0]; - if (ndigits > 1) - { - dest[idx++] = '.'; - memcpy(dest + idx, digits + 1, ndigits - 1); - idx += ndigits - 1; - } - dest[idx++] = 'e'; - sign = K + ndigits - 1 < 0 ? '-' : '+'; - dest[idx++] = sign; - cent = 0; - if (exp > 99) - { - cent = exp / 100; - dest[idx++] = cent + '0'; - exp -= cent * 100; - } - if (exp > 9) - { - int32_t dec = exp / 10; - dest[idx++] = dec + '0'; - exp -= dec * 10; - } - else - if (cent) - dest[idx++] = '0'; - - dest[idx++] = exp % 10 + '0'; - return(idx); -} - -static int32_t dtoa_filter_special(double fp, char* dest, bool neg) -{ - uint64_t bits; - bool nan; - if (fp == 0.0) - { - dest[0] = '0'; dest[1] = '.'; dest[2] = '0'; - return(3); - } - bits = dtoa_get_dbits(fp); - nan = (bits & dtoa_expmask) == dtoa_expmask; - if (!nan) return(0); - - if (!neg) - { - dest[0] = '+'; /* else 1.0-nan...? */ - dest++; - } - if (bits & dtoa_fracmask) - { - s7_int payload = nan_payload(fp); - size_t len; - len = snprintf(dest, 22, "nan.%" ld64, payload); - /* dest[0] = 'n'; dest[1] = 'a'; dest[2] = 'n'; dest[3] = '.'; dest[4] = '0'; */ - return((neg) ? len : len + 1); - } - dest[0] = 'i'; dest[1] = 'n'; dest[2] = 'f'; dest[3] = '.'; dest[4] = '0'; - return((neg) ? 5 : 6); -} - -static inline int32_t fpconv_dtoa(double d, char dest[24]) -{ - char digit[23]; - int32_t str_len = 0, spec, K, ndigits; - bool neg = false; - - if (dtoa_get_dbits(d) & dtoa_signmask) - { - dest[0] = '-'; - str_len++; - neg = true; - } - spec = dtoa_filter_special(d, dest + str_len, neg); - if (spec) return(str_len + spec); - K = 0; - ndigits = dtoa_grisu2(d, digit, &K); - str_len += dtoa_emit_digits(digit, ndigits, dest + str_len, K, neg); - return(str_len); -} -#endif - - -/* -------------------------------- number->string -------------------------------- */ -static const char dignum[] = "0123456789abcdef"; - -static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix) /* called by number_to_string_with_radix */ -{ - s7_int i, len, end; - bool sign; - s7_int pown; - - if ((radix < 2) || (radix > 16)) - return(0); - - if (n == S7_INT64_MIN) /* can't negate this, so do it by hand */ - { - static const char *mnfs[17] = {"","", - "-1000000000000000000000000000000000000000000000000000000000000000", "-2021110011022210012102010021220101220222", - "-20000000000000000000000000000000", "-1104332401304422434310311213", "-1540241003031030222122212", - "-22341010611245052052301", "-1000000000000000000000", "-67404283172107811828", "-9223372036854775808", - "-1728002635214590698", "-41a792678515120368", "-10b269549075433c38", "-4340724c6c71dc7a8", "-160e2ad3246366808", "-8000000000000000"}; - - len = safe_strlen(mnfs[radix]); - memcpy((void *)p, (void *)mnfs[radix], len); - p[len] = '\0'; - return(len); - } - - sign = (n < 0); - if (sign) n = -n; - - /* the previous version that counted up to n, rather than dividing down below n, as here, - * could be confused by large ints on 64 bit machines - */ - pown = n; - for (i = 1; i < 100; i++) - { - if (pown < radix) - break; - pown /= (s7_int)radix; - } - len = i - 1; - if (sign) len++; - end = 0; - if (sign) - { - p[0] = '-'; - end++; - } - for (i = len; i >= end; i--) - { - p[i] = dignum[n % radix]; - n /= radix; - } - p[len + 1] = '\0'; - return(len + 1); -} - -static char *integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) /* do not free the returned string */ -{ - char *p, *op; - bool sign; - - if (num == S7_INT64_MIN) - { - (*nlen) = 20; - return((char *)"-9223372036854775808"); - } - p = (char *)(sc->int_to_str1 + INT_TO_STR_SIZE - 1); - op = p; - *p-- = '\0'; - - sign = (num < 0); - if (sign) num = -num; /* we need a positive index below */ - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - if (sign) - { - *p = '-'; - (*nlen) = op - p; - return(p); - } - (*nlen) = op - p - 1; - return(++p); -} - -static char *integer_to_string_no_length(s7_scheme *sc, s7_int num) /* do not free the returned string */ -{ - char *p; - bool sign; - - if (num == S7_INT64_MIN) - return((char *)"-9223372036854775808"); - p = (char *)(sc->int_to_str2 + INT_TO_STR_SIZE - 1); - *p-- = '\0'; - sign = (num < 0); - if (sign) num = -num; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - if (sign) - { - *p = '-'; - return(p); - } - return(++p); -} - -static char *floatify(char *str, s7_int *nlen) -{ - if ((!strchr(str, '.')) && (!strchr(str, 'e'))) /* faster than (strcspn(str, ".e") >= (size_t)(*nlen)) */ - { - s7_int len = *nlen; - /* snprintf returns "nan" and "inf" but we (stupidly) want "+nan.0" and "+inf.0"; "-nan" and "-inf" will be handled by the normal case */ - if (len == 3) - { - if (str[0] == 'n') - { - str[0] = '+'; str[1] = 'n'; str[2] = 'a'; str[3] = 'n'; - len = 4; - } - if (str[0] == 'i') - { - str[0] = '+'; str[1] = 'i'; str[2] = 'n'; str[3] = 'f'; - len = 4; - }} - str[len]='.'; - str[len + 1]='0'; - str[len + 2]='\0'; - (*nlen) = len + 2; - } - return(str); -} - -static void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len) -{ - s7_int spaces = width - len; - if (width >= sc->num_to_str_size) - { - sc->num_to_str_size = width + 1; - sc->num_to_str = (char *)Realloc(sc->num_to_str, sc->num_to_str_size); - } - sc->num_to_str[width] = '\0'; - memmove((void *)(sc->num_to_str + spaces), (void *)src, len); - local_memset((void *)(sc->num_to_str), (int)' ', spaces); -} - -static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int width, s7_int precision, - char float_choice, s7_int *nlen, use_write_t choice) /* don't free result */ -{ - /* called by number_to_string_with_radix g_number_to_string, number_to_string_p_p number_to_port format_number */ - /* the rest of s7 assumes nlen is set to the correct length - * a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small. - * but then even worse: (format #f "~F" 1e308+1e308i)! - */ - s7_int len = width + precision; - len = (len > 512) ? (512 + 2 * len) : 1024; - if (len > sc->num_to_str_size) - { - sc->num_to_str = (sc->num_to_str) ? (char *)Realloc(sc->num_to_str, len) : (char *)Malloc(len); - sc->num_to_str_size = len; - } - - /* bignums can't happen here */ - if (is_t_integer(obj)) - { - char *p; - if (width == 0) - { - if (has_number_name(obj)) - { - (*nlen) = number_name_length(obj); - return((char *)number_name(obj)); - } - return(integer_to_string(sc, integer(obj), nlen)); - } - p = integer_to_string(sc, integer(obj), &len); - if (width > len) - { - insert_spaces(sc, p, width, len); - (*nlen) = width; - return(sc->num_to_str); - } - (*nlen) = len; - return(p); - } - - if (is_t_real(obj)) - { - if (width == 0) - { -#if WITH_DTOA - if ((float_choice == 'g') && - (precision == WRITE_REAL_PRECISION)) - { - /* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001 - * because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug. - */ - len = fpconv_dtoa(real(obj), sc->num_to_str); - sc->num_to_str[len] = '\0'; - (*nlen) = len; - return(sc->num_to_str); - } -#endif - len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, - (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"), - (int32_t)precision, real(obj)); /* -4 for floatify */ - } - else len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, - (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"), - (int32_t)width, (int32_t)precision, real(obj)); /* -4 for floatify */ - (*nlen) = len; - floatify(sc->num_to_str, nlen); - return(sc->num_to_str); - } - - if (is_t_complex(obj)) - { - char *imag; - sc->num_to_str[0] = '\0'; - imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, imag_part(obj)), 0, precision, float_choice, &len, choice)); - - sc->num_to_str[0] = '\0'; - number_to_string_base_10(sc, wrap_real(sc, real_part(obj)), 0, precision, float_choice, &len, choice); - - sc->num_to_str[len] = '\0'; - len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL); - free(imag); - - if (width > len) /* (format #f "~20g" 1+i) */ - { - insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ - (*nlen) = width; - } - else (*nlen) = len; - return(sc->num_to_str); - } - - /* ratio */ - len = catstrs_direct(sc->num_to_str, integer_to_string_no_length(sc, numerator(obj)), "/", pos_int_to_str_direct(sc, denominator(obj)), (const char *)NULL); - if (width > len) - { - insert_spaces(sc, sc->num_to_str, width, len); - (*nlen) = width; - } - else (*nlen) = len; - return(sc->num_to_str); -} - -static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t radix, s7_int width, s7_int precision, char float_choice, s7_int *nlen) -{ - /* called by s7_number_to_string (char*), g_number_to_string (strp), number_to_string_p_pp (strp), format_number (strp basically) */ - /* the rest of s7 assumes nlen is set to the correct length */ - block_t *b; - char *p; - s7_int len, str_len; - -#if WITH_GMP - if (s7_is_bignum(obj)) - return(big_number_to_string_with_radix(sc, obj, radix, width, nlen, P_WRITE)); - /* this ignores precision because it's way too hard to get the mpfr string to look like - * C's output -- we either have to call mpfr_get_str twice (the first time just to - * find out what the exponent is and how long the string actually is), or we have - * to do messy string manipulations. So (format #f "",3F" pi) ignores the "3" and - * prints the full string. And don't even think about mpfr_snprintf! - */ -#endif - if (radix == 10) - { - p = number_to_string_base_10(sc, obj, width, precision, float_choice, nlen, P_WRITE); - return(string_to_block(sc, p, *nlen)); - } - - switch (type(obj)) - { - case T_INTEGER: - { - size_t len1; - b = inline_mallocate(sc, (128 + width)); - p = (char *)block_data(b); - len1 = integer_to_string_any_base(p, integer(obj), radix); - if ((size_t)width > len1) - { - size_t start = width - len1; - memmove((void *)(p + start), (void *)p, len1); - local_memset((void *)p, (int)' ', start); - p[width] = '\0'; - *nlen = width; - } - else *nlen = len1; - return(b); - } - - case T_RATIO: - { - size_t len1, len2; - str_len = 256 + width; - b = inline_mallocate(sc, str_len); - p = (char *)block_data(b); - len1 = integer_to_string_any_base(p, numerator(obj), radix); - p[len1] = '/'; - len2 = integer_to_string_any_base((char *)(p + len1 + 1), denominator(obj), radix); - len = len1 + 1 + len2; - p[len] = '\0'; - } - break; - - case T_REAL: - { - int32_t i; - s7_int int_part, nsize; - s7_double x = real(obj), frac_part, min_frac, base; - bool sign = false; - char n[128], d[256]; - - if (is_NaN(x)) - return(string_to_block(sc, "+nan.0", *nlen = 6)); - if (is_inf(x)) - { - if (x < 0.0) - return(string_to_block(sc, "-inf.0", *nlen = 6)); - return(string_to_block(sc, "+inf.0", *nlen = 6)); - } - if (x < 0.0) - { - sign = true; - x = -x; - } - if (x > 1.0e18) /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */ - { - int32_t ep = (int32_t)floor(log(x) / log((double)radix)); - block_t *b1; - len = 0; - b = number_to_string_with_radix(sc, wrap_real(sc, x / pow((double)radix, (double)ep)), /* divide it down to one digit, then the fractional part */ - radix, width, precision, float_choice, &len); - b1 = inline_mallocate(sc, len + 8); - p = (char *)block_data(b1); - p[0] = '\0'; - (*nlen) = catstrs(p, len + 8, (sign) ? "-" : "", (char *)block_data(b), (radix == 16) ? "@" : "e", integer_to_string_no_length(sc, ep), (char *)NULL); - liberate(sc, b); - return(b1); - } - - int_part = (s7_int)floor(x); - frac_part = x - int_part; - nsize = integer_to_string_any_base(n, int_part, radix); - min_frac = dpow(radix, -precision); - - /* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */ - for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix) - { - s7_int ipart = (s7_int)(frac_part * base); - if (ipart >= radix) /* rounding confusion */ - ipart = radix - 1; - frac_part -= (ipart / base); - /* d[i] = ((const char *)"0123456789abcdef")[ipart]; */ - d[i] = dignum[ipart]; - } - if (i == 0) - d[i++] = '0'; - d[i] = '\0'; - b = inline_mallocate(sc, 256); - p = (char *)block_data(b); - /* much faster than catstrs because we know the string lengths */ - { - char *pt = p; - if (sign) {pt[0] = '-'; pt++;} - memcpy(pt, n, nsize); - pt += nsize; - pt[0] = '.'; - pt++; - memcpy(pt, d, i); - pt[i] = '\0'; - /* len = ((sign) ? 1 : 0) + 1 + nsize + i; */ - len = pt + i - p; - } - str_len = 256; - } - break; - - default: - { - char *pt; - s7_int real_len = 0, imag_len = 0; - block_t *n = number_to_string_with_radix(sc, wrap_real(sc, real_part(obj)), radix, 0, precision, float_choice, &real_len); /* include floatify */ - block_t *d = number_to_string_with_radix(sc, wrap_real(sc, imag_part(obj)), radix, 0, precision, float_choice, &imag_len); - char *dp = (char *)block_data(d); - b = inline_mallocate(sc, 512); - p = (char *)block_data(b); - pt = p; - memcpy(pt, (void *)block_data(n), real_len); - pt += real_len; - if ((dp[0] != '+') && (dp[0] != '-')) {pt[0] = '+'; pt++;} - memcpy(pt, dp, imag_len); - pt[imag_len] = 'i'; - pt[imag_len + 1] = '\0'; - len = pt + imag_len + 1 - p; - str_len = 512; - liberate(sc, n); - liberate(sc, d); - } - break; - } - - if (width > len) - { - s7_int spaces; - if (width >= str_len) - { - str_len = width + 1; - b = reallocate(sc, b, str_len); - p = (char *)block_data(b); - } - spaces = width - len; - p[width] = '\0'; - memmove((void *)(p + spaces), (void *)p, len); - local_memset((void *)p, (int)' ', spaces); - (*nlen) = width; - } - else (*nlen) = len; - return(b); -} - -char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix) -{ - s7_int nlen = 0; - block_t *b = number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen); /* (log top 10) so we get all the digits in base 10 (??) */ - char *str = copy_string_with_length((char *)block_data(b), nlen); - liberate(sc, b); - return(str); -} - -static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_number_to_string "(number->string num (radix 10)) converts the number num into a string." - #define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol) - - s7_int nlen = 0, radix; /* ignore cppcheck complaint about radix! */ - char *res; - s7_pointer x = car(args); - - if (!is_number(x)) - return(method_or_bust(sc, x, sc->number_to_string_symbol, args, a_number_string, 1)); - - if (is_pair(cdr(args))) - { - s7_pointer y = cadr(args); - if (s7_is_integer(y)) - radix = s7_integer_clamped_if_gmp(sc, y); - else return(method_or_bust(sc, y, sc->number_to_string_symbol, args, sc->type_names[T_INTEGER], 2)); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, y, a_valid_radix_string); -#if (WITH_GMP) - if (!s7_is_bignum(x)) -#endif - { - block_t *b = number_to_string_with_radix(sc, x, radix, 0, sc->float_format_precision, 'g', &nlen); - return(block_to_string(sc, b, nlen)); - }} -#if WITH_GMP - else radix = 10; - if (s7_is_bignum(x)) - { - block_t *b = big_number_to_string_with_radix(sc, x, radix, 0, &nlen, P_WRITE); - return(block_to_string(sc, b, nlen)); - } - res = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); -#else - if (is_t_integer(x)) - { - if (has_number_name(x)) - { - nlen = number_name_length(x); - res = (char *)number_name(x); - } - else res = integer_to_string(sc, integer(x), &nlen); - } - else res = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); -#endif - return(inline_make_string_with_length(sc, res, nlen)); -} - -static s7_pointer number_to_string_p_p(s7_scheme *sc, s7_pointer p) -{ -#if WITH_GMP - return(g_number_to_string(sc, set_plist_1(sc, p))); -#else - s7_int nlen = 0; - char *res; - if (!is_number(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->number_to_string_symbol, a_number_string)); - res = number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); - return(inline_make_string_with_length(sc, res, nlen)); -#endif -} - -static s7_pointer number_to_string_p_i(s7_scheme *sc, s7_int p) -{ - s7_int nlen = 0; - char *res = integer_to_string(sc, p, &nlen); - return(inline_make_string_with_length(sc, res, nlen)); -} -/* not number_to_string_p_d! */ - -static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ -#if WITH_GMP - return(g_number_to_string(sc, set_plist_2(sc, p1, p2))); -#else - s7_int nlen = 0, radix; - block_t *b; - - if (!is_number(p1)) - wrong_type_error_nr(sc, sc->number_to_string_symbol, 1, p1, a_number_string); - if (!is_t_integer(p2)) - wrong_type_error_nr(sc, sc->number_to_string_symbol, 2, p2, sc->type_names[T_INTEGER]); - radix = integer(p2); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, p2, a_valid_radix_string); - - b = number_to_string_with_radix(sc, p1, radix, 0, sc->float_format_precision, 'g', &nlen); - return(block_to_string(sc, b, nlen)); -#endif -} - - -/* -------------------------------------------------------------------------------- */ -#define CTABLE_SIZE 256 -static bool *exponent_table, *slashify_table, *char_ok_in_a_name, *white_space, *number_table, *symbol_slashify_table; -static int32_t *digits; - -static void init_ctables(void) -{ - exponent_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - slashify_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - symbol_slashify_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - char_ok_in_a_name = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - white_space = (bool *)Calloc(CTABLE_SIZE + 1, sizeof(bool)); - white_space++; /* leave white_space[-1] false for white_space[EOF] */ - number_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - digits = (int32_t *)Calloc(CTABLE_SIZE, sizeof(int32_t)); - - for (int32_t i = 0; i < CTABLE_SIZE; i++) - { - char_ok_in_a_name[i] = true; - white_space[i] = false; - digits[i] = 256; - number_table[i] = false; - } - - char_ok_in_a_name[0] = false; - char_ok_in_a_name[(uint8_t)'('] = false; /* cast for C++ */ - char_ok_in_a_name[(uint8_t)')'] = false; - char_ok_in_a_name[(uint8_t)';'] = false; - char_ok_in_a_name[(uint8_t)'\t'] = false; - char_ok_in_a_name[(uint8_t)'\n'] = false; - char_ok_in_a_name[(uint8_t)'\r'] = false; - char_ok_in_a_name[(uint8_t)' '] = false; - char_ok_in_a_name[(uint8_t)'"'] = false; - - white_space[(uint8_t)'\t'] = true; - white_space[(uint8_t)'\n'] = true; - white_space[(uint8_t)'\r'] = true; - white_space[(uint8_t)'\f'] = true; - white_space[(uint8_t)'\v'] = true; - white_space[(uint8_t)' '] = true; - white_space[(uint8_t)'\205'] = true; /* 133 */ - white_space[(uint8_t)'\240'] = true; /* 160 */ - - /* surely only 'e' is needed... */ - exponent_table[(uint8_t)'e'] = true; exponent_table[(uint8_t)'E'] = true; - exponent_table[(uint8_t)'@'] = true; -#if WITH_EXTRA_EXPONENT_MARKERS - exponent_table[(uint8_t)'s'] = true; exponent_table[(uint8_t)'S'] = true; - exponent_table[(uint8_t)'f'] = true; exponent_table[(uint8_t)'F'] = true; - exponent_table[(uint8_t)'d'] = true; exponent_table[(uint8_t)'D'] = true; - exponent_table[(uint8_t)'l'] = true; exponent_table[(uint8_t)'L'] = true; -#endif - for (int32_t i = 0; i < 32; i++) slashify_table[i] = true; - for (int32_t i = 127; i < 160; i++) slashify_table[i] = true; - slashify_table[(uint8_t)'\\'] = true; - slashify_table[(uint8_t)'"'] = true; - slashify_table[(uint8_t)'\n'] = false; - - for (int32_t i = 0; i < CTABLE_SIZE; i++) - symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i])); /* force use of (symbol ...) for cases like '(ab) as symbol */ - - digits[(uint8_t)'0'] = 0; digits[(uint8_t)'1'] = 1; digits[(uint8_t)'2'] = 2; digits[(uint8_t)'3'] = 3; digits[(uint8_t)'4'] = 4; - digits[(uint8_t)'5'] = 5; digits[(uint8_t)'6'] = 6; digits[(uint8_t)'7'] = 7; digits[(uint8_t)'8'] = 8; digits[(uint8_t)'9'] = 9; - digits[(uint8_t)'a'] = 10; digits[(uint8_t)'A'] = 10; - digits[(uint8_t)'b'] = 11; digits[(uint8_t)'B'] = 11; - digits[(uint8_t)'c'] = 12; digits[(uint8_t)'C'] = 12; - digits[(uint8_t)'d'] = 13; digits[(uint8_t)'D'] = 13; - digits[(uint8_t)'e'] = 14; digits[(uint8_t)'E'] = 14; - digits[(uint8_t)'f'] = 15; digits[(uint8_t)'F'] = 15; - - number_table[(uint8_t)'0'] = true; number_table[(uint8_t)'1'] = true; number_table[(uint8_t)'2'] = true; number_table[(uint8_t)'3'] = true; - number_table[(uint8_t)'4'] = true; number_table[(uint8_t)'5'] = true; number_table[(uint8_t)'6'] = true; number_table[(uint8_t)'7'] = true; - number_table[(uint8_t)'8'] = true; number_table[(uint8_t)'9'] = true; number_table[(uint8_t)'.'] = true; - number_table[(uint8_t)'+'] = true; - number_table[(uint8_t)'-'] = true; - number_table[(uint8_t)'#'] = true; -} - -#define is_white_space(C) white_space[C] - /* this is much faster than C's isspace, and does not depend on the current locale. - * if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space - */ - -/* -------------------------------- *#readers* -------------------------------- */ -static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name) -{ - s7_pointer value = sc->F, args = sc->F; - bool need_loader_port = is_loader_port(current_input_port(sc)); - - /* *#reader* is assumed to be an alist of (char . proc) - * where each proc takes one argument, the string from just beyond the "#" to the next delimiter. - * The procedure can call read-char to read ahead in the current-input-port. - * If it returns anything other than #f, that is the value of the sharp expression. - * Since #f means "nothing found", it is tricky to handle #F: - * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm - * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later) - */ - if (need_loader_port) - clear_loader_port(current_input_port(sc)); - - /* normally read* can't read from current_input_port(sc) if it is in use by the loader, but here we are deliberately making that possible */ - for (s7_pointer reader = slot_value(sc->sharp_readers); is_not_null(reader); reader = cdr(reader)) - if (name[0] == s7_character(caar(reader))) - { - if (args == sc->F) - args = set_plist_1(sc, s7_make_string_wrapper(sc, name)); - /* args is GC protected by s7_apply_function?? (placed on the stack) */ - value = s7_apply_function(sc, cdar(reader), args); /* this is much less error-safe than s7_call */ - if (value != sc->F) - break; - } - if (need_loader_port) - set_loader_port(current_input_port(sc)); - return(value); -} - -static s7_pointer g_sharp_readers_set(s7_scheme *sc, s7_pointer args) -{ - /* new value must be either () or a proper list of conses (char . func) */ - s7_pointer x; - if (is_null(cadr(args))) return(cadr(args)); - if (!is_pair(cadr(args))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); - for (x = cadr(args); is_pair(x); x = cdr(x)) - if ((!is_pair(car(x))) || - (!is_character(caar(x))) || - (!is_procedure(cdar(x)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); - if (!is_null(x)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); - return(cadr(args)); -} - -static s7_pointer make_undefined(s7_scheme *sc, const char* name) -{ - s7_int len = safe_strlen(name); - char *newstr = (char *)Malloc(len + 2); - s7_pointer p; - new_cell(sc, p, T_UNDEFINED | T_IMMUTABLE); - newstr[0] = '#'; - memcpy((void *)(newstr + 1), (void *)name, len); - newstr[len + 1] = '\0'; - if (sc->undefined_constant_warnings) s7_warn(sc, len + 32, "%s is undefined\n", newstr); - undefined_set_name_length(p, len + 1); - undefined_name(p) = newstr; - add_undefined(sc, p); - return(p); -} - -static int32_t inchar(s7_pointer pt) -{ - int32_t c; - if (is_file_port(pt)) - c = fgetc(port_file(pt)); /* not uint8_t! -- could be EOF */ - else - { - if (port_data_size(pt) <= port_position(pt)) - return(EOF); - c = (uint8_t)port_data(pt)[port_position(pt)++]; - } - if (c == '\n') - port_line_number(pt)++; - return(c); -} - -static void backchar(char c, s7_pointer pt) -{ - if (c == '\n') - port_line_number(pt)--; - - if (is_file_port(pt)) - ungetc(c, port_file(pt)); - else - if (port_position(pt) > 0) - port_position(pt)--; -} - -static void resize_strbuf(s7_scheme *sc, s7_int needed_size) -{ - s7_int old_size = sc->strbuf_size; - while (sc->strbuf_size <= needed_size) sc->strbuf_size *= 2; - sc->strbuf = (char *)Realloc(sc->strbuf, sc->strbuf_size); - for (s7_int i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0'; -} - -static s7_pointer *chars; - -static s7_pointer unknown_sharp_constant(s7_scheme *sc, const char *name, s7_pointer pt) -{ - /* if name[len - 1] != '>' there's no > delimiter at the end */ - - if (hook_has_functions(sc->read_error_hook)) /* check *read-error-hook* */ - { - bool old_history_enabled = s7_set_history_enabled(sc, false); /* see sc->error_hook for a more robust way to handle this */ - s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->T, s7_make_string_wrapper(sc, name))); - s7_set_history_enabled(sc, old_history_enabled); - if (result != sc->unspecified) - return(result); - } - if (pt) /* #<"..."> which gets here as name="#<" */ - { - s7_int len = safe_strlen(name); - if ((name[len - 1] != '>') && - (is_input_port(pt)) && - (pt != sc->standard_input)) - { - if (s7_peek_char(sc, pt) != chars[(uint8_t)'"']) /* if not #<"...">, just return it */ - return(make_undefined(sc, name)); - /* PERHAPS: strchr port-data '>'?? it might be # etc -- what would this break? maybe extend section below */ - - if (is_string_port(pt)) /* probably unnecessary (see below) */ - { - s7_int c = inchar(pt); - const char *pstart = (const char *)(port_data(pt) + port_position(pt)); - const char *p = strchr(pstart, (int)'"'); - s7_int added_len; - char *buf; - s7_pointer res; - - if (!p) - { - backchar(c, pt); - return(make_undefined(sc, name)); - } - p++; - while (char_ok_in_a_name[(uint8_t)(*p)]) {p++;} - added_len = (s7_int)(p - pstart); /* p is one past '>' presumably */ - /* we can't use strbuf here -- it might be the source of the "name" argument! */ - buf = (char *)Malloc(len + added_len + 2); - memcpy((void *)buf, (void *)name, len); - buf[len] = '"'; /* from inchar */ - memcpy((void *)(buf + len + 1), (void *)pstart, added_len); - buf[len + added_len + 1] = 0; - port_position(pt) += added_len; - res = make_undefined(sc, (const char *)buf); - free(buf); - return(res); - }}} - return(make_undefined(sc, name)); -} - -static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error); -#define SYMBOL_OK true -#define NO_SYMBOLS false - -static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer pt, bool error_if_bad_number) -{ - /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */ - if ((!name) || (!*name)) /* (string->number "#") for example */ - return(make_undefined(sc, name)); - - /* stupid r7rs special cases */ - if ((name[0] == 't') && - ((name[1] == '\0') || (c_strings_are_equal(name, "true")))) - return(sc->T); - - if ((name[0] == 'f') && - ((name[1] == '\0') || (c_strings_are_equal(name, "false")))) - return(sc->F); - - if (name[0] == '_') - { - /* this needs to be unsettable via *#readers*: - * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1)))))) - * (let ((+ -)) (#_+ 1 2)): -1 - */ - s7_pointer sym = make_symbol_with_strlen(sc, (char *)(name + 1)); - if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - return(initial_value(sym)); - /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to - * read undefined #_ vals that it will eventually discard. - */ - return(make_undefined(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */ - } - - if (is_not_null(slot_value(sc->sharp_readers))) - { - s7_pointer x = check_sharp_readers(sc, name); - if (x != sc->F) - return(x); - } - - if ((name[0] == '\0') || name[1] == '\0') - return(unknown_sharp_constant(sc, name, pt)); /* pt here because #<"..."> comes here as "<" so name[1] is '\0'! */ - - switch (name[0]) - { - /* -------- #< ... > -------- */ - case '<': - if (c_strings_are_equal(name, "")) return(sc->unspecified); - if (c_strings_are_equal(name, "")) return(sc->undefined); - if (c_strings_are_equal(name, "")) return(eof_object); - return(unknown_sharp_constant(sc, name, pt)); - - /* -------- #o #x #b -------- */ - case 'o': /* #o (octal) */ - case 'x': /* #x (hex) */ - case 'b': /* #b (binary) */ - { - s7_pointer res = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error); - if ((error_if_bad_number) && (res == sc->F)) /* #b32 etc but not if called from string->number */ - { - char buf[256]; - size_t len = snprintf(buf, 256, "#%s is not a number", name); - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, s7_make_string_with_length(sc, buf, len))); /* can't use wrap_string here (buf is local) */ - } - return(res); - } - - /* -------- #\... -------- */ - case '\\': - if (name[2] == 0) /* the most common case: #\a */ - return(chars[(uint8_t)(name[1])]); - /* not uint32_t here! (uint32_t)255 (as a char) returns -1!! */ - switch (name[1]) - { - case 'n': - if ((c_strings_are_equal(name + 1, "null")) || - (c_strings_are_equal(name + 1, "nul"))) - return(chars[0]); - - if (c_strings_are_equal(name + 1, "newline")) - return(chars[(uint8_t)'\n']); - break; - - case 's': if (c_strings_are_equal(name + 1, "space")) return(chars[(uint8_t)' ']); break; - case 'r': if (c_strings_are_equal(name + 1, "return")) return(chars[(uint8_t)'\r']); break; - case 'l': if (c_strings_are_equal(name + 1, "linefeed")) return(chars[(uint8_t)'\n']); break; - case 't': if (c_strings_are_equal(name + 1, "tab")) return(chars[(uint8_t)'\t']); break; - case 'a': if (c_strings_are_equal(name + 1, "alarm")) return(chars[7]); break; - case 'b': if (c_strings_are_equal(name + 1, "backspace")) return(chars[8]); break; - case 'e': if (c_strings_are_equal(name + 1, "escape")) return(chars[0x1b]); break; - case 'd': if (c_strings_are_equal(name + 1, "delete")) return(chars[0x7f]); break; - - case 'x': - /* #\x is just x, but apparently #\x is int->char? #\x65 -> #\e, and #\xcebb is lambda? */ - { - /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3, - * #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level. - * another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught - */ - bool happy = true; - char *tmp = (char *)(name + 2); - int32_t lval = 0; - - while ((*tmp) && (happy) && (lval >= 0) && (lval < 256)) - { - int32_t dig = digits[(int32_t)(*tmp++)]; - if (dig < 16) - lval = dig + (lval * 16); - else happy = false; - } - if ((happy) && - (lval < 256) && - (lval >= 0)) - return(chars[lval]); - } - break; - }} - return(unknown_sharp_constant(sc, name, NULL)); -} - -static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) -{ - bool negative = false; - s7_int lval = 0; - int32_t dig; - char *tmp = (char *)str; -#if WITH_GMP - char *tmp1; -#endif - if (str[0] == '+') - tmp++; - else - if (str[0] == '-') - { - negative = true; - tmp++; - } - while (*tmp == '0') {tmp++;}; -#if WITH_GMP - tmp1 = tmp; -#endif - if (radix == 10) - { - while (true) - { - dig = digits[(uint8_t)(*tmp++)]; - if (dig > 9) break; -#if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(lval, (s7_int)10, &lval)) || - (add_overflow(lval, (s7_int)dig, &lval))) - { - if ((radix == 10) && - (strncmp(str, "-9223372036854775808", 20) == 0) && - (digits[(uint8_t)(*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */ - return(S7_INT64_MIN); - *overflow = true; - return((negative) ? S7_INT64_MIN : S7_INT64_MAX); - } -#else - lval = dig + (lval * 10); - dig = digits[(uint8_t)(*tmp++)]; - if (dig > 9) break; - lval = dig + (lval * 10); -#endif - }} - else - while (true) - { - dig = digits[(uint8_t)(*tmp++)]; - if (dig >= radix) break; -#if HAVE_OVERFLOW_CHECKS && (!WITH_GMP) - { - s7_int oval = 0; - if (multiply_overflow(lval, (s7_int)radix, &oval)) - { - /* maybe a bad idea! #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */ - if ((radix == 16) && - (digits[(uint8_t)(*tmp)] >= radix)) - { - lval -= 576460752303423488LL; /* turn off sign bit */ - lval *= radix; - lval += dig; - lval -= 9223372036854775807LL; - return(lval - 1); - } - lval = oval; /* old case */ - if ((lval == S7_INT64_MIN) && (digits[(uint8_t)(*tmp++)] > 9)) - return(lval); - *overflow = true; - break; - } - else lval = oval; - if (add_overflow(lval, (s7_int)dig, &lval)) - { - if (lval == S7_INT64_MIN) return(lval); - *overflow = true; - break; - }} -#else - lval = dig + (lval * radix); - dig = digits[(uint8_t)(*tmp++)]; - if (dig >= radix) break; - lval = dig + (lval * radix); -#endif - } - -#if WITH_GMP - if (!(*overflow)) - (*overflow) = ((lval > S7_INT32_MAX) || - ((tmp - tmp1) > s7_int_digits_by_radix[radix])); - /* this tells the string->number readers to create a bignum. We need to be very conservative here to catch contexts such as (/ 1/524288 19073486328125) */ -#endif - return((negative) ? -lval : lval); -} - -/* 9223372036854775807 9223372036854775807 - * -9223372036854775808 -9223372036854775808 - * 0000000000000000000000000001.0 1.0 - * 1.0000000000000000000000000000 1.0 - * 1000000000000000000000000000.0e-40 1.0e-12 - * 0.0000000000000000000000000001e40 1.0e12 - * 1.0e00000000000000000001 10.0 - */ - -#if WITH_GMP -static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow) -#else -#define string_to_double_with_radix(Str, Rad, Over) string_to_double_with_radix_1(Str, Rad) -static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix) -#endif -{ - /* strtod follows LANG which is not what we want (only "." is decimal point in Scheme). - * To overcome LANG in strtod would require screwing around with setlocale which never works. - * So we use our own code -- according to valgrind, this function is much faster than strtod. - * comma as decimal point causes ambiguities: `(+ ,1 2) etc - */ - - int32_t i, sign = 1, frac_len, int_len, dig, exponent = 0; - int32_t max_len = s7_int_digits_by_radix[radix]; - int64_t int_part = 0, frac_part = 0; - char *str = (char *)ur_str; - char *ipart, *fpart; - s7_double dval = 0.0; - - /* there's an ambiguity in number notation here if we allow "1e1" or "1.e1" in base 16 (or 15) -- is e a digit or an exponent marker? - * but 1e+1, for example disambiguates it -- kind of messy! -- the scheme spec says "e" can only occur in base 10. - * '@' can now be used as the exponent marker (26-Mar-12). - * Another slight ambiguity: 1+1/2i is parsed as 1 + 0.5i, not 1+1/(2i), or (1+1)/(2i) or (1+1/2)i etc - */ - if (*str == '-') - { - str++; - sign = -1; - } - else - if (*str == '+') - str++; - while (*str == '0') {str++;}; - - ipart = str; - while (digits[(int32_t)(*str)] < radix) str++; - int_len = str - ipart; - - if (*str == '.') str++; - fpart = str; - while (digits[(int32_t)(*str)] < radix) str++; - frac_len = str - fpart; - - if ((*str) && (exponent_table[(uint8_t)(*str)])) - { - bool exp_negative = false; - str++; - if (*str == '+') - str++; - else - if (*str == '-') - { - str++; - exp_negative = true; - } - while ((dig = digits[(int32_t)(*str++)]) < 10) /* exponent itself is always base 10 */ - { -#if HAVE_OVERFLOW_CHECKS - if ((int32_multiply_overflow(exponent, 10, &exponent)) || - (int32_add_overflow(exponent, dig, &exponent))) - { - exponent = 1000000; /* see below */ - break; - } -#else - exponent = dig + (exponent * 10); -#endif - } -#if (!defined(__GNUC__)) || ((__GNUC__ < 5) && (!defined(__clang__))) - if (exponent < 0) /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */ - exponent = 1000000; /* see below for examples -- this number needs to be very big but not too big for add */ -#endif - if (exp_negative) - exponent = -exponent; - - /* 2e12341234123123123123213123123123 -> 0.0 - * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0 - * first zero: 2e123412341231231231231 - * then: 2e12341234123123123123123123 -> inf - * then: 2e123412341231231231231231231231231231 -> 0.0 - * 2e-123412341231231231231 -> inf - * but: 0e123412341231231231231231231231231231 - */ - } - -#if WITH_GMP - /* 9007199254740995.0 */ - if (int_len + frac_len >= max_len) - { - (*overflow) = true; - return(0.0); - } -#endif - str = ipart; - if ((int_len + exponent) > max_len) - { - /* 12341234.56789e12 12341234567889999872.0 1.234123456789e+19 - * -1234567890123456789.0 -1234567890123456768.0 -1.2345678901235e+18 - * 12345678901234567890.0 12345678901234567168.0 1.2345678901235e+19 - * 123.456e30 123456000000000012741097792995328.0 1.23456e+32 - * 12345678901234567890.0e12 12345678901234569054409354903552.0 1.2345678901235e+31 - * 1.234567890123456789012e30 1234567890123456849145940148224.0 1.2345678901235e+30 - * 1e20 100000000000000000000.0 1e+20 - * 1234567890123456789.0 1234567890123456768.0 1.2345678901235e+18 - * 123.456e16 1234560000000000000.0 1.23456e+18 - * 98765432101234567890987654321.0e-5 987654321012345728401408.0 9.8765432101235e+23 - * 98765432101234567890987654321.0e-10 9876543210123456512.0 9.8765432101235e+18 - * 0.00000000000000001234e20 1234.0 - * 0.000000000000000000000000001234e30 1234.0 - * 0.0000000000000000000000000000000000001234e40 1234.0 - * 0.000000000012345678909876543210e15 12345.678909877 - * 0e1000 0.0 - */ - - for (i = 0; i < max_len; i++) - { - dig = digits[(int32_t)(*str++)]; - if (dig < radix) - int_part = dig + (int_part * radix); - else break; - } - - /* if the exponent is huge, check for 0 int_part and frac_part before complaining (0e1000 or 0.0e1000) - */ - if ((int_part == 0) && - (exponent > max_len)) - { - /* if frac_part is also 0, return 0.0 */ - if (frac_len == 0) return(0.0); - str = fpart; - while ((dig = digits[(int32_t)(*str++)]) < radix) - frac_part = dig + (frac_part * radix); - if (frac_part == 0) return(0.0); -#if WITH_GMP - (*overflow) = true; -#endif - } -#if WITH_GMP - (*overflow) = ((int_part > 0) || (exponent > 20)); /* .1e310 is a tricky case */ -#endif - if (int_part != 0) /* 0.<310 zeros here>1e310 for example -- pow (via dpow) thinks it has to be too big, returns Nan, - * then Nan * 0 -> Nan and the NaN propagates - */ - { - if (int_len <= max_len) - dval = int_part * dpow(radix, exponent); - else dval = int_part * dpow(radix, exponent + int_len - max_len); - } - else dval = 0.0; - - /* shift by exponent, but if int_len > max_len then we assumed (see below) int_len - max_len 0's on the left */ - /* using int_to_int or table lookups here instead of pow did not make any difference in speed */ - - if (int_len < max_len) - { - str = fpart; - for (int32_t k = 0; (frac_len > 0) && (k < exponent); k += max_len) - { - int32_t flen = (frac_len > max_len) ? max_len : frac_len; /* ? */ - frac_len -= max_len; - frac_part = 0; - for (i = 0; i < flen; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - if (frac_part != 0) /* same pow->NaN problem as above can occur here */ - dval += frac_part * dpow(radix, exponent - flen - k); - }} - else - /* some of the fraction is in the integer part before the negative exponent shifts it over */ - if (int_len > max_len) - { - int32_t ilen = int_len - max_len; /* we read these above */ - /* str should be at the last digit we read */ - if (ilen > max_len) - ilen = max_len; - for (i = 0; i < ilen; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += frac_part * dpow(radix, exponent - ilen); - } - return(sign * dval); - } - - /* int_len + exponent <= max_len */ - if (int_len <= max_len) - { - int32_t int_exponent = exponent; - /* a better algorithm (since the inaccuracies are in the radix^exponent portion): - * strip off leading zeros and possible sign, - * strip off digits beyond max_len, then remove any trailing zeros. - * (maybe fiddle with the lowest order digit here for rounding, but I doubt it matters) - * read digits until end of number or max_len reached, ignoring the decimal point - * get exponent and use it and decimal point location to position the current result integer - * this always combines the same integer and the same exponent no matter how the number is expressed. - */ - if (int_len > 0) - { - char *iend = (char *)(str + int_len - 1); - while ((*iend == '0') && (iend != str)) {iend--; int_exponent++;} - while (str <= iend) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - } - dval = (int_exponent == 0) ? (s7_double)int_part : int_part * dpow(radix, int_exponent); - } - else - { - int32_t flen, len = int_len + exponent; - int64_t frpart = 0; - - /* 98765432101234567890987654321.0e-20 987654321.012346 - * 98765432101234567890987654321.0e-29 0.98765432101235 - * 98765432101234567890987654321.0e-30 0.098765432101235 - * 98765432101234567890987654321.0e-28 9.8765432101235 - */ - for (i = 0; i < len; i++) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - flen = -exponent; - if (flen > max_len) - flen = max_len; - for (i = 0; i < flen; i++) - frpart = digits[(int32_t)(*str++)] + (frpart * radix); - if (len <= 0) - dval = int_part + frpart * dpow(radix, len - flen); - else dval = int_part + frpart * dpow(radix, -flen); - } - - if (frac_len > 0) - { - str = fpart; - if (frac_len <= max_len) - { - /* splitting out base 10 case saves very little here */ - /* this ignores trailing zeros, so that 0.3 equals 0.300 */ - char *fend = (char *)(str + frac_len - 1); - - while ((*fend == '0') && (fend != str)) {fend--; frac_len--;} /* (= .6 0.6000) */ - if ((frac_len & 1) == 0) - { - while (str <= fend) - { - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - }} - else - while (str <= fend) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - - dval += frac_part * dpow(radix, exponent - frac_len); - - /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 - * 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780 - * 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780 - * (= 0.6 0.60): #f - * (= #i3/5 0.6): #f - * so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky) - * (= 0.6 6e-1): #t ; but not 60e-2 - * to fix the 0.60 case, we need to ignore trailing post-dot zeros. - */ - } - else - { - if (exponent <= 0) - { - for (i = 0; i < max_len; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - - dval += frac_part * dpow(radix, exponent - max_len); - } - else - { - /* 1.0123456789876543210e1 10.12345678987654373771 - * 1.0123456789876543210e10 10123456789.87654304504394531250 - * 0.000000010000000000000000e10 100.0 - * 0.000000010000000000000000000000000000000000000e10 100.0 - * 0.000000012222222222222222222222222222222222222e10 122.22222222222222 - * 0.000000012222222222222222222222222222222222222e17 1222222222.222222 - */ - int_part = 0; - for (i = 0; i < exponent; i++) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - frac_len -= exponent; - if (frac_len > max_len) - frac_len = max_len; - for (i = 0; i < frac_len; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += int_part + frac_part * dpow(radix, -frac_len); - }}} -#if WITH_GMP - if ((int_part == 0) && - (frac_part == 0)) - return(0.0); - (*overflow) = ((frac_len - exponent) > max_len); -#endif - return(sign * dval); -} - -#if (!WITH_GMP) -static s7_pointer make_undefined_bignum(s7_scheme *sc, const char *name) -{ - s7_int len = safe_strlen(name) + 16; - block_t *b = mallocate(sc, len); - char *buf = (char *)block_data(b); - s7_pointer res; - snprintf(buf, len, "", name); - res = make_undefined(sc, (const char *)buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now # */ - liberate(sc, b); - return(res); -} -#endif - -static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, char *p, char *q, int32_t radix, bool want_symbol, int32_t offset) -{ - s7_int len = safe_strlen(p); - if (p[len - 1] == 'i') /* +nan.0[+/-]...i */ - { - if (len == (offset + 2)) /* +nan.0+i */ - return(make_complex_not_0i(sc, x, (p[offset] == '+') ? 1.0 : -1.0)); - if ((len > (offset + 1)) && (len < 1024)) /* make compiler happy */ - { - char *ip = copy_string_with_length((const char *)(p + offset), len - offset - 1); - s7_pointer imag = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - free(ip); - if (is_real(imag)) - return(make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */ - }} - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); -} - -static s7_pointer nan2_or_bust(s7_scheme *sc, s7_double x, char *q, int32_t radix, bool want_symbol, int64_t rl_len) -{ - s7_int len = safe_strlen(q); - /* fprintf(stderr, "\n%s %s %" ld64, __func__, q, len); */ - if ((len > rl_len) && (len < 1024)) /* make compiler happy */ - { - char *ip = copy_string_with_length((const char *)q, rl_len); - s7_pointer rl = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - free(ip); - /* fprintf(stderr, "\nrl: %s\n", display(rl)); */ - if (is_real(rl)) - return(make_complex(sc, real_to_double(sc, rl, __func__), x)); - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); -} - -#if WITH_NUMBER_SEPARATOR -static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix); -static s7_pointer make_symbol_or_number(s7_scheme *sc, const char *name, int32_t radix, bool want_symbol) -{ - block_t *b; - char *new_name; - char sep = sc->number_separator; - s7_int len, i, j; - s7_pointer res; - - if (name[0] == sep) - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - len = safe_strlen(name); - b = mallocate(sc, len + 1); - new_name = (char *)block_data(b); - memcpy((void *)new_name, (void *)name, len); - new_name[len] = 0; - - for (i = 0, j = 0; i < len; i++) - if (name[i] != sep) - { - if ((digits[(uint8_t)(name[i])] < radix) || (!t_number_separator_p[(uint8_t)name[i]])) - new_name[j++] = name[i]; - else - { - liberate(sc, b); - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - }} - else /* sep has to be between two digits */ - if ((digits[(uint8_t)(name[i - 1])] >= radix) || (digits[(uint8_t)(name[i + 1])] >= radix)) - { - liberate(sc, b); - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - } - - new_name[j] = '\0'; - res = string_to_number(sc, new_name, radix); - liberate(sc, b); - return(res); -} -#endif - -static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error) -{ - /* make symbol or number from string, a number starts with + - . or digit, but so does 1+ for example */ -#if WITH_NUMBER_SEPARATOR - #define is_digit(Chr, Rad) ((digits[(uint8_t)Chr] < Rad) || ((Chr == sc->number_separator) && (sc->number_separator != '\0'))) -#else - #define is_digit(Chr, Rad) (digits[(uint8_t)Chr] < Rad) -#endif - char c, *p = q; - bool has_dec_point1 = false; - - c = *p++; - switch (c) - { - case '#': - /* from string->number, (string->number #xc) */ - return(make_sharp_constant(sc, p, with_error, NULL, false)); /* make_sharp_constant expects the '#' to be removed */ - - case '+': - case '-': - c = *p++; - if (c == '.') - { - has_dec_point1 = true; - c = *p++; - } - if (!c) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - if (!is_digit(c, radix)) - { - if (has_dec_point1) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - if (c == 'n') - { - if (local_strcmp(p, "an.0")) /* +nan.0, even if we read -nan.0 -- what's the point of a negative NaN? */ - return(real_NaN); - if ((local_strncmp(p, "an.0", 4)) && /* +nan.0[+/-]...i */ - ((p[4] == '+') || (p[4] == '-'))) - return(nan1_or_bust(sc, NAN, p, q, radix, want_symbol, 4)); - /* read +/-nan. or +/-nan.+/-...i */ - if (local_strncmp(p, "an.", 3)) /* +nan. */ - { - bool overflow = false; - int32_t i; - for (i = 3; is_digit(p[i], 10); i++); - if ((p[i] == '+') || (p[i] == '-')) /* complex case */ - { - int64_t payload = string_to_integer((char *)(p + 3), 10, &overflow); - return(nan1_or_bust(sc, nan_with_payload(payload), p, q, radix, want_symbol, i)); - } - if ((p[i] != '\0') && (!white_space[(uint8_t)(p[i])])) /* check for +nan.0i etc, '\0' is not white_space apparently */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - return(make_nan_with_payload(sc, string_to_integer((char *)(p + 3), 10, &overflow))); - }} - if (c == 'i') - { - if (local_strcmp(p, "nf.0")) /* +inf.0 */ - return((q[0] == '+') ? real_infinity : real_minus_infinity); - if ((local_strncmp(p, "nf.0", 4)) && - ((p[4] == '+') || (p[4] == '-'))) - return(nan1_or_bust(sc, (q[0] == '-') ? -INFINITY : INFINITY, p, q, radix, want_symbol, 4)); - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - } - break; - - case '.': - has_dec_point1 = true; - c = *p++; - if ((!c) || (!is_digit(c, radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - break; - - case 'n': - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - case 'i': - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - case '0': /* these two are always digits */ - case '1': - break; - - default: - if (!is_digit(c, radix)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - break; - } - - /* now it's possibly a number -- the first character(s) could be part of a number in the current radix */ - { - char *slash1 = NULL, *slash2 = NULL, *plus = NULL, *ex1 = NULL, *ex2 = NULL; - bool has_i = false, has_dec_point2 = false; - int32_t has_plus_or_minus = 0, current_radix; -#if (!WITH_GMP) - bool overflow = false; /* for string_to_integer */ -#endif - current_radix = radix; /* current_radix is 10 for the exponent portions, but radix for all the rest */ - - for ( ; (c = *p) != 0; ++p) - { - /* what about embedded null? (string->number (string #\1 (integer->char 0) #\0)) - * currently we stop and return 1, but Guile returns #f. - * this also means we can't use substring_uncopied if (string->number (substring...)) - */ - if (!is_digit(c, current_radix)) /* moving this inside the switch statement was much slower */ - { - current_radix = radix; - - switch (c) - { - /* -------- decimal point -------- */ - case '.': - if ((!is_digit(p[1], current_radix)) && - (!is_digit(p[-1], current_radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - { - if ((has_dec_point1) || (slash1)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - has_dec_point1 = true; - } - else - { - if ((has_dec_point2) || (slash2)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - has_dec_point2 = true; - } - continue; - - /* -------- exponent marker -------- */ -#if WITH_EXTRA_EXPONENT_MARKERS - /* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */ - case 's': case 'S': - case 'd': case 'D': - case 'f': case 'F': - case 'l': case 'L': -#endif - case 'e': case 'E': - if (current_radix > 10) /* see above */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - /* fall through -- if '@' used, radices>10 are ok */ - - case '@': - current_radix = 10; - - if (((ex1) || - (slash1)) && - (has_plus_or_minus == 0)) /* ee */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (((ex2) || - (slash2)) && - (has_plus_or_minus != 0)) /* 1+1.0ee */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if ((!is_digit(p[-1], radix)) && /* was current_radix but that's always 10! */ - (p[-1] != '.')) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - { - ex1 = p; - has_dec_point1 = true; /* decimal point illegal from now on */ - } - else - { - ex2 = p; - has_dec_point2 = true; - } - p++; - if ((*p == '-') || (*p == '+')) p++; - if (is_digit(*p, current_radix)) - continue; - break; - - /* -------- internal + or - -------- */ - case '+': - case '-': - if (has_plus_or_minus != 0) /* already have the separator */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - has_plus_or_minus = (c == '+') ? 1 : -1; - plus = (char *)(p + 1); - /* now check for nan/inf as imaginary part */ - - if ((plus[0] == 'n') && - (local_strncmp(plus, "nan.", 4))) - { - bool overflow = false; - int64_t payload = string_to_integer((char *)(p + 5), 10, &overflow); - /* fprintf(stderr, "\n%s: %s %s %ld %ld\n", __func__, p, q, (intptr_t)(p - q), payload); */ - return(nan2_or_bust(sc, nan_with_payload(payload), q, radix, want_symbol, (intptr_t)(p - q))); - } - if ((plus[0] == 'i') && - (local_strcmp(plus, "inf.0i"))) - return(nan2_or_bust(sc, (c == '+') ? INFINITY : -INFINITY, q, radix, want_symbol, (intptr_t)(p - q))); - continue; - - /* ratio marker */ - case '/': - if ((has_plus_or_minus == 0) && - ((ex1) || - (slash1) || - (has_dec_point1))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if ((has_plus_or_minus != 0) && - ((ex2) || - (slash2) || - (has_dec_point2))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - slash1 = (char *)(p + 1); - else slash2 = (char *)(p + 1); - - if ((!is_digit(p[1], current_radix)) || - (!is_digit(p[-1], current_radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - continue; - - /* -------- i for the imaginary part -------- */ - case 'i': - if ((has_plus_or_minus != 0) && - (!has_i)) - { - has_i = true; - continue; - } - break; - - default: - break; - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - }} - - if ((has_plus_or_minus != 0) && /* that is, we have an internal + or - */ - (!has_i)) /* but no i for the imaginary part */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - -#if WITH_NUMBER_SEPARATOR - if ((sc->number_separator != '\0') && (strchr(q, (int)(sc->number_separator)))) - return(make_symbol_or_number(sc, q, radix, want_symbol)); -#endif - - if (has_i) - { -#if (!WITH_GMP) - s7_double rl = 0.0, im = 0.0; -#else - char e1 = 0, e2 = 0; -#endif - s7_pointer result; - s7_int len = safe_strlen(q); - char ql1, pl1; - - if (q[len - 1] != 'i') - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - /* save original string */ - ql1 = q[len - 1]; - pl1 = (*(plus - 1)); -#if WITH_GMP - if (ex1) {e1 = *ex1; (*ex1) = '@';} /* for mpfr */ - if (ex2) {e2 = *ex2; (*ex2) = '@';} -#endif - /* look for cases like 1+i */ - q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ - - (*((char *)(plus - 1))) = '\0'; - -#if (!WITH_GMP) - if ((has_dec_point1) || - (ex1)) /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */ - rl = string_to_double_with_radix(q, radix, ignored); - else /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */ - { - if (slash1) - { - /* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */ - s7_int den, num = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - den = string_to_integer(slash1, radix, &overflow); - if (den == 0) - rl = NAN; /* real_part if complex */ - else - { - if (num == 0) - { - rl = 0.0; - overflow = false; - } - else - { - if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ - rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */ - }}} - else - { - rl = (s7_double)string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - }} - if (rl == -0.0) rl = 0.0; - - if ((has_dec_point2) || - (ex2)) - im = string_to_double_with_radix(plus, radix, ignored); - else - { - if (slash2) /* complex part I think */ - { - /* same as above: 0-0/100000000000000000000000000000000000000i */ - s7_int den, num = string_to_integer(plus, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - den = string_to_integer(slash2, radix, &overflow); - if (den == 0) - im = NAN; - else - { - if (num == 0) - { - im = 0.0; - overflow = false; - } - else - { - if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ - im = (long_double)num / (long_double)den; - }}} - else - { - im = (s7_double)string_to_integer(plus, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - }} - if ((has_plus_or_minus == -1) && - (im != 0.0)) - im = -im; - result = s7_make_complex(sc, rl, im); -#else - result = string_to_either_complex(sc, q, slash1, ex1, has_dec_point1, plus, slash2, ex2, has_dec_point2, radix, has_plus_or_minus); -#endif - /* restore original string */ - q[len - 1] = ql1; - (*((char *)(plus - 1))) = pl1; -#if WITH_GMP - if (ex1) (*ex1) = e1; - if (ex2) (*ex2) = e2; -#endif - return(result); - } - - /* not complex */ - if ((has_dec_point1) || - (ex1)) - { - s7_pointer result; - if (slash1) /* not complex, so slash and "." is not a number */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - -#if (!WITH_GMP) - result = make_real(sc, string_to_double_with_radix(q, radix, ignored)); -#else - { - char old_e = 0; - if (ex1) - { - old_e = (*ex1); - (*ex1) = '@'; - } - result = string_to_either_real(sc, q, radix); - if (ex1) - (*ex1) = old_e; - } -#endif - return(result); - } - - /* rational */ - if (slash1) -#if (!WITH_GMP) - { - s7_int d, n = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - d = string_to_integer(slash1, radix, &overflow); - - if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ - return(int_zero); - if (d == 0) return(real_NaN); - if (overflow) return(make_undefined_bignum(sc, q)); - /* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000 - * but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every - * big number comes through here, so there's no clean and safe way to check that q == slash1. - */ - return(make_ratio(sc, n, d)); - } -#else - return(string_to_either_ratio(sc, q, slash1, radix)); -#endif - /* integer */ -#if (!WITH_GMP) - { - s7_int x = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - return(make_integer(sc, x)); - } -#else - return(string_to_either_integer(sc, q, radix)); -#endif - } -} - - -/* -------------------------------- string->number -------------------------------- */ -static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix) -{ - s7_pointer x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - return((is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */ -} - -static s7_pointer string_to_number_p_p(s7_scheme *sc, s7_pointer str1) -{ - char *str; - if (!is_string(str1)) - wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]); - str = (char *)string_value(str1); - return(((!str) || (!(*str))) ? sc->F : string_to_number(sc, str, 10)); -} - -static s7_pointer string_to_number_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer radix1) -{ - s7_int radix; - char *str; - if (!is_string(str1)) - wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]); - - if (!is_t_integer(radix1)) - wrong_type_error_nr(sc, sc->string_to_number_symbol, 2, radix1, sc->type_names[T_INTEGER]); - radix = integer(radix1); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->string_to_number_symbol, int_two, radix1, a_valid_radix_string); - - str = (char *)string_value(str1); - if ((!str) || (!(*str))) - return(sc->F); - return(string_to_number(sc, str, radix)); -} - -static s7_pointer g_string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - s7_int radix; - char *str; - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), caller, args, sc->type_names[T_STRING], 1)); - - if (is_pair(cdr(args))) - { - s7_pointer rad = cadr(args); - if (!s7_is_integer(rad)) - return(method_or_bust(sc, rad, caller, args, sc->type_names[T_INTEGER], 2)); - radix = s7_integer_clamped_if_gmp(sc, rad); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, caller, int_two, rad, a_valid_radix_string); - } - else radix = 10; - str = (char *)string_value(car(args)); - if ((!str) || (!(*str))) - return(sc->F); - return(string_to_number(sc, str, radix)); -} - -static s7_pointer g_string_to_number(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_number "(string->number str (radix 10)) converts str into a number. \ -If str does not represent a number, string->number returns #f. If 'str' has an embedded radix, \ -the optional 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3." - #define Q_string_to_number s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \ - sc->is_string_symbol, sc->is_integer_symbol) - return(g_string_to_number_1(sc, args, sc->string_to_number_symbol)); -} - - -/* -------------------------------- abs -------------------------------- */ -static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_integer(x)) - { - if (integer(x) >= 0) return(x); - if (integer(x) > S7_INT64_MIN) return(make_integer(sc, -integer(x))); - } - if (is_t_real(x)) - { - if (is_NaN(real(x))) - return((nan_payload(real(x)) > 0) ? x : real_NaN); /* (abs -nan.0) -> +nan.0?? */ - return((signbit(real(x))) ? make_real(sc, -real(x)) : x); - } -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) >= 0) return(x); -#if WITH_GMP - if (integer(x) == S7_INT64_MIN) - { - x = s7_int_to_big_integer(sc, integer(x)); - mpz_neg(big_integer(x), big_integer(x)); - return(x); - } -#else - if (integer(x) == S7_INT64_MIN) - sole_arg_out_of_range_error_nr(sc, sc->abs_symbol, set_elist_1(sc, x), result_is_too_large_string); -#endif - return(make_integer(sc, -integer(x))); - - case T_RATIO: - if (numerator(x) >= 0) return(x); -#if WITH_GMP && (!POINTER_32) - if (numerator(x) == S7_INT64_MIN) - { - s7_pointer p; - mpz_set_si(sc->mpz_1, S7_INT64_MIN); - mpz_neg(sc->mpz_1, sc->mpz_1); - mpz_set_si(sc->mpz_2, denominator(x)); - new_cell(sc, p, T_BIG_RATIO); - big_ratio_bgr(p) = alloc_bigrat(sc); - add_big_ratio(sc, p); - mpq_set_num(big_ratio(p), sc->mpz_1); - mpq_set_den(big_ratio(p), sc->mpz_2); - return(p); - } -#else - if (numerator(x) == S7_INT64_MIN) - return(make_ratio(sc, S7_INT64_MAX, denominator(x))); -#endif - return(make_simple_ratio(sc, -numerator(x), denominator(x))); - - case T_REAL: - if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */ - return((nan_payload(real(x)) > 0) ? x : real_NaN); - return((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */ -#if WITH_GMP - case T_BIG_INTEGER: - mpz_abs(sc->mpz_1, big_integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_abs(sc->mpq_1, big_ratio(x)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_abs(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - default: - return(method_or_bust_p(sc, x, sc->abs_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_abs(s7_scheme *sc, s7_pointer args) -{ - #define H_abs "(abs x) returns the absolute value of the real number x" - #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) - return(abs_p_p(sc, car(args))); -} - -static s7_double abs_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);} -static s7_int abs_i_i(s7_int x) {return((x < 0) ? (-x) : x);} - - -/* -------------------------------- magnitude -------------------------------- */ -static double my_hypot(double x, double y) -{ - /* according to callgrind, this is much faster than libc's hypot */ - if (x == 0.0) return(fabs(y)); - if (y == 0.0) return(fabs(x)); - if (x == y) return(1.414213562373095 * fabs(x)); - if (is_NaN(x)) return(x); - if (is_NaN(y)) return(y); - return(sqrt(x * x + y * y)); -} - -static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_complex(x)) - return(make_real(sc, my_hypot(real_part(x), imag_part(x)))); /* was reversed? 8-Nov-22 */ - - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == S7_INT64_MIN) return(mostfix); - /* (magnitude -9223372036854775808) -> -9223372036854775808 - * same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808 - */ - return((integer(x) < 0) ? make_integer(sc, -integer(x)) : x); - case T_RATIO: - return((numerator(x) < 0) ? make_simple_ratio(sc, -numerator(x), denominator(x)) : x); - case T_REAL: - if (is_NaN(real(x))) /* (magnitude -nan.0) -> +nan.0, not -nan.0 */ - return((nan_payload(real(x)) > 0) ? x : real_NaN); - return((signbit(real(x))) ? make_real(sc, -real(x)) : x); -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: - case T_BIG_REAL: - return(abs_p_p(sc, x)); - case T_BIG_COMPLEX: - mpc_abs(sc->mpfr_1, big_complex(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->magnitude_symbol, a_number_string)); - } -} - -static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args) -{ - #define H_magnitude "(magnitude z) returns the magnitude of z" - #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - return(magnitude_p_p(sc, car(args))); -} - -static s7_int magnitude_i_i(s7_int x) {return((x < 0) ? (-x) : x);} -static s7_double magnitude_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);} - - -/* -------------------------------- rationalize -------------------------------- */ -#if WITH_GMP - -static rat_locals_t *init_rat_locals_t(s7_scheme *sc) -{ - rat_locals_t *r = (rat_locals_t *)Malloc(sizeof(rat_locals_t)); - sc->ratloc = r; - mpz_inits(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL); - mpq_init(r->q); - mpfr_inits2(sc->bignum_precision, r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL); - return(r); -} - -static void free_rat_locals(s7_scheme *sc) -{ - rat_locals_t *r = sc->ratloc; - mpz_clears(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL); - mpq_clear(r->q); - mpfr_clears(r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL); - free(r); -} - -static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) -{ - /* can return be non-rational? */ - /* currently (rationalize 1/0 1e18) -> 0 - * remember to pad with many trailing zeros: - * (rationalize 0.1 0) -> 3602879701896397/36028797018963968 - * (rationalize 0.1000000000000000 0) -> 1/10 - * perhaps gmp number reader used if gmp -- could this be the trailing zeros problem? (why is the non-gmp case ok?) - * also the bignum function is faking it. - * (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968 - * a confusing case: - * (rationalize 5925563891587147521650777143.74135805596e05) should be 148139097289678688041269428593533951399/250000 - * but that requires more than 128 bits of bignum-precision. - */ - - s7_pointer pp0 = car(args); - rat_locals_t *r = (sc->ratloc) ? sc->ratloc : init_rat_locals_t(sc); - - switch (type(pp0)) - { - case T_INTEGER: - mpfr_set_si(r->ux, integer(pp0), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(pp0), denominator(pp0)); - mpfr_set_q(r->ux, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - if (is_NaN(real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); - if (is_inf(real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); - mpfr_set_d(r->ux, real(pp0), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(r->ux, big_integer(pp0), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(r->ux, big_ratio(pp0), MPFR_RNDN); - break; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); - if (mpfr_inf_p(big_real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); - mpfr_set(r->ux, big_real(pp0), MPFR_RNDN); - break; - case T_COMPLEX: - case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->rationalize_symbol, 1, pp0, sc->type_names[T_REAL]); - default: - return(method_or_bust(sc, pp0, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1)); - } - - if (is_null(cdr(args))) - mpfr_set_d(r->error, sc->default_rationalize_error, MPFR_RNDN); - else - { - s7_pointer pp1 = cadr(args); - switch (type(pp1)) - { - case T_INTEGER: - mpfr_set_si(r->error, integer(pp1), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(pp1), denominator(pp1)); - mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - if (is_NaN(real(pp1))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); - if (is_inf(real(pp1))) - return(int_zero); - mpfr_set_d(r->error, real(pp1), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(r->error, big_integer(pp1), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(r->error, big_ratio(pp1), MPFR_RNDN); - break; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(pp1))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); - if (mpfr_inf_p(big_real(pp1))) - return(int_zero); - mpfr_set(r->error, big_real(pp1), MPFR_RNDN); - break; - case T_COMPLEX: - case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->rationalize_symbol, 2, pp1, sc->type_names[T_REAL]); - default: - return(method_or_bust(sc, pp1, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); - } - mpfr_abs(r->error, r->error, MPFR_RNDN); - } - - mpfr_set(r->x0, r->ux, MPFR_RNDN); /* x0 = ux - error */ - mpfr_sub(r->x0, r->x0, r->error, MPFR_RNDN); - mpfr_set(r->x1, r->ux, MPFR_RNDN); /* x1 = ux + error */ - mpfr_add(r->x1, r->x1, r->error, MPFR_RNDN); - mpfr_get_z(r->i, r->x0, MPFR_RNDU); /* i = ceil(x0) */ - - if (mpfr_cmp_ui(r->error, 1) >= 0) /* if (error >= 1.0) */ - { - if (mpfr_cmp_ui(r->x0, 0) < 0) /* if (x0 < 0) */ - { - if (mpfr_cmp_ui(r->x1, 0) < 0) /* if (x1 < 0) */ - mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* num = floor(x1) */ - else mpz_set_ui(r->n, 0); /* else num = 0 */ - } - else mpz_set(r->n, r->i); /* else num = i */ - return(mpz_to_integer(sc, r->n)); - } - - if (mpfr_cmp_z(r->x1, r->i) >= 0) /* if (x1 >= i) */ - { - if (mpz_cmp_ui(r->i, 0) >= 0) /* if (i >= 0) */ - mpz_set(r->n, r->i); /* num = i */ - else mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* else num = floor(x1) */ - return(mpz_to_integer(sc, r->n)); - } - - mpfr_get_z(r->i0, r->x0, MPFR_RNDD); /* i0 = floor(x0) */ - mpfr_get_z(r->i1, r->x1, MPFR_RNDU); /* i1 = ceil(x1) */ - - mpz_set(r->p0, r->i0); /* p0 = i0 */ - mpz_set_ui(r->q0, 1); /* q0 = 1 */ - mpz_set(r->p1, r->i1); /* p1 = i1 */ - mpz_set_ui(r->q1, 1); /* q1 = 1 */ - mpfr_sub_z(r->e0, r->x0, r->i1, MPFR_RNDN); /* e0 = i1 - x0 */ - mpfr_neg(r->e0, r->e0, MPFR_RNDN); - mpfr_sub_z(r->e1, r->x0, r->i0, MPFR_RNDN); /* e1 = x0 - i0 */ - mpfr_sub_z(r->e0p, r->x1, r->i1, MPFR_RNDN); /* e0p = i1 - x1 */ - mpfr_neg(r->e0p, r->e0p, MPFR_RNDN); - mpfr_sub_z(r->e1p, r->x1, r->i0, MPFR_RNDN); /* e1p = x1 - i0 */ - - while (true) - { - mpfr_set_z(r->val, r->p0, MPFR_RNDN); - mpfr_div_z(r->val, r->val, r->q0, MPFR_RNDN); /* val = p0/q0 */ - - if (((mpfr_lessequal_p(r->x0, r->val)) && /* if ((x0 <= val) && (val <= x1)) */ - (mpfr_lessequal_p(r->val, r->x1))) || - (mpfr_cmp_ui(r->e1, 0) == 0) || - (mpfr_cmp_ui(r->e1p, 0) == 0)) - /* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */ - { - mpq_set_num(r->q, r->p0); /* return(p0/q0) */ - mpq_set_den(r->q, r->q0); - return(mpq_to_rational(sc, r->q)); - } - - mpfr_div(r->val, r->e0, r->e1, MPFR_RNDN); - mpfr_get_z(r->r, r->val, MPFR_RNDD); /* r = floor(e0/e1) */ - mpfr_div(r->val, r->e0p, r->e1p, MPFR_RNDN); - mpfr_get_z(r->r1, r->val, MPFR_RNDU); /* r1 = ceil(e0p/e1p) */ - if (mpz_cmp(r->r1, r->r) < 0) /* if (r1 < r) */ - mpz_set(r->r, r->r1); /* r = r1 */ - - mpz_set(r->old_p1, r->p1); /* old_p1 = p1 */ - mpz_set(r->p1, r->p0); /* p1 = p0 */ - mpz_set(r->old_q1, r->q1); /* old_q1 = q1 */ - mpz_set(r->q1, r->q0); /* q1 = q0 */ - - mpfr_set(r->old_e0, r->e0, MPFR_RNDN); /* old_e0 = e0 */ - mpfr_set(r->e0, r->e1p, MPFR_RNDN); /* e0 = e1p */ - mpfr_set(r->old_e0p, r->e0p, MPFR_RNDN); /* old_e0p = e0p */ - mpfr_set(r->e0p, r->e1, MPFR_RNDN); /* e0p = e1 */ - mpfr_set(r->old_e1, r->e1, MPFR_RNDN); /* old_e1 = e1 */ - - mpz_mul(r->p0, r->p0, r->r); /* p0 = old_p1 + r * p0 */ - mpz_add(r->p0, r->p0, r->old_p1); - - mpz_mul(r->q0, r->q0, r->r); /* q0 = old_q1 + r * q0 */ - mpz_add(r->q0, r->q0, r->old_q1); - - mpfr_mul_z(r->e1, r->e1p, r->r, MPFR_RNDN); /* e1 = old_e0p - r * e1p */ - mpfr_sub(r->e1, r->old_e0p, r->e1, MPFR_RNDN); - - mpfr_mul_z(r->e1p, r->old_e1, r->r, MPFR_RNDN);/* e1p = old_e0 - r * old_e1 */ - mpfr_sub(r->e1p, r->old_e0, r->e1p, MPFR_RNDN); - } -} -#endif - -static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args) -{ - #define H_rationalize "(rationalize x err) returns the ratio with smallest denominator within err of x" - #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol) - /* I can't find a case where this returns a non-rational result */ - - s7_double err; - s7_pointer x = car(args); - -#if WITH_GMP - if (is_big_number(x)) - return(big_rationalize(sc, args)); -#endif - if (!is_real(x)) - return(method_or_bust(sc, x, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1)); - - if (is_null(cdr(args))) - err = sc->default_rationalize_error; - else - { - s7_pointer ex = cadr(args); -#if WITH_GMP - if (is_big_number(ex)) - return(big_rationalize(sc, args)); -#endif - if (!is_real(ex)) - return(method_or_bust(sc, ex, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); - err = real_to_double(sc, ex, "rationalize"); - if (is_NaN(err)) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, cadr(args), it_is_nan_string); - if (err < 0.0) err = -err; - } - - switch (type(x)) - { - case T_INTEGER: - { - s7_int a, b, pa; - if (err < 1.0) return(x); - a = integer(x); - pa = (a < 0) ? -a : a; - if (err >= pa) return(int_zero); - b = (s7_int)err; - pa -= b; - return(make_integer(sc, (a < 0) ? -pa : pa)); - } - - case T_RATIO: - if (err == 0.0) - return(x); - - case T_REAL: - { - s7_double rat = s7_real(x); /* possible fall through from above */ - s7_int numer = 0, denom = 1; - - if ((is_NaN(rat)) || (is_inf(rat))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, a_normal_real_string); - - if (err >= fabs(rat)) - return(int_zero); - -#if WITH_GMP - if (fabs(rat) > RATIONALIZE_LIMIT) - return(big_rationalize(sc, set_plist_2(sc, x, wrap_real(sc, err)))); -#else - if (fabs(rat) > RATIONALIZE_LIMIT) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, it_is_too_large_string); -#endif - if ((fabs(rat) + fabs(err)) < 1.0e-18) - err = 1.0e-18; - /* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that, - * (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe. - */ - - if (fabs(rat) < fabs(err)) - return(int_zero); - - return((c_rationalize(rat, err, &numer, &denom)) ? make_ratio(sc, numer, denom) : sc->F); - }} - return(sc->F); /* make compiler happy */ -} - -static s7_int rationalize_i_i(s7_int x) {return(x);} -static s7_pointer rationalize_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));} -static s7_pointer rationalize_p_d(s7_scheme *sc, s7_double x) -{ - if ((is_NaN(x)) || (is_inf(x))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, wrap_real(sc, x), a_normal_real_string); /* was make_real, also below */ - if (fabs(x) > RATIONALIZE_LIMIT) -#if WITH_GMP - return(big_rationalize(sc, set_plist_1(sc, wrap_real(sc, x)))); -#else - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, wrap_real(sc, x), it_is_too_large_string); -#endif - return(s7_rationalize(sc, x, sc->default_rationalize_error)); -} - - -/* -------------------------------- angle -------------------------------- */ -static s7_pointer g_angle(s7_scheme *sc, s7_pointer args) -{ - #define H_angle "(angle z) returns the angle of z" - #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - - s7_pointer x = car(args); /* (angle inf+infi) -> 0.78539816339745 ? I think this should be -pi < ang <= pi */ - switch (type(x)) - { - case T_INTEGER: return((integer(x) < 0) ? real_pi : int_zero); - case T_RATIO: return((numerator(x) < 0) ? real_pi : int_zero); - case T_COMPLEX: return(make_real(sc, atan2(imag_part(x), real_part(x)))); - - case T_REAL: - if (is_NaN(real(x))) return(x); - return((real(x) < 0.0) ? real_pi : real_zero); -#if WITH_GMP - case T_BIG_INTEGER: return((mpz_cmp_ui(big_integer(x), 0) >= 0) ? int_zero : big_pi(sc)); - case T_BIG_RATIO: return((mpq_cmp_ui(big_ratio(x), 0, 1) >= 0) ? int_zero : big_pi(sc)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_d(big_real(x), 0.0) >= 0) ? real_zero : big_pi(sc)); - case T_BIG_COMPLEX: - { - s7_pointer z; - new_cell(sc, z, T_BIG_REAL); - big_real_bgf(z) = alloc_bigflt(sc); - add_big_real(sc, z); - mpc_arg(big_real(z), big_complex(x), MPFR_RNDN); - return(z); - } -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->angle_symbol, a_number_string)); - } -} - - -/* -------------------------------- complex -------------------------------- */ - -static s7_pointer complex_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - if ((is_big_number(x)) || (is_big_number(y))) - { - s7_pointer p0 = x, p1 = y, p = NULL; - - if (!is_real(p0)) - return(method_or_bust(sc, p0, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - if (!is_real(p1)) - return(method_or_bust(sc, p1, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); - - switch (type(p1)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - { - s7_double iz = s7_real(p1); - if (iz == 0.0) /* imag-part is 0.0 */ - return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_d(mpc_imagref(big_complex(p)), iz, MPFR_RNDN); - } - break; - case T_BIG_REAL: - if (mpfr_zero_p(big_real(p1))) return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set(mpc_imagref(big_complex(p)), big_real(p1), MPFR_RNDN); - break; - case T_BIG_RATIO: - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_q(mpc_imagref(big_complex(p)), big_ratio(p1), MPFR_RNDN); - break; - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p1), 0) == 0) return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(p1), MPFR_RNDN); - break; - } - switch (type(p0)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - mpfr_set_d(mpc_realref(big_complex(p)), s7_real(p0), MPFR_RNDN); - break; - case T_BIG_REAL: - mpfr_set(mpc_realref(big_complex(p)), big_real(p0), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(p0), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(mpc_realref(big_complex(p)), big_integer(p0), MPFR_RNDN); - break; - } - add_big_complex(sc, p); - return(p); - } -#endif - switch (type(y)) - { - case T_INTEGER: - switch (type(x)) - { - case T_INTEGER: return((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double)integer(x), (s7_double)integer(y))); - /* these int->dbl's are problematic: - * (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i - * should we raise an error? - */ - case T_RATIO: return((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double)fraction(x), (s7_double)integer(y))); - case T_REAL: return((integer(y) == 0) ? x : s7_make_complex(sc, real(x), (s7_double)integer(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } - case T_RATIO: - switch (type(x)) - { - case T_INTEGER: return(s7_make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); /* can fraction be 0.0? */ - case T_RATIO: return(s7_make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y))); - case T_REAL: return(s7_make_complex(sc, real(x), (s7_double)fraction(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } - case T_REAL: - switch (type(x)) - { - case T_INTEGER: return((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double)integer(x), real(y))); - case T_RATIO: return((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double)fraction(x), real(y))); - case T_REAL: return((real(y) == 0.0) ? x : s7_make_complex(sc, real(x), real(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } - default: - return(method_or_bust(sc, (is_let(x)) ? x : y, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); - } -} - -static s7_pointer g_complex(s7_scheme *sc, s7_pointer args) -{ - #define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2" - #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol) - return(complex_p_pp(sc, car(args), cadr(args))); -} - -static s7_pointer complex_p_ii(s7_scheme *sc, s7_int x, s7_int y) -{ - return((y == 0.0) ? make_integer(sc, x) : make_complex_not_0i(sc, (s7_double)x, (s7_double)y)); -} - -static s7_pointer complex_p_dd(s7_scheme *sc, s7_double x, s7_double y) -{ - return((y == 0.0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y)); -} - - -/* -------------------------------- bignum -------------------------------- */ -static s7_pointer g_bignum(s7_scheme *sc, s7_pointer args) -{ - #define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'. If the argument is a number \ -bignum returns that number as a bignum" -#if WITH_GMP - #define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), sc->is_integer_symbol) -#else - #define Q_bignum s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), \ - sc->is_integer_symbol) -#endif - - s7_pointer p = car(args); - if (is_number(p)) - { - if (!is_null(cdr(args))) - error_nr(sc, make_symbol(sc, "bignum-error", 12), - set_elist_2(sc, wrap_string(sc, "bignum of a number takes only one argument: ~S", 46), args)); -#if WITH_GMP - switch (type(p)) - { - case T_INTEGER: return(s7_int_to_big_integer(sc, integer(p))); - case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(p), denominator(p))); - case T_REAL: return(s7_double_to_big_real(sc, real(p))); - case T_COMPLEX: return(s7_double_to_big_complex(sc, real_part(p), imag_part(p))); - default: return(p); - } -#else - return(p); -#endif - } - p = g_string_to_number_1(sc, args, sc->bignum_symbol); - if (is_false(sc, p)) /* (bignum "1/3.0") */ - error_nr(sc, make_symbol(sc, "bignum-error", 12), - set_elist_2(sc, wrap_string(sc, "bignum string argument does not represent a number: ~S", 54), car(args))); -#if WITH_GMP - switch (type(p)) - { - case T_INTEGER: return(s7_int_to_big_integer(sc, integer(p))); - case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(p), denominator(p))); - case T_COMPLEX: return(s7_number_to_big_complex(sc, p)); - case T_REAL: - if (is_NaN(real(p))) return(p); - return(s7_double_to_big_real(sc, real(p))); - /* 9Sep21: this was return(string_to_big_real(sc, string_value(car(args)), (is_pair(cdr(args))) ? s7_integer_clamped_if_gmp(sc, cadr(args)) : 10)); */ - default: - return(p); - } -#else - return(p); -#endif -} - - -/* -------------------------------- exp -------------------------------- */ -#if (!HAVE_COMPLEX_NUMBERS) - static s7_pointer no_complex_numbers_string; -#endif - -#define EXP_LIMIT 100.0 - -#if WITH_GMP -static s7_pointer exp_1(s7_scheme *sc, s7_double x) -{ - mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); - mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -} - -static s7_pointer exp_2(s7_scheme *sc, s7_double x, s7_double y) -{ - mpc_set_d_d(sc->mpc_1, x, y, MPC_RNDNN); - mpc_exp(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -} -#endif - -static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x) -{ - s7_double z; - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_one); /* (exp 0) -> 1 */ - z = (s7_double)integer(x); -#if WITH_GMP - if (fabs(z) > EXP_LIMIT) - return(exp_1(sc, z)); -#endif - return(make_real(sc, exp(z))); - - case T_RATIO: - z = (s7_double)fraction(x); -#if WITH_GMP - if (fabs(z) > EXP_LIMIT) - return(exp_1(sc, z)); -#endif - return(make_real(sc, exp(z))); - - case T_REAL: -#if WITH_GMP - if (fabs(real(x)) > EXP_LIMIT) - return(exp_1(sc, real(x))); -#endif - return(make_real(sc, exp(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS -#if WITH_GMP - if ((fabs(real_part(x)) > EXP_LIMIT) || - (fabs(imag_part(x)) > EXP_LIMIT)) - return(exp_2(sc, real_part(x), imag_part(x))); -#endif - return(c_complex_to_s7(sc, cexp(to_c_complex(x)))); - /* this is inaccurate for large arguments: - * (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i - */ -#else - out_of_range_error_nr(sc, sc->exp_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_exp(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_exp(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->exp_symbol, a_number_string)); - } -} - -static s7_pointer g_exp(s7_scheme *sc, s7_pointer args) -{ - #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459" - #define Q_exp sc->pl_nn - return(exp_p_p(sc, car(args))); -} - -static s7_double exp_d_d(s7_double x) {return(exp(x));} -static s7_pointer exp_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, exp(x)));} - - -/* -------------------------------- log -------------------------------- */ -#if __cplusplus -#define LOG_2 1.4426950408889634074 -#else -#define LOG_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */ -#endif - -#if WITH_GMP -static s7_pointer big_log(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p0 = car(args), p1 = NULL, res; - - if (!is_number(p0)) - return(method_or_bust(sc, p0, sc->log_symbol, args, a_number_string, 1)); - - if (is_pair(cdr(args))) - { - p1 = cadr(args); - if (!is_number(p1)) - return(method_or_bust(sc, p1, sc->log_symbol, args, a_number_string, 2)); - } - - if (is_real(p0)) - { - res = any_real_to_mpfr(sc, p0, sc->mpfr_1); - if (res == real_NaN) return(res); - if ((is_positive(sc, p0)) && - ((!p1) || - ((is_real(p1)) && (is_positive(sc, p1))))) - { - if (res) return(res); - mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - if (p1) - { - res = any_real_to_mpfr(sc, p1, sc->mpfr_2); - if (res) - return((res == real_infinity) ? real_zero : res); - if (mpfr_zero_p(sc->mpfr_2)) - out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); - mpfr_log(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - } - if ((mpfr_integer_p(sc->mpfr_1)) && ((is_rational(p0)) && ((!p1) || (is_rational(p1))))) - return(mpfr_to_integer(sc, sc->mpfr_1)); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }} - if (p1) - { - res = any_number_to_mpc(sc, p1, sc->mpc_2); - if (res) - return((res == real_infinity) ? real_zero : complex_NaN); - if (mpc_zero_p(sc->mpc_2)) - out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); - } - res = any_number_to_mpc(sc, p0, sc->mpc_1); - if (res) - { - if ((res == real_infinity) && (p1) && ((is_negative(sc, p0)))) - return(make_complex_not_0i(sc, INFINITY, -NAN)); - return((res == real_NaN) ? complex_NaN : res); - } - mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - if (p1) - { - mpc_log(sc->mpc_2, sc->mpc_2, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - } - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -} -#endif - -static s7_pointer g_int_log2(s7_scheme *sc, s7_pointer args) -{ - s7_int ix = integer(car(args)); - s7_double fx = log2((double)ix); - return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); -} - -static s7_pointer g_log(s7_scheme *sc, s7_pointer args) -{ - #define H_log "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3" - #define Q_log sc->pcl_n - - s7_pointer x = car(args); - -#if WITH_GMP - if (is_big_number(x)) return(big_log(sc, args)); -#endif - - if (!is_number(x)) - return(method_or_bust(sc, x, sc->log_symbol, args, a_number_string, 1)); - - if (is_pair(cdr(args))) - { - s7_pointer y = cadr(args); - if (!(is_number(y))) - return(method_or_bust(sc, y, sc->log_symbol, args, a_number_string, 2)); - -#if WITH_GMP - if (is_big_number(y)) return(big_log(sc, args)); -#endif - if ((is_t_integer(y)) && (integer(y) == 2)) - { - /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */ - if (is_t_integer(x)) - { - s7_int ix = integer(x); - if (ix > 0) - { - s7_double fx; -#if (__ANDROID__) || (MS_WINDOWS) || (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ <= 4)))) && (!defined(__clang__))) - /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */ - fx = log((double)ix) * LOG_2; -#else - fx = log2((double)ix); -#endif - /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */ -#if (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 4)))) && (!defined(__clang__))) - return(make_real(sc, fx)); -#else - return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); -#endif - }} - if ((is_real(x)) && - (is_positive(sc, x))) - return(make_real(sc, log(s7_real(x)) * LOG_2)); - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2)); - } - - if ((is_t_integer(x)) && (integer(x) == 1) && (is_t_integer(y)) && (integer(y) == 1)) /* (log 1 1) -> 0 (this is NaN in the bignum case) */ - return(int_zero); - - /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */ - if (is_zero(y)) - { - if ((is_t_integer(y)) && (is_t_integer(x)) && (integer(x) == 1)) - return(y); - out_of_range_error_nr(sc, sc->log_symbol, int_two, y, wrap_string(sc, "can't be zero", 13)); - } - - if ((is_t_real(x)) && (is_NaN(real(x)))) - return(x); - if (is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */ - return((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ - - if ((is_real(x)) && - (is_real(y)) && - (is_positive(sc, x)) && - (is_positive(sc, y))) - { - if ((is_rational(x)) && - (is_rational(y))) - { - s7_double res = log(rational_to_double(sc, x)) / log(rational_to_double(sc, y)); - s7_int ires = (s7_int)res; - if (res - ires == 0.0) - return(make_integer(sc, ires)); /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */ - /* since x and y are rational here, it seems reasonable to try to rationalize the result, but not go overboard? - * what about (expt 16 3/2) -> 64? also 2 as base is handled above and always returns a float. - */ - if (fabs(res) < RATIONALIZE_LIMIT) - { - s7_int num, den; - if ((c_rationalize(res, sc->default_rationalize_error, &num, &den)) && - (s7_int_abs(num) < 100) && (s7_int_abs(den) < 100)) - return(make_simple_ratio(sc, num, den)); - } - return(make_real(sc, res)); - } - return(make_real(sc, log(s7_real(x)) / log(s7_real(y)))); - } - if ((is_t_real(x)) && (is_NaN(real(x)))) - return(x); - if ((is_t_complex(y)) && ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))))) - return(y); - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y)))); - } - - if (!is_real(x)) - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)))); - if (is_positive(sc, x)) - return(make_real(sc, log(s7_real(x)))); - return(make_complex_not_0i(sc, log(-s7_real(x)), M_PI)); -} - -static s7_pointer log_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ -#if (!WITH_GMP) - if (args == 2) - { - s7_pointer x = cadr(expr), y = caddr(expr); - if ((is_t_integer(y)) && (integer(y) == 2) && (is_t_integer(x)) && (integer(x) > 0)) - return(sc->int_log2); - } -#endif - return(f); -} - -/* -------------------------------- sin -------------------------------- */ -#define SIN_LIMIT 1.0e16 -#define SINH_LIMIT 20.0 -/* (- (sinh (bignum 30.0)) (sinh 30.0)): -3.718172657214174140191915872003397016115E-4 - * (- (sinh (bignum 20.0)) (sinh 20.0)): -7.865629467297586346406367346575835463792E-10, slightly worse (e-8) if imag-part - */ - -static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_real(x)) return(make_real(sc, sin(real(x)))); /* range check in gmp case */ -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (sin 0) -> 0 */ -#if WITH_GMP - if (integer(x) > SIN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sin((s7_double)(integer(x))))); /* bogus for very large integers, but so is the equivalent real (see SIN_LIMIT) */ - - case T_RATIO: - return(make_real(sc, sin((s7_double)(fraction(x))))); - - case T_REAL: - { - s7_double y = real(x); -#if WITH_GMP - if (fabs(y) > SIN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sin(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SIN_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csin(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->sin_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sin(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_sin(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->sin_symbol, a_number_string)); - } - /* sin is inaccurate over about 1e30. There's a way to get true results, but it involves fancy "range reduction" techniques. - * (sin 1e32): 0.5852334864823946 - * but it should be 3.901970254333630491697613212893425767786E-1 - * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 !! (it's now a range error) - * it should be 5.263007914620499494429139986095833592117E0 - * before comparing imag-part to 0, we need to look for NaN and inf, else: - * (sinh 0+0/0i) -> 0.0 and (sinh (log 0.0)) -> inf.0 - */ -} - -static s7_pointer g_sin(s7_scheme *sc, s7_pointer args) -{ - #define H_sin "(sin z) returns sin(z)" - #define Q_sin sc->pl_nn - return(sin_p_p(sc, car(args))); -} - -#if WITH_GMP -static s7_pointer sin_p_d(s7_scheme *sc, s7_double x) -{ - if (fabs(x) <= SIN_LIMIT) - return(make_real(sc, sin(x))); - mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -} -#else -static s7_pointer sin_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sin(x)));} -#endif - -static s7_double sin_d_d(s7_double x) {return(sin(x));} - - -/* -------------------------------- cos -------------------------------- */ -static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_real(x)) return(make_real(sc, cos(real(x)))); /* range check in gmp case */ -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_one); /* (cos 0) -> 1 */ -#if WITH_GMP - if (integer(x) > SIN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cos((s7_double)(integer(x))))); - - case T_RATIO: - return(make_real(sc, cos((s7_double)(fraction(x))))); - - case T_REAL: /* if with_gmp */ - { - s7_double y = real(x); -#if WITH_GMP - if (fabs(y) > SIN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cos(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SIN_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, ccos(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->cos_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_cos(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_cos(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->cos_symbol, a_number_string)); - } -} - -static s7_pointer g_cos(s7_scheme *sc, s7_pointer args) -{ - #define H_cos "(cos z) returns cos(z)" - #define Q_cos sc->pl_nn - return(cos_p_p(sc, car(args))); -} - -#if WITH_GMP -static s7_pointer cos_p_d(s7_scheme *sc, s7_double x) -{ - if (fabs(x) <= SIN_LIMIT) - return(make_real(sc, cos(x))); - mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -} -#else -static s7_pointer cos_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cos(x)));} -#endif - -static s7_double cos_d_d(s7_double x) {return(cos(x));} - - -/* -------------------------------- tan -------------------------------- */ -#define TAN_LIMIT 1.0e18 - -static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_real(x)) return(make_real(sc, tan(real(x)))); -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (tan 0) -> 0 */ -#if WITH_GMP - if (integer(x) > TAN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, tan((s7_double)(integer(x))))); - - case T_RATIO: - return(make_real(sc, tan((s7_double)(fraction(x))))); - -#if WITH_GMP - case T_REAL: - if (fabs(real(x)) > TAN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, tan(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - if (imag_part(x) > 350.0) - return(make_complex_not_0i(sc, 0.0, 1.0)); - return((imag_part(x) < -350.0) ? s7_make_complex(sc, 0.0, -1.0) : c_complex_to_s7(sc, ctan(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->tan_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_tan(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0) - return(make_complex_not_0i(sc, 0.0, 1.0)); - if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0) - return(make_complex_not_0i(sc, 0.0, -1.0)); - mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->tan_symbol, a_number_string)); - } -} - -static s7_pointer g_tan(s7_scheme *sc, s7_pointer args) -{ - #define H_tan "(tan z) returns tan(z)" - #define Q_tan sc->pl_nn - return(tan_p_p(sc, car(args))); -} - -static s7_double tan_d_d(s7_double x) {return(tan(x));} - - -/* -------------------------------- asin -------------------------------- */ -static s7_pointer c_asin(s7_scheme *sc, s7_double x) -{ - s7_double absx = fabs(x), recip; - s7_complex result; - - if (absx <= 1.0) - return(make_real(sc, asin(x))); - - /* otherwise use maxima code: */ - recip = 1.0 / absx; - result = (M_PI / 2.0) - (_Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))))); - return((x < 0.0) ? c_complex_to_s7(sc, -result) : c_complex_to_s7(sc, result)); -} - -static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_real(p)) return(c_asin(sc, real(p))); - switch (type(p)) - { - case T_INTEGER: - if (integer(p) == 0) return(int_zero); /* (asin 0) -> 0 */ - /* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex */ - return(c_asin(sc, (s7_double)integer(p))); - - case T_RATIO: - return(c_asin(sc, fraction(p))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - /* if either real or imag part is very large, use explicit formula, not casin */ - /* this code taken from sbcl's src/code/irrat.lisp; break is around x+70000000i */ - if ((fabs(real_part(p)) > 1.0e7) || - (fabs(imag_part(p)) > 1.0e7)) - { - s7_complex sq1mz, sq1pz, z = to_c_complex(p); - sq1mz = csqrt(1.0 - z); - sq1pz = csqrt(1.0 + z); - return(s7_make_complex(sc, atan(real_part(p) / creal(sq1mz * sq1pz)), asinh(cimag(sq1pz * conj(sq1mz))))); - } - return(c_complex_to_s7(sc, casin(to_c_complex(p)))); -#else - out_of_range_error_nr(sc, sc->asin_symbol, int_one, p, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - goto ASIN_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); - goto ASIN_BIG_REAL; - case T_BIG_REAL: - if (mpfr_inf_p(big_real(p))) - { - if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */ - return(make_complex_not_0i(sc, NAN, -INFINITY)); - } - mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); - ASIN_BIG_REAL: - mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); - if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) - { - mpfr_asin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); - mpc_asin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_asin(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->asin_symbol, a_number_string)); - } -} - -static s7_pointer g_asin(s7_scheme *sc, s7_pointer args) -{ - #define H_asin "(asin z) returns asin(z); (sin (asin x)) = x" - #define Q_asin sc->pl_nn - return(asin_p_p(sc, car(args))); -} - - -/* -------------------------------- acos -------------------------------- */ -static s7_pointer c_acos(s7_scheme *sc, s7_double x) -{ - s7_double absx = fabs(x), recip; - s7_complex result; - - if (absx <= 1.0) - return(make_real(sc, acos(x))); - - /* else follow maxima again: */ - recip = 1.0 / absx; - if (x > 0.0) - result = _Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))); - else result = M_PI - _Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))); - return(c_complex_to_s7(sc, result)); -} - -static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_real(p)) return(c_acos(sc, real(p))); - switch (type(p)) - { - case T_INTEGER: - return((integer(p) == 1) ? int_zero : c_acos(sc, (s7_double)integer(p))); - - case T_RATIO: - return(c_acos(sc, fraction(p))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - /* if either real or imag part is very large, use explicit formula, not cacos */ - /* this code taken from sbcl's src/code/irrat.lisp */ - - if ((fabs(real_part(p)) > 1.0e7) || - (fabs(imag_part(p)) > 1.0e7)) - { - s7_complex sq1mz, sq1pz, z = to_c_complex(p); - sq1mz = csqrt(1.0 - z); - sq1pz = csqrt(1.0 + z); /* creal(sq1pz) can be 0.0 */ - if (creal(sq1pz) == 0.0) /* so the atan arg will be inf, so the real part will be pi/2(?) */ - return(s7_make_complex(sc, M_PI / 2.0, asinh(cimag(sq1mz * conj(sq1pz))))); - return(s7_make_complex(sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)), asinh(cimag(sq1mz * conj(sq1pz))))); - } - return(c_complex_to_s7(sc, cacos(s7_to_c_complex(p)))); -#else - out_of_range_error_nr(sc, sc->acos_symbol, int_one, p, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - goto ACOS_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); - goto ACOS_BIG_REAL; - case T_BIG_REAL: - if (mpfr_inf_p(big_real(p))) - { - if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */ - return(make_complex_not_0i(sc, -NAN, INFINITY)); - } - mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); - ACOS_BIG_REAL: - mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); - if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) - { - mpfr_acos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); - mpc_acos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_acos(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->acos_symbol, a_number_string)); - } -} - -static s7_pointer g_acos(s7_scheme *sc, s7_pointer args) -{ - #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1" - #define Q_acos sc->pl_nn - return(acos_p_p(sc, car(args))); -} - - -/* -------------------------------- atan -------------------------------- */ -static s7_pointer g_atan(s7_scheme *sc, s7_pointer args) -{ - #define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)" - #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol) - /* actually if there are two args, both should be real, but how to express that in the signature? */ - - s7_pointer x = car(args), y; - /* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */ - - if (!is_pair(cdr(args))) - { - switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, atan((double)integer(x)))); - case T_RATIO: return(make_real(sc, atan(fraction(x)))); - case T_REAL: return(make_real(sc, atan(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, catan(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->atan_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_atan(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->atan_symbol, a_number_string)); - }} - - y = cadr(args); - switch (type(x)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - if (is_small_real(y)) - return(make_real(sc, atan2(s7_real(x), s7_real(y)))); -#if WITH_GMP - if (!is_real(y)) - return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); - mpfr_set_d(sc->mpfr_1, s7_real(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; - case T_BIG_REAL: - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; -#endif - default: - return(method_or_bust(sc, x, sc->atan_symbol, args, sc->type_names[T_REAL], 1)); - } -#if WITH_GMP - ATAN2_BIG_REAL: - if (is_small_real(y)) - mpfr_set_d(sc->mpfr_2, s7_real(y), MPFR_RNDN); - else - if (is_t_big_real(y)) - mpfr_set(sc->mpfr_2, big_real(y), MPFR_RNDN); - else - if (is_t_big_integer(y)) - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - else - if (is_t_big_ratio(y)) - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - else return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); - mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif -} - -static s7_double atan_d_dd(s7_double x, s7_double y) {return(atan2(x, y));} - - -/* -------------------------------- sinh -------------------------------- */ -static s7_pointer sinh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (sinh 0) -> 0 */ - - case T_REAL: - case T_RATIO: - { - s7_double y = s7_real(x); -#if WITH_GMP - if (fabs(y) > SINH_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sinh(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SINH_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csinh(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->sinh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sinh(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_sinh(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->sinh_symbol, a_number_string)); - } -} - -static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args) -{ - #define H_sinh "(sinh z) returns sinh(z)" - #define Q_sinh sc->pl_nn - return(sinh_p_p(sc, car(args))); -} - -static s7_double sinh_d_d(s7_double x) {return(sinh(x));} -static s7_pointer sinh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sinh(x)));} - - -/* -------------------------------- cosh -------------------------------- */ -static s7_pointer cosh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_one); /* (cosh 0) -> 1 */ - - case T_REAL: - case T_RATIO: - { - s7_double y = s7_real(x); -#if WITH_GMP - if (fabs(y) > SINH_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cosh(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SINH_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, ccosh(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->cosh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_cosh(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_cosh(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->cosh_symbol, a_number_string)); - } -} - -static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args) -{ - #define H_cosh "(cosh z) returns cosh(z)" - #define Q_cosh sc->pl_nn - return(cosh_p_p(sc, car(args))); -} - -static s7_double cosh_d_d(s7_double x) {return(cosh(x));} -static s7_pointer cosh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cosh(x)));} - - -/* -------------------------------- tanh -------------------------------- */ -#define TANH_LIMIT 350.0 -static s7_pointer tanh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, tanh((s7_double)integer(x)))); - case T_RATIO: return(make_real(sc, tanh(fraction(x)))); - case T_REAL: return(make_real(sc, tanh(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - if (real_part(x) > TANH_LIMIT) - return(real_one); /* closer than 0.0 which is what ctanh is about to return! */ - if (real_part(x) < -TANH_LIMIT) - return(make_real(sc, -1.0)); /* closer than ctanh's -0.0 */ - return(c_complex_to_s7(sc, ctanh(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->tanh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - goto BIG_REAL_TANH; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - goto BIG_REAL_TANH; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - BIG_REAL_TANH: - if (mpfr_cmp_d(sc->mpfr_1, TANH_LIMIT) > 0) return(real_one); - if (mpfr_cmp_d(sc->mpfr_1, -TANH_LIMIT) < 0) return(make_real(sc, -1.0)); - mpfr_tanh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), TANH_LIMIT, 1))) > 0) - return(real_one); - if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -TANH_LIMIT, 1))) < 0) - return(make_real(sc, -1.0)); - if ((mpfr_nan_p(mpc_imagref(big_complex(x)))) || - (mpfr_inf_p(mpc_imagref(big_complex(x))))) - { - if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0) - return(make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */ - return(complex_NaN); - } - mpc_tanh(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->tanh_symbol, a_number_string)); - } -} - -static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args) -{ - #define H_tanh "(tanh z) returns tanh(z)" - #define Q_tanh sc->pl_nn - return(tanh_p_p(sc, car(args))); -} - -static s7_double tanh_d_d(s7_double x) {return(tanh(x));} - - -/* -------------------------------- asinh -------------------------------- */ -static s7_pointer asinh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, asinh((s7_double)integer(x)))); - case T_RATIO: return(make_real(sc, asinh(fraction(x)))); - case T_REAL: return(make_real(sc, asinh(real(x)))); - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - #if (defined(__OpenBSD__)) || (defined(__NetBSD__)) - return(c_complex_to_s7(sc, casinh_1(to_c_complex(x)))); - #else - return(c_complex_to_s7(sc, casinh(to_c_complex(x)))); - #endif -#else - out_of_range_error_nr(sc, sc->asinh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_asinh(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_asinh(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->asinh_symbol, a_number_string)); - } -} - -static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args) -{ - #define H_asinh "(asinh z) returns asinh(z)" - #define Q_asinh sc->pl_nn - return(asinh_p_p(sc, car(args))); -} - - -/* -------------------------------- acosh -------------------------------- */ -static s7_pointer acosh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 1) return(int_zero); - case T_REAL: - case T_RATIO: - { - s7_double x1 = s7_real(x); - if (x1 >= 1.0) - return(make_real(sc, acosh(x1))); - } - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - #ifdef __OpenBSD__ - return(c_complex_to_s7(sc, cacosh_1(s7_to_c_complex(x)))); - #else - return(c_complex_to_s7(sc, cacosh(s7_to_c_complex(x)))); /* not to_c_complex because x might not be complex */ - #endif -#else - /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */ - out_of_range_error_nr(sc, sc->acosh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN); - mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_acosh(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->acosh_symbol, a_number_string)); - } -} - -static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args) -{ - #define H_acosh "(acosh z) returns acosh(z)" - #define Q_acosh sc->pl_nn - return(acosh_p_p(sc, car(args))); -} - - -/* -------------------------------- atanh -------------------------------- */ -static s7_pointer atanh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (atanh 0) -> 0 */ - case T_REAL: - case T_RATIO: - { - s7_double x1 = s7_real(x); - if (fabs(x1) < 1.0) - return(make_real(sc, atanh(x1))); - } - /* if we can't distinguish x from 1.0 even with long_doubles, we'll get inf.0: - * (atanh 9223372036854775/9223372036854776) -> 18.714973875119 - * (atanh 92233720368547758/92233720368547757) -> inf.0 - * (atanh (bignum 92233720368547758/92233720368547757)) -> 1.987812468492420421418925013176932317086E1+1.570796326794896619231321691639751442098E0i - * but the imaginary part is unnecessary - */ - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - #if (defined(__OpenBSD__)) || (defined(__NetBSD__)) - return(c_complex_to_s7(sc, catanh_1(s7_to_c_complex(x)))); - #else - return(c_complex_to_s7(sc, catanh(s7_to_c_complex(x)))); - #endif -#else - out_of_range_error_nr(sc, sc->atanh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_2, big_integer(x), MPFR_RNDN); - goto ATANH_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(x), MPFR_RNDN); - goto ATANH_BIG_REAL; - case T_BIG_REAL: - mpfr_set(sc->mpfr_2, big_real(x), MPFR_RNDN); - ATANH_BIG_REAL: - mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); - if (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) < 0) - { - mpfr_atanh(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_2)); - } - mpc_set_fr(sc->mpc_1, sc->mpfr_2, MPC_RNDNN); - mpc_atanh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_atanh(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->atanh_symbol, a_number_string)); - } -} - -static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args) -{ - #define H_atanh "(atanh z) returns atanh(z)" - #define Q_atanh sc->pl_nn - return(atanh_p_p(sc, car(args))); -} - - -/* -------------------------------- sqrt -------------------------------- */ -static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) -{ - switch (type(p)) - { - case T_INTEGER: - { - s7_double sqx; - if (integer(p) >= 0) - { - s7_int ix; -#if WITH_GMP - mpz_set_si(sc->mpz_1, integer(p)); - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(make_integer(sc, mpz_get_si(sc->mpz_1))); - mpfr_set_si(sc->mpfr_1, integer(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - sqx = sqrt((s7_double)integer(p)); - ix = (s7_int)sqx; - return(((ix * ix) == integer(p)) ? make_integer(sc, ix) : make_real(sc, sqx)); - /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t - * but (* 94906265 94906265) -> 9007199136250225 -- oops - * if we use bigfloats, we're ok: - * (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15 - * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265 - */ - } -#if HAVE_COMPLEX_NUMBERS -#if WITH_GMP - mpc_set_si(sc->mpc_1, integer(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - sqx = (s7_double)integer(p); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */ - return(s7_make_complex(sc, 0.0, sqrt((s7_double)(-sqx)))); -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); -#endif - } - - case T_RATIO: - if (numerator(p) > 0) /* else it's complex, so it can't be a ratio */ - { - s7_int nm = (s7_int)sqrt(numerator(p)); - if (nm * nm == numerator(p)) - { - s7_int dn = (s7_int)sqrt(denominator(p)); - if (dn * dn == denominator(p)) - return(make_ratio(sc, nm, dn)); - } - return(make_real(sc, sqrt((s7_double)fraction(p)))); - } -#if HAVE_COMPLEX_NUMBERS - return(s7_make_complex(sc, 0.0, sqrt((s7_double)(-fraction(p))))); -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); -#endif - - case T_REAL: - if (is_NaN(real(p))) return(p); - if (real(p) >= 0.0) - return(make_real(sc, sqrt(real(p)))); - return(make_complex_not_0i(sc, 0.0, sqrt(-real(p)))); - - case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */ -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csqrt(to_c_complex(p)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */ -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p), 0) >= 0) - { - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(p)); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(mpz_to_integer(sc, sc->mpz_1)); - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_z(sc->mpc_1, big_integer(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - - case T_BIG_RATIO: /* if big ratio, check both num and den for squares */ - if (mpq_cmp_ui(big_ratio(p), 0, 1) < 0) - { - mpc_set_q(sc->mpc_1, big_ratio(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(p))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(p))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_3); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - }} - mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - - case T_BIG_REAL: - if (mpfr_cmp_ui(big_real(p), 0) < 0) - { - mpc_set_fr(sc->mpc_1, big_real(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } - mpfr_sqrt(sc->mpfr_1, big_real(p), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - - case T_BIG_COMPLEX: - mpc_sqrt(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->sqrt_symbol, a_number_string)); - } -} - -static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args) -{ - #define H_sqrt "(sqrt z) returns the square root of z" - #define Q_sqrt sc->pl_nn - return(sqrt_p_p(sc, car(args))); -} - - -/* -------------------------------- expt -------------------------------- */ -static s7_int int_to_int(s7_int x, s7_int n) -{ - /* from GSL */ - s7_int value = 1; - do { - if (n & 1) value *= x; - n >>= 1; -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(x, x, &x)) - break; -#else - x *= x; -#endif - } while (n); - return(value); -} - -static const int64_t nth_roots[63] = { - S7_INT64_MAX, S7_INT64_MAX, 3037000499LL, 2097151, 55108, 6208, 1448, 511, 234, 127, 78, 52, 38, 28, 22, - 18, 15, 13, 11, 9, 8, 7, 7, 6, 6, 5, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2}; - -static bool int_pow_ok(s7_int x, s7_int y) -{ - return((y < S7_INT_BITS) && (nth_roots[y] >= s7_int_abs(x))); -} - -#if WITH_GMP -static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p); -static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2); - -static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args), y = cadr(args), res; - if (!is_number(x)) - return(method_or_bust(sc, x, sc->expt_symbol, args, a_number_string, 1)); - if (!is_number(y)) - return(method_or_bust(sc, y, sc->expt_symbol, args, a_number_string, 2)); - - if (is_zero(x)) - { - if ((s7_is_integer(x)) && - (s7_is_integer(y)) && - (is_zero(y))) - return(int_one); - - if (is_real(y)) - { - if (is_negative(sc, y)) - division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - } - else - if (is_negative(sc, real_part_p_p(sc, y))) /* handle big_complex as well as complex */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - - if ((is_rational(x)) && - (is_rational(y))) - return(int_zero); - return(real_zero); - } - - if (s7_is_integer(y)) - { - s7_int yval = s7_integer_clamped_if_gmp(sc, y); - if (yval == 0) - return((is_rational(x)) ? int_one : real_one); - - if (yval == 1) - return(x); - - if ((!is_big_number(x)) && - ((is_one(x)) || (is_zero(x)))) - return(x); - - if ((yval < S7_INT32_MAX) && - (yval > S7_INT32_MIN)) - { - /* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */ - if (s7_is_integer(x)) - { - if (is_t_big_integer(x)) - mpz_set(sc->mpz_2, big_integer(x)); - else mpz_set_si(sc->mpz_2, integer(x)); - if (yval >= 0) - { - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - return(mpz_to_integer(sc, sc->mpz_2)); - } - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)(-yval)); - mpq_set_z(sc->mpq_1, sc->mpz_2); - mpq_inv(sc->mpq_1, sc->mpq_1); - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - return(mpq_to_big_ratio(sc, sc->mpq_1)); - } - - if (s7_is_ratio(x)) /* here y is an integer */ - { - if (is_t_big_ratio(x)) - { - mpz_set(sc->mpz_1, mpq_numref(big_ratio(x))); - mpz_set(sc->mpz_2, mpq_denref(big_ratio(x))); - } - else - { - mpz_set_si(sc->mpz_1, numerator(x)); - mpz_set_si(sc->mpz_2, denominator(x)); - } - if (yval >= 0) - { - mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_2); - } - else - { - yval = -yval; - mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - mpq_set_num(sc->mpq_1, sc->mpz_2); - mpq_set_den(sc->mpq_1, sc->mpz_1); - mpq_canonicalize(sc->mpq_1); - } - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - return(mpq_to_big_ratio(sc, sc->mpq_1)); - } - - if (is_real(x)) - { - if (is_t_big_real(x)) - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - else mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }}} - - if ((is_t_ratio(y)) && /* not s7_is_ratio which accepts bignums */ - (numerator(y) == 1)) - { - if (denominator(y) == 2) - return(sqrt_p_p(sc, x)); - - if ((is_real(x)) && - (denominator(y) == 3)) - { - any_real_to_mpfr(sc, x, sc->mpfr_1); - mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }} - - res = any_number_to_mpc(sc, y, sc->mpc_2); - if (res == real_infinity) - { - if (is_one(x)) return(int_one); - if (!is_real(x)) return((is_negative(sc, y)) ? real_zero : complex_NaN); - if (is_zero(x)) - { - if (is_negative(sc, y)) division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - return(real_zero); - } - if (lt_b_pi(sc, x, 0)) - { - if (lt_b_pi(sc, x, -1)) - return((is_positive(sc, y)) ? real_infinity : real_zero); - return((is_positive(sc, y)) ? real_zero : real_infinity); - } - if (lt_b_pi(sc, x, 1)) - return((is_positive(sc, y)) ? real_zero : real_infinity); - return((is_positive(sc, y)) ? real_infinity : real_zero); - } - if (res) return(complex_NaN); - - if ((is_real(x)) && - (is_real(y)) && - (is_positive(sc, x))) - { - res = any_real_to_mpfr(sc, x, sc->mpfr_1); - if (res) - { - if (res == real_infinity) - { - if (is_negative(sc, y)) return(real_zero); - return((is_zero(y)) ? real_one : real_infinity); - } - return(complex_NaN); - } - mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - - res = any_number_to_mpc(sc, x, sc->mpc_1); - if (res) - { - if ((res == real_infinity) && (is_real(y))) - { - if (is_negative(sc, y)) return(real_zero); - return((is_zero(y)) ? real_one : real_infinity); - } - return(complex_NaN); - } - if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0) - return(int_zero); - if (mpc_cmp_si_si(sc->mpc_1, 1, 0) == 0) - return(int_one); - - mpc_pow(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - - if ((!mpfr_nan_p(mpc_imagref(sc->mpc_1))) && (mpfr_cmp_ui(mpc_imagref(sc->mpc_1), 0) == 0)) /* (expt -inf.0 1/3) -> +inf.0+nan.0i in mpc */ - { - if ((is_rational(car(args))) && - (is_rational(cadr(args))) && - (mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0)) - { - /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */ - /* so first make sure we're within (say) 31 bits */ - mpfr_set_ui(sc->mpfr_1, S7_INT32_MAX, MPFR_RNDN); - if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0) - { - mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_1)); - }} - mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - return(mpc_to_number(sc, sc->mpc_1)); -} -#endif - -static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw) -{ - if (!is_number(n)) - return(method_or_bust_pp(sc, n, sc->expt_symbol, n, pw, a_number_string, 1)); - if (!is_number(pw)) - return(method_or_bust_pp(sc, pw, sc->expt_symbol, n, pw, a_number_string, 2)); - - if (is_zero(n)) - { - if (is_zero(pw)) - { - if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */ - return(int_one); - return(real_zero); /* (expt 0.0 0) -> 0.0 */ - } - if (is_real(pw)) - { - if (is_negative(sc, pw)) /* (expt 0 -1) */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); - /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */ - - if (is_NaN(s7_real(pw))) /* (expt 0 +nan.0) */ - return(pw); - } - else - { /* (expt 0 a+bi) */ - if (real_part(pw) < 0.0) /* (expt 0 -1+i) */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); - if ((is_NaN(real_part(pw))) || /* (expt 0 0+1/0i) */ - (is_NaN(imag_part(pw)))) - return(pw); - } - if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* pw != 0, (expt 0 2312) */ - return(int_zero); - return(real_zero); /* (expt 0.0 123123) */ - } - - if (is_one(pw)) - { - if (s7_is_integer(pw)) /* (expt x 1) */ - return(n); - if (is_rational(n)) /* (expt ratio 1.0) */ - return(make_real(sc, rational_to_double(sc, n))); - return(n); - } - if (is_t_integer(pw)) - { - s7_int y = integer(pw); - if (y == 0) - { - if (is_rational(n)) /* (expt 3 0) */ - return(int_one); - if ((is_NaN(s7_real_part(n))) || /* (expt 1/0 0) -> NaN */ - (is_NaN(s7_imag_part(n)))) /* (expt (complex 0 1/0) 0) -> NaN */ - return(n); - return(real_one); /* (expt 3.0 0) */ - } - switch (type(n)) - { - case T_INTEGER: - { - s7_int x = integer(n); - if (x == 1) /* (expt 1 y) */ - return(n); - - if (x == -1) - { - if (y == S7_INT64_MIN) /* (expt -1 most-negative-fixnum) */ - return(int_one); - if (s7_int_abs(y) & 1) /* (expt -1 odd-int) */ - return(n); - return(int_one); /* (expt -1 even-int) */ - } - - if (y == S7_INT64_MIN) /* (expt x most-negative-fixnum) */ - return(int_zero); - if (x == S7_INT64_MIN) /* (expt most-negative-fixnum y) */ - return(make_real(sc, pow((double)x, (double)y))); - - if (int_pow_ok(x, s7_int_abs(y))) - { - if (y > 0) - return(make_integer(sc, int_to_int(x, y))); - return(make_ratio(sc, 1, int_to_int(x, -y))); - }} - break; - - case T_RATIO: - { - s7_int nm = numerator(n), dn = denominator(n); - if (y == S7_INT64_MIN) - { - if (s7_int_abs(nm) > dn) - return(int_zero); /* (expt 4/3 most-negative-fixnum) -> 0? */ - return(real_infinity); /* (expt 3/4 most-negative-fixnum) -> inf? */ - } - if ((int_pow_ok(nm, s7_int_abs(y))) && - (int_pow_ok(dn, s7_int_abs(y)))) - { - if (y > 0) - return(make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y))); - return(make_ratio_with_div_check(sc, sc->expt_symbol, int_to_int(dn, -y), int_to_int(nm, -y))); - }} - break; - /* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking - * one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc - */ - - case T_REAL: - /* (expt -1.0 most-positive-fixnum) should be -1.0 - * (expt -1.0 (+ (expt 2 53) 1)) -> -1.0 - * (expt -1.0 (- 1 (expt 2 54))) -> -1.0 - */ - if (real(n) == -1.0) - { - if (y == S7_INT64_MIN) - return(real_one); - return((s7_int_abs(y) & 1) ? n : real_one); - } - break; - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - if ((s7_real_part(n) == 0.0) && - ((s7_imag_part(n) == 1.0) || - (s7_imag_part(n) == -1.0))) - { - bool yp = (y > 0), np = (s7_imag_part(n) > 0.0); - switch (s7_int_abs(y) % 4) - { - case 0: return(real_one); - case 1: return(make_complex_not_0i(sc, 0.0, (yp == np) ? 1.0 : -1.0)); - case 2: return(make_real(sc, -1.0)); - case 3: return(make_complex_not_0i(sc, 0.0, (yp == np) ? -1.0 : 1.0)); - }} -#else - out_of_range_error_nr(sc, sc->expt_symbol, int_two, n, no_complex_numbers_string); -#endif - break; - }} - - if ((is_real(n)) && - (is_real(pw))) - { - s7_double x, y; - - if ((is_t_ratio(pw)) && - (numerator(pw) == 1)) - { - if (denominator(pw) == 2) - return(sqrt_p_p(sc, n)); - if (denominator(pw) == 3) - return(make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */ - /* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */ - } - - x = s7_real(n); - y = s7_real(pw); - if (is_NaN(x)) return(n); - if (is_NaN(y)) return(pw); - if (y == 0.0) return(real_one); - /* I think pow(rl, inf) is ok */ - if (x > 0.0) - return(make_real(sc, pow(x, y))); /* tricky cases abound here: (expt -1 1/9223372036854775807) */ - } - - /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ? - * (expt 0+i 1+1/0i) = 0.0 ?? - */ - return(c_complex_to_s7(sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw)))); -} - -static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) -{ - #define H_expt "(expt z1 z2) returns z1^z2" - #define Q_expt sc->pcl_n -#if WITH_GMP - return(big_expt(sc, args)); - /* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */ -#endif - return(expt_p_pp(sc, car(args), cadr(args))); -} - - -/* -------------------------------- lcm -------------------------------- */ -#if WITH_GMP -static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args) -{ - mpz_set_si(sc->mpz_3, num); - mpz_set_si(sc->mpz_4, den); - - for (s7_pointer x = args; is_pair(x); x = cdr(x)) - { - s7_pointer rat = car(x); - switch (type(rat)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(rat)); - mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_set_si(sc->mpz_4, 1); - break; - case T_RATIO: - mpz_set_si(sc->mpz_1, numerator(rat)); - mpz_set_si(sc->mpz_2, denominator(rat)); - mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2); - break; - case T_BIG_INTEGER: - mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat)); - mpz_set_si(sc->mpz_4, 1); - break; - case T_BIG_RATIO: - mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); - mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); - break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(x, args), rat, a_rational_string); - default: - return(method_or_bust(sc, rat, sc->lcm_symbol, - set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), - a_rational_string, position_of(x, args))); - }} - return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); -} -#endif - -static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) -{ - /* (/ (* m n) (gcd m n)), (lcm a b c) -> (lcm a (lcm b c)) */ - #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments" - #define Q_lcm sc->pcl_f - - s7_int n = 1, d = 0; - - if (!is_pair(args)) - return(int_one); - - if (!is_pair(cdr(args))) - { - if (!is_rational(car(args))) - return(method_or_bust(sc, car(args), sc->lcm_symbol, args, a_rational_string, 1)); - return(g_abs(sc, args)); - } - - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer x = car(p); - s7_int b; -#if HAVE_OVERFLOW_CHECKS - s7_int n1; -#endif - switch (type(x)) - { - case T_INTEGER: - d = 1; - if (integer(x) == 0) /* return 0 unless there's a wrong-type-arg (geez what a mess) */ - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - { - s7_pointer x1 = car(p); - if (is_number(x1)) - { - if (!is_rational(x1)) - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - else - if (has_active_methods(sc, x1)) - { - s7_pointer f = find_method_with_let(sc, x1, sc->is_rational_symbol); - if ((f == sc->undefined) || - (is_false(sc, s7_apply_function(sc, f, set_plist_1(sc, x1))))) - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - else wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - return(int_zero); - } - b = integer(x); - if (b < 0) - { - if (b == S7_INT64_MIN) -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); -#endif - b = -b; - } -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(n / c_gcd(n, b), b, &n1)) -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, result_is_too_large_string); -#endif - n = n1; -#else - n = (n / c_gcd(n, b)) * b; -#endif - break; - - case T_RATIO: - b = numerator(x); - if (b < 0) - { - if (b == S7_INT64_MIN) -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); -#endif - b = -b; - } -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(n / c_gcd(n, b), b, &n1)) /* (lcm 92233720368547758/3 3005/2) */ -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, intermediate_too_large_string); -#endif - n = n1; -#else - n = (n / c_gcd(n, b)) * b; -#endif - if (d == 0) - d = (p == args) ? denominator(x) : 1; - else d = c_gcd(d, denominator(x)); - break; - -#if WITH_GMP - case T_BIG_INTEGER: - d = 1; - case T_BIG_RATIO: - return(big_lcm(sc, n, d, p)); -#endif - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string); - - default: - return(method_or_bust(sc, x, sc->lcm_symbol, - set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->lcm_symbol, n, d), p), - a_rational_string, position_of(p, args))); - }} - return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); -} - - -/* -------------------------------- gcd -------------------------------- */ -#if WITH_GMP -static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args) -{ - mpz_set_si(sc->mpz_3, num); - mpz_set_si(sc->mpz_4, den); - - for (s7_pointer x = args; is_pair(x); x = cdr(x)) - { - s7_pointer rat = car(x); - switch (type(rat)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(rat)); - mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); - break; - case T_RATIO: - mpz_set_si(sc->mpz_1, numerator(rat)); - mpz_set_si(sc->mpz_2, denominator(rat)); - mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2); - break; - case T_BIG_INTEGER: - mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat)); - break; - case T_BIG_RATIO: - mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); - mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); - break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->gcd_symbol, position_of(x, args), rat, a_rational_string); - default: - return(method_or_bust(sc, rat, sc->gcd_symbol, - set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), - a_rational_string, position_of(x, args))); - }} - return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); -} -#endif - -static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args) -{ - #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments" - #define Q_gcd sc->pcl_f - - s7_int n = 0, d = 1; - - if (!is_pair(args)) /* (gcd) */ - return(int_zero); - - if (!is_pair(cdr(args))) /* (gcd 3/4) */ - { - if (!is_rational(car(args))) - return(method_or_bust(sc, car(args), sc->gcd_symbol, args, a_rational_string, 1)); - return(abs_p_p(sc, car(args))); - } - - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer x = car(p); - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == S7_INT64_MIN) -#if WITH_GMP - return(big_gcd(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); -#endif - n = c_gcd(n, integer(x)); - break; - - case T_RATIO: - { -#if HAVE_OVERFLOW_CHECKS - s7_int dn; -#endif - n = c_gcd(n, numerator(x)); - if (d == 1) - d = denominator(x); - else - { - s7_int b = denominator(x); -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */ -#if WITH_GMP - return(big_gcd(sc, n, d, x)); -#else - sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, intermediate_too_large_string); -#endif - d = dn; -#else - d = (d / c_gcd(d, b)) * b; -#endif - }} - break; - -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: - return(big_gcd(sc, n, d, p)); -#endif - - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->gcd_symbol, position_of(p, args), x, a_rational_string); - - default: - return(method_or_bust(sc, x, sc->gcd_symbol, - set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->gcd_symbol, n, d), p), - a_rational_string, position_of(p, args))); - }} - return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); -} - - -/* -------------------------------- floor -------------------------------- */ -static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - { - s7_int val = numerator(x) / denominator(x); - /* C "/" truncates? -- C spec says "truncation toward 0" */ - /* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers - * but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results: - * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1 - * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2 - */ - return(make_integer(sc, (numerator(x) < 0) ? (val - 1) : val)); /* not "val" because it might be truncated to 0 */ - } - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (s7_int)floor(z))); - /* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */ - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); - mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->floor_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->floor_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_floor(s7_scheme *sc, s7_pointer args) -{ - #define H_floor "(floor x) returns the integer closest to x toward -inf" - #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(floor_p_p(sc, car(args))); -} - -static s7_int floor_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int floor_i_7d(s7_scheme *sc, s7_double x) -{ - if (is_NaN(x)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, real_NaN, it_is_nan_string); - if (fabs(x) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, wrap_real(sc, x), it_is_too_large_string); - return((s7_int)floor(x)); -} - -static s7_int floor_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p)); - if (is_t_real(p)) return(floor_i_7d(sc, real(p))); - if (is_t_ratio(p)) /* for consistency with floor_p_p, don't use floor(fraction(p)) */ - { - s7_int val = numerator(p) / denominator(p); - return((numerator(p) < 0) ? val - 1 : val); - } - return(s7_integer(method_or_bust_p(sc, p, sc->floor_symbol, sc->type_names[T_REAL]))); -} - -static s7_pointer floor_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,floor_i_7d(sc, x)));} -#endif - - -/* -------------------------------- ceiling -------------------------------- */ -static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - { - s7_int val = numerator(x) / denominator(x); - return(make_integer(sc, (numerator(x) < 0) ? val : (val + 1))); - } - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (s7_int)ceil(real(x)))); - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); - mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->ceiling_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->ceiling_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args) -{ - #define H_ceiling "(ceiling x) returns the integer closest to x toward inf" - #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(ceiling_p_p(sc, car(args))); -} - -static s7_int ceiling_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int ceiling_i_7d(s7_scheme *sc, s7_double x) -{ - if (is_NaN(x)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, real_NaN, it_is_nan_string); - if ((is_inf(x)) || - (x > DOUBLE_TO_INT64_LIMIT) || (x < -DOUBLE_TO_INT64_LIMIT)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, wrap_real(sc, x), it_is_too_large_string); - return((s7_int)ceil(x)); -} - -static s7_int ceiling_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p)); - if (is_t_real(p)) return(ceiling_i_7d(sc, real(p))); - if (is_t_ratio(p)) return((s7_int)(ceil(fraction(p)))); - return(s7_integer(method_or_bust_p(sc, p, sc->ceiling_symbol, sc->type_names[T_REAL]))); -} - -static s7_pointer ceiling_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, ceiling_i_7d(sc, x)));} -#endif - - -/* -------------------------------- truncate -------------------------------- */ -static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - return(make_integer(sc, (s7_int)(numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */ - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (z > 0.0) ? (s7_int)floor(z) : (s7_int)ceil(z))); - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); - mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->truncate_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->truncate_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args) -{ - #define H_truncate "(truncate x) returns the integer closest to x toward 0" - #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(truncate_p_p(sc, car(args))); -} - -static s7_int truncate_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int truncate_i_7d(s7_scheme *sc, s7_double x) -{ - if (is_NaN(x)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, real_NaN, it_is_nan_string); - if (is_inf(x)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), it_is_infinite_string); - if (fabs(x) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), it_is_too_large_string); - return((x > 0.0) ? (s7_int)floor(x) : (s7_int)ceil(x)); -} - -static s7_pointer truncate_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, truncate_i_7d(sc, x)));} -#endif - - -/* -------------------------------- round -------------------------------- */ -static s7_double r5rs_round(s7_double x) -{ - s7_double fl = floor(x), ce = ceil(x); - s7_double dfl = x - fl; - s7_double dce = ce - x; - if (dfl > dce) return(ce); - if (dfl < dce) return(fl); - return((fmod(fl, 2.0) == 0.0) ? fl : ce); -} - -static s7_pointer round_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - { - s7_int truncated = numerator(x) / denominator(x), remains = numerator(x) % denominator(x); - long_double frac = s7_fabsl((long_double)remains / (long_double)denominator(x)); - if ((frac > 0.5) || - ((frac == 0.5) && - (truncated % 2 != 0))) - return(make_integer(sc, (numerator(x) < 0) ? (truncated - 1) : (truncated + 1))); - return(make_integer(sc, truncated)); - } - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); /* mpfr_roundeven in mpfr 4.0.0 */ - mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_3)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (s7_int)r5rs_round(z))); - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - { - int32_t rnd; - mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2); - rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x))); - mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x))); - if (rnd > 0) - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - else - if ((rnd == 0) && - (mpz_odd_p(sc->mpz_1))) - mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); - return(mpz_to_integer(sc, sc->mpz_1)); - } - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); - mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_3)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->round_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->round_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_round(s7_scheme *sc, s7_pointer args) -{ - #define H_round "(round x) returns the integer closest to x" - #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(round_p_p(sc, car(args))); -} - -static s7_int round_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int round_i_7d(s7_scheme *sc, s7_double z) -{ - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, real_NaN, it_is_nan_string); - if ((is_inf(z)) || - (z > DOUBLE_TO_INT64_LIMIT) || (z < -DOUBLE_TO_INT64_LIMIT)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, wrap_real(sc, z), it_is_too_large_string); - return((s7_int)r5rs_round(z)); -} - -static s7_pointer round_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,round_i_7d(sc, x)));} -#endif - - -/* ---------------------------------------- add ---------------------------------------- */ -static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (add_overflow(x, y, &val)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_set_si(sc->mpz_2, y); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (long_double)x + (long_double)y)); - } -#endif - return(make_integer(sc, val)); -#else - return(make_integer(sc, x + y)); -#endif -} - -static s7_pointer integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme *sc, s7_pointer x, s7_pointer y) /* x: int, y:ratio */ -{ -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(x), denominator(y), &z)) || - (add_overflow(z, numerator(y), &z))) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(x)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); - mpz_set_si(sc->mpz_2, numerator(y)); - mpz_add(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer + ratio overflow: (+ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, (long_double)integer(x) + fraction(y))); - } -#endif - return(make_ratio(sc, z, denominator(y))); -#else - return(make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y))); -#endif -} - -#define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0) -/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */ - -static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - /* an experiment: try to avoid the switch statement */ - /* this wins in most s7 cases, not so much elsewhere? parallel subtract/multiply code is slower */ - if (is_t_integer(x)) - { - if (is_t_integer(y)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - } - else - if (is_t_real(x)) - { - if (is_t_real(y)) - return(make_real(sc, real(x) + real(y))); - } - else - if ((is_t_complex(x)) && (is_t_complex(y))) - return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - return(integer_ratio_add_if_overflow_to_real_or_rational(sc, x, y)); - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */ - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, integer(x)); - mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(integer_ratio_add_if_overflow_to_real_or_rational(sc, y, x)); - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - { -#if HAVE_OVERFLOW_CHECKS - s7_int q; - if (add_overflow(n1, n2, &q)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (/ (+ %" ld64 " %" ld64 ") %" ld64 ")\n", n1, n2, d1); - return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1)); - } -#endif - return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1)); -#else - return(make_ratio_with_div_check(sc, sc->add_symbol, n1 + n2, d1)); -#endif - } - -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1, d1d2, q; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1)) || - (add_overflow(n1d2, n2d1, &q))) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (+ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2))); - } -#endif - return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1d2)); - } -#else - return(make_ratio_with_div_check(sc, sc->add_symbol, n1 * d2 + n2 * d1, d1 * d2)); -#endif - } - case T_REAL: - return(make_real(sc, fraction(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, fraction(x) + real_part(y), imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: -#if WITH_GMP - if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (+ .1 9223372036854775807) */ - { - mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) + (long_double)integer(y))); - case T_RATIO: - return(make_real(sc, real(x) + fraction(y))); - case T_REAL: - return(make_real(sc, real(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, real(x) + real_part(y), imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_add_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - return(make_complex_not_0i(sc, real_part(x) + integer(y), imag_part(x))); - case T_RATIO: - return(make_complex_not_0i(sc, real_part(x) + fraction(y), imag_part(x))); - case T_REAL: - return(make_complex_not_0i(sc, real_part(x) + real(y), imag_part(x))); - case T_COMPLEX: - return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(y)); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_add(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_add_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_add(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } -#endif - default: - return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); - } -} - -static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer p0, s7_pointer p1, s7_pointer p2) -{ - if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2))) - { -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if ((!add_overflow(integer(p0), integer(p1), &val)) && - (!add_overflow(val, integer(p2), &val))) - return(make_integer(sc, val)); -#if WITH_GMP - mpz_set_si(sc->mpz_1, integer(p0)); - mpz_set_si(sc->mpz_2, integer(p1)); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - mpz_set_si(sc->mpz_2, integer(p2)); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - return(mpz_to_integer(sc, sc->mpz_1)); -#else - if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(p0), integer(p1), integer(p2)); - return(make_real(sc, (long_double)integer(p0) + (long_double)integer(p1) + (long_double)integer(p2))); -#endif -#else - return(make_integer(sc, integer(p0) + integer(p1) + integer(p2))); -#endif - } - if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2))) - return(make_real(sc, real(p0) + real(p1) + real(p2))); - { - s7_pointer p = add_p_pp(sc, p0, p1); - sc->error_argnum = 1; - p = add_p_pp(sc, p, p2); - sc->error_argnum = 0; - return(p); - } -} - -static s7_pointer g_add(s7_scheme *sc, s7_pointer args) -{ - #define H_add "(+ ...) adds its arguments" - #define Q_add sc->pcl_n - - s7_pointer x, p; - if (is_null(args)) - return(int_zero); - x = car(args); - p = cdr(args); - if (is_null(p)) - { - if (!is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->add_symbol, a_number_string)); - return(x); - } - if (is_null(cdr(p))) - return(add_p_pp(sc, x, car(p))); - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = add_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) {return(add_p_ppp(sc, car(args), cadr(args), caddr(args)));} - -static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int32_t pos) -{ - if (is_t_integer(x)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); - - switch (type(x)) - { - case T_RATIO: return(integer_ratio_add_if_overflow_to_real_or_rational(sc, int_one, x)); /* return(add_p_pp(sc, x, int_one)) */ - case T_REAL: return(make_real(sc, real(x) + 1.0)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, 1); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(add_p_pp(sc, x, int_one)); -#endif - default: - return(method_or_bust(sc, x, sc->add_symbol, - (pos == 1) ? set_plist_2(sc, x, int_one) : set_plist_2(sc, int_one, x), - a_number_string, pos)); - } - return(x); -} - -#if WITH_GMP -static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, car(args), 1));} -#else -static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args); - if (is_t_integer(x)) return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); /* return(make_integer(sc, integer(x) + 1)); */ - if (is_t_real(x)) return(make_real(sc, real(x) + 1.0)); - if (is_t_complex(x)) return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); - return(add_p_pp(sc, x, int_one)); -} -#endif -static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, cadr(args), 2));} - -static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y, int32_t loc) -{ - if (is_t_integer(x)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), y)); - - switch (type(x)) - { - case T_RATIO: return(add_p_pp(sc, x, wrap_integer(sc, y))); - case T_REAL: return(make_real(sc, real(x) + y)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, y); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(add_p_pp(sc, x, wrap_integer(sc, y))); -#endif - default: return(method_or_bust_with_type_pi(sc, x, sc->add_symbol, x, y, a_number_string, loc)); - } - return(x); -} - -static s7_pointer add_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_add_xi(sc, p1, i1, 1));} - -static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t loc) -{ - if (is_t_real(x)) return(make_real(sc, real(x) + y)); - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, integer(x) + y)); - case T_RATIO: return(make_real(sc, fraction(x) + y)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(add_p_pp(sc, x, wrap_real(sc, y))); -#endif - default: return(method_or_bust_with_type_pf(sc, x, sc->add_symbol, x, y, a_number_string, loc)); - } - return(x); -} - -static s7_pointer g_add_2_ff(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - if ((is_t_real(car(args))) && (is_t_real(cadr(args)))) - return(make_real(sc, real(car(args)) + real(cadr(args)))); - return(add_p_pp(sc, car(args), cadr(args))); -#else - return(make_real(sc, real(car(args)) + real(cadr(args)))); -#endif -} - -static s7_pointer g_add_2_ii(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - if ((is_t_integer(car(args))) && (is_t_integer(cadr(args)))) -#endif - return(add_if_overflow_to_real_or_big_integer(sc, integer(car(args)), integer(cadr(args)))); -#if WITH_GMP - return(g_add(sc, args)); /* possibly bigint? */ -#endif -} - -#if WITH_GMP -static s7_pointer add_2_if(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if ((is_t_integer(x)) && (is_t_real(y))) - { - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - return(make_real(sc, integer(x) + real(y))); - } - return(add_p_pp(sc, x, y)); -} - -static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(add_2_if(sc, car(args), cadr(args)));} -static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(add_2_if(sc, cadr(args), car(args)));} - -static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {if (is_t_integer(cadr(args))) return(g_add_xi(sc, car(args), integer(cadr(args)), 1)); return(g_add(sc, args));} -static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {if (is_t_integer(car(args))) return(g_add_xi(sc, cadr(args), integer(car(args)), 2)); return(g_add(sc, args));} -static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {if (is_t_real(cadr(args))) return(g_add_xf(sc, car(args), real(cadr(args)), 1)); return(g_add(sc, args));} -static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {if (is_t_real(car(args))) return(g_add_xf(sc, cadr(args), real(car(args)), 2)); return(g_add(sc, args));} - -#else - -static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) + real(cadr(args))));} -static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) + integer(cadr(args))));} -static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, car(args), integer(cadr(args)), 1));} -static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, cadr(args), integer(car(args)), 2));} -static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, car(args), real(cadr(args)), 1));} -static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, cadr(args), real(car(args)), 2));} -#endif - -static s7_pointer add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));} -static s7_pointer add_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_integer(sc, x1 + x2));} - -/* add_p_ii and add_d_id unhittable apparently -- this (d_id) is due to the order of d_dd_ok and d_id_ok in float_optimize, - * but d_dd is much more often hit, and the int arg (if constant) is turned into a float in d_dd - */ -static s7_double add_d_d(s7_double x) {return(x);} -static s7_double add_d_dd(s7_double x1, s7_double x2) {return(x1 + x2);} -static s7_double add_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 + x2 + x3);} -static s7_double add_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 + x2 + x3 + x4);} - -static s7_int add_i_ii(s7_int i1, s7_int i2) {return(i1 + i2);} -static s7_int add_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 + i2 + i3);} - -static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1) -{ - if (is_pair(arg1)) - { - if (car(arg1) == sc->quote_symbol) - return((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */ - - if ((is_h_optimized(arg1)) && - (is_safe_c_op(optimize_op(arg1))) && - (is_c_function(opt1_cfunc(arg1)))) - { - s7_pointer sig = c_function_signature(opt1_cfunc(arg1)); - if ((sig) && - (is_pair(sig)) && - (is_symbol(car(sig)))) - return(car(sig)); - } - /* perhaps add closure sig if we can depend on it (immutable func etc) */ - } - else - if (!is_symbol(arg1)) - return(s7_type_of(sc, arg1)); - return(NULL); -} - -static s7_pointer chooser_check_arg_types(s7_scheme *sc, s7_pointer arg1, s7_pointer arg2, s7_pointer fallback, - s7_pointer f_2_ff, s7_pointer f_2_ii, s7_pointer f_2_if, s7_pointer f_2_fi, - s7_pointer f_2_xi, s7_pointer f_2_ix, s7_pointer f_2_fx, s7_pointer f_2_xf) -{ - s7_pointer arg1_type = argument_type(sc, arg1); - s7_pointer arg2_type = argument_type(sc, arg2); - if ((arg1_type) || (arg2_type)) - { - if (arg1_type == sc->is_float_symbol) - { - if (arg2_type == sc->is_float_symbol) - return(f_2_ff); - return((arg2_type == sc->is_integer_symbol) ? f_2_fi : f_2_fx); - } - if (arg1_type == sc->is_integer_symbol) - { - if (arg2_type == sc->is_float_symbol) - return(f_2_if); - return((arg2_type == sc->is_integer_symbol) ? f_2_ii : f_2_ix); - } - if (arg2_type == sc->is_float_symbol) - return(f_2_xf); - if (arg2_type == sc->is_integer_symbol) - return(f_2_xi); - } - return(fallback); -} - -static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args); - -static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ - if (args != 2) return((args == 3) ? sc->add_3 : f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (arg2 == int_one) /* (+ ... 1) */ - return(sc->add_x1); - if ((is_t_integer(arg1)) && ((is_pair(arg2)) && (is_optimized(arg2)) && (is_h_safe_c_nc(arg2)) && (fn_proc(arg2) == g_random_i))) - { - set_opt3_int(cdr(expr), integer(cadr(arg2))); - set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* op if r op? */ - return(sc->add_i_random); - } - if (arg1 == int_one) - return(sc->add_1x); - return(chooser_check_arg_types(sc, arg1, arg2, sc->add_2, - sc->add_2_ff, sc->add_2_ii, sc->add_2_if, sc->add_2_fi, - sc->add_2_xi, sc->add_2_ix, sc->add_2_fx, sc->add_2_xf)); - } - return(sc->add_2); -} - -/* ---------------------------------------- subtract ---------------------------------------- */ -static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer p) /* can't use "negate" because it confuses C++! */ -{ - switch (type(p)) - { - case T_INTEGER: - if (integer(p) == S7_INT64_MIN) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, S7_INT64_MIN); - mpz_neg(sc->mpz_1, sc->mpz_1); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, p, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); -#endif - return(make_integer(sc, -integer(p))); - - case T_RATIO: return(make_simple_ratio(sc, -numerator(p), denominator(p))); - case T_REAL: return(make_real(sc, -real(p))); - case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(p), -imag_part(p))); - -#if WITH_GMP - case T_BIG_INTEGER: - mpz_neg(sc->mpz_1, big_integer(p)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_neg(sc->mpq_1, big_ratio(p)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_neg(sc->mpfr_1, big_real(p), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_neg(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->subtract_symbol, a_number_string)); - } -} - -static inline s7_pointer subtract_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (subtract_overflow(x, y, &val)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_set_si(sc->mpz_2, y); - mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_2); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (long_double)x - (long_double)y)); - } -#endif - return(make_integer(sc, val)); -#else - return(make_integer(sc, x - y)); -#endif -} - -static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) - return(negate_p_p(sc, y)); - switch (type(y)) - { - case T_INTEGER: - return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - - case T_RATIO: - { -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(x), denominator(y), &z)) || - (subtract_overflow(z, numerator(y), &z))) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(x)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); - mpz_set_si(sc->mpz_2, numerator(y)); - mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer - ratio overflow: (- %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, (long_double)integer(x) - fraction(y))); - } -#endif - return(make_ratio(sc, z, denominator(y))); -#else - return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); -#endif - } - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (- 9223372036854775807 .1) */ - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, integer(x)); - mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - { -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(y), denominator(x), &z)) || - (subtract_overflow(numerator(x), z, &z))) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(y)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x)); - mpz_set_si(sc->mpz_2, numerator(x)); - mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(x)); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - integer overflow: (- %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); - return(make_real(sc, fraction(x) - (long_double)integer(y))); - } -#endif - return(make_ratio(sc, z, denominator(x))); -#else - return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); -#endif - } - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - { -#if HAVE_OVERFLOW_CHECKS - s7_int q; - if (subtract_overflow(n1, n2, &q)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1)); - } -#endif - return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1)); -#else - return(make_ratio(sc, numerator(x) - numerator(y), denominator(x))); -#endif - } - -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1, d1d2, q; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1)) || - (subtract_overflow(n1d2, n2d1, &q))) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2))); - } -#endif - return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1d2)); - } -#else - return(make_ratio_with_div_check(sc, sc->subtract_symbol, n1 * d2 - n2 * d1, d1 * d2)); -#endif - } - case T_REAL: - return(make_real(sc, fraction(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, fraction(x) - real_part(y), -imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: -#if WITH_GMP - if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (- .1 92233720368547758071) */ - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ - case T_RATIO: - return(make_real(sc, real(x) - fraction(y))); - case T_REAL: - return(make_real(sc, real(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, real(x) - real_part(y), -imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - return(make_complex_not_0i(sc, real_part(x) - integer(y), imag_part(x))); - case T_RATIO: - return(make_complex_not_0i(sc, real_part(x) - fraction(y), imag_part(x))); - case T_REAL: - return(make_complex_not_0i(sc, real_part(x) - real(y), imag_part(x))); - case T_COMPLEX: - return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(y)); - mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_sub(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } -#endif - default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); - } -} - -static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args) -{ - #define H_subtract "(- x1 ...) subtracts its trailing arguments from the first, or negates the first if only one it is given" - #define Q_subtract sc->pcl_n - - s7_pointer x = car(args), p = cdr(args); - if (is_null(p)) - return(negate_p_p(sc, x)); - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = subtract_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args) {return(negate_p_p(sc, car(args)));} -static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args); - x = subtract_p_pp(sc, x, cadr(args)); - sc->error_argnum = 1; - x = subtract_p_pp(sc, x, caddr(args)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); - case T_RATIO: return(subtract_p_pp(sc, x, int_one)); - case T_REAL: return(make_real(sc, real(x) - 1.0)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, x, int_one)); -#endif - default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, int_one, a_number_string, 1)); - } - return(x); -} - -static s7_pointer g_subtract_x1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = car(args); -#if WITH_GMP - return(subtract_p_pp(sc, p, int_one)); -#endif - /* return((is_t_integer(p)) ? make_integer(sc, integer(p) - 1) : minus_c1(sc, p)); */ - return((is_t_integer(p)) ? subtract_if_overflow_to_real_or_big_integer(sc, integer(p), 1) : minus_c1(sc, p)); -} - -static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */ -{ - s7_pointer x = car(args); - s7_double n = real(cadr(args)); /* checked below is_t_real */ - if (is_t_real(x)) return(make_real(sc, real(x) - n)); - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, integer(x) - n)); - case T_RATIO: return(make_real(sc, fraction(x) - n)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - n, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, x, cadr(args))); -#endif - default: - return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); - } - return(x); -} - -static s7_pointer g_subtract_f2(s7_scheme *sc, s7_pointer args) /* (- f x) */ -{ - s7_pointer x = cadr(args); - s7_double n = real(car(args)); /* checked below is_t_real */ - - if (is_t_real(x)) return(make_real(sc, n - real(x))); - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, n - integer(x))); - case T_RATIO: return(make_real(sc, n - fraction(x))); - case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, car(args), x)); -#endif - default: - return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); - } - return(x); -} - -static s7_int subtract_i_ii(s7_int i1, s7_int i2) {return(i1 - i2);} -static s7_int subtract_i_i(s7_int x) {return(-x);} -static s7_int subtract_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 - i2 - i3);} - -static s7_double subtract_d_d(s7_double x) {return(-x);} -static s7_double subtract_d_dd(s7_double x1, s7_double x2) {return(x1 - x2);} -static s7_double subtract_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 - x2 - x3);} -static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 - x2 - x3 - x4);} - -static s7_pointer subtract_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 - x2));} -static s7_pointer subtract_p_ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(make_integer(sc, i1 - i2));} - -static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if (is_t_integer(x)) - return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), y)); - - switch (type(x)) - { - case T_RATIO: return(make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x))); - case T_REAL: return(make_real(sc, real(x) - y)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - y, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, y); - mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(subtract_p_pp(sc, x, wrap_integer(sc, y))); -#endif - default: return(method_or_bust_with_type_pi(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); - } - return(x); -} - -static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args == 1) return(sc->subtract_1); - if (args != 2) return((args == 3) ? sc->subtract_3 : f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (arg2 == int_one) return(sc->subtract_x1); - if (is_t_real(arg1)) return(sc->subtract_f2); - if (is_t_real(arg2)) return(sc->subtract_2f); - } - return(sc->subtract_2); -} - - -/* ---------------------------------------- multiply ---------------------------------------- */ -#define QUOTIENT_FLOAT_LIMIT 1e13 -#define QUOTIENT_INT_LIMIT 10000000000000 -/* fraction(x) is not accurate enough if it involves numbers over e18 even when done with long_doubles */ - -static inline s7_pointer multiply_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (multiply_overflow(x, y, &val)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_mul_si(sc->mpz_1, sc->mpz_1, y); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (s7_double)x * (s7_double)y)); - } -#endif - return(make_integer(sc, val)); -#else - return(make_integer(sc, x * y)); -#endif -} - -static s7_pointer integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme *sc, s7_int x, s7_pointer y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if (multiply_overflow(x, numerator(y), &z)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_mul_si(sc->mpz_1, sc->mpz_1, numerator(y)); - mpq_set_si(sc->mpq_1, 1, denominator(y)); - mpq_set_num(sc->mpq_1, sc->mpz_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", x, numerator(y), denominator(y)); - return(make_real(sc, (s7_double)x * fraction(y))); - } -#endif - return(make_ratio(sc, z, denominator(y))); -#else - return(make_ratio(sc, x * numerator(y), denominator(y))); -#endif -} - -static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(x), y)); - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) * real(y))); - case T_COMPLEX: - return(s7_make_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(y), integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(y), x)); - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1n2, d1d2; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, n2, &n1n2))) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, fraction(x) * fraction(y))); - } -#endif - return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1n2, d1d2)); - } -#else - return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1 * n2, d1 * d2)); -#endif - } - case T_REAL: -#if WITH_GMP - if (numerator(x) > QUOTIENT_INT_LIMIT) - { - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, fraction(x) * real(y))); - case T_COMPLEX: - return(s7_make_complex(sc, fraction(x) * real_part(y), fraction(x) * imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: -#if WITH_GMP - if (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) * (long_double)integer(y))); - case T_RATIO: -#if WITH_GMP - if (numerator(y) > QUOTIENT_INT_LIMIT) - { - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, fraction(y) * real(x))); - case T_REAL: - return(make_real(sc, real(x) * real(y))); - case T_COMPLEX: - return(make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - return(make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y))); - case T_RATIO: - return(s7_make_complex(sc, real_part(x) * fraction(y), imag_part(x) * fraction(y))); - case T_REAL: - return(make_complex(sc, real_part(x) * real(y), imag_part(x) * real(y))); - case T_COMPLEX: - { - s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y); - return(make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); - } -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(x), integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_mul(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* 0.0? */ - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } -#endif - default: - return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); - } -} - -static s7_pointer multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) -{ - x = multiply_p_pp(sc, x, y); - sc->error_argnum = 1; - x = multiply_p_pp(sc, x, z); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer multiply_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer args, s7_pointer typ, int32_t num) -{ - if (has_active_methods(sc, obj)) - return(find_and_apply_method(sc, obj, sc->multiply_symbol, args)); - if (num == 0) - sole_arg_wrong_type_error_nr(sc, sc->multiply_symbol, obj, typ); - wrong_type_error_nr(sc, sc->multiply_symbol, num, obj, typ); - return(NULL); -} - -static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args) -{ - #define H_multiply "(* ...) multiplies its arguments" - #define Q_multiply sc->pcl_n - - s7_pointer x, p; - if (is_null(args)) - return(int_one); - x = car(args); - p = cdr(args); - if (is_null(p)) - { - if (!is_number(x)) - return(multiply_method_or_bust(sc, x, args, a_number_string, 0)); - return(x); - } - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = multiply_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, int32_t loc) -{ - switch (type(x)) - { - case T_INTEGER: return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), n)); - case T_RATIO: return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, n, x)); - case T_REAL: return(make_real(sc, real(x) * n)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n)); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(x), n); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(multiply_p_pp(sc, x, wrap_integer(sc, n))); -#endif - default: - /* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */ - return(method_or_bust_with_type_pi(sc, x, sc->multiply_symbol, x, n, a_number_string, loc)); - } - return(x); -} - -static s7_pointer multiply_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_mul_xi(sc, p1, i1, 1));} - -static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t num) -{ - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, integer(x) * y)); - case T_RATIO: return(make_real(sc, numerator(x) * y / denominator(x))); - case T_REAL: return(make_real(sc, real(x) * y)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * y, imag_part(x) * y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul_d(sc->mpfr_1, big_real(x), y, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: return(method_or_bust_with_type_pf(sc, x, sc->multiply_symbol, x, y, a_number_string, num)); - } - return(x); -} - -#if WITH_GMP -static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) { - if ((is_t_integer(car(args))) && (is_t_real(cadr(args)))) - return(make_real(sc, integer(car(args)) * real(cadr(args)))); - return(multiply_p_pp(sc, car(args), cadr(args))); -} - -static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args) -{ - if ((is_t_integer(cadr(args))) && (is_t_real(car(args)))) - return(make_real(sc, real(car(args)) * integer(cadr(args)))); - return(multiply_p_pp(sc, car(args), cadr(args))); -} - -static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {if (is_t_integer(cadr(args))) return(g_mul_xi(sc, car(args), integer(cadr(args)), 1)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {if (is_t_integer(car(args))) return(g_mul_xi(sc, cadr(args), integer(car(args)), 2)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {if (is_t_real(cadr(args))) return(g_mul_xf(sc, car(args), real(cadr(args)), 1)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {if (is_t_real(car(args))) return(g_mul_xf(sc, cadr(args), real(car(args)), 2)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_ff(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));} -#else -static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) * real(cadr(args))));} -static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * integer(cadr(args))));} -static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, car(args), integer(cadr(args)), 1));} -static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, cadr(args), integer(car(args)), 2));} -static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, car(args), real(cadr(args)), 1));} /* split out t_real is slower */ -static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, cadr(args), real(car(args)), 2));} -static s7_pointer g_mul_2_ff(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * real(cadr(args))));} - -static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val, x = integer(car(args)), y = integer(cadr(args)); - if (multiply_overflow(x, y, &val)) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (s7_double)x * (s7_double)y)); - } - return(make_integer(sc, val)); -#else - return(make_integer(sc, integer(car(args)) * integer(cadr(args)))); -#endif -} -#endif - -static s7_int multiply_i_ii(s7_int i1, s7_int i2) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (multiply_overflow(i1, i2, &val)) - { -#if WITH_WARNINGS - s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", i1, i2); -#endif - return(S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */ - } - /* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */ - return(val); -#else - return(i1 * i2); -#endif -} - -static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val1, val2; - if ((multiply_overflow(i1, i2, &val1)) || - (multiply_overflow(val1, i3, &val2))) - { -#if WITH_WARNINGS - s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", i1, i2, i3); -#endif - return(S7_INT64_MAX); - } - return(val2); -#else - return(i1 * i2 * i3); -#endif -} - -static s7_double multiply_d_d(s7_double x) {return(x);} -static s7_double multiply_d_dd(s7_double x1, s7_double x2) {return(x1 * x2);} -static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 * x2 * x3);} -static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 * x2 * x3 * x4);} -static s7_pointer mul_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 * x2));} - -static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - return(chooser_check_arg_types(sc, cadr(expr), caddr(expr), sc->multiply_2, - sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, sc->mul_2_fi, - sc->mul_2_xi, sc->mul_2_ix, sc->mul_2_fx, sc->mul_2_xf)); - return(sc->multiply_2); -} - - -/* ---------------------------------------- divide ---------------------------------------- */ -static s7_pointer complex_invert(s7_scheme *sc, s7_pointer p) -{ - s7_double r2 = real_part(p), i2 = imag_part(p); - s7_double den = (r2 * r2 + i2 * i2); - /* here if p is, for example, -inf.0+i, den is +inf.0 so -i2/den is -0.0 (in gcc anyway), so the imag part is 0.0 */ - return(s7_make_complex(sc, r2 / den, -i2 / den)); -} - -static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) -{ -#if WITH_GMP - s7_pointer x; -#endif - switch (type(p)) - { - case T_INTEGER: -#if WITH_GMP && (!POINTER_32) - if (integer(p) == S7_INT64_MIN) /* (/ 1 (*s7* 'most-negative-fixnum)) -> -1/9223372036854775808 */ - { - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpz_set_si(sc->mpz_1, S7_INT64_MAX); - mpz_set_si(sc->mpz_2, 1); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - mpq_set_si(big_ratio(x), -1, 1); - mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */ - return(x); - } -#endif - if (integer(p) == 0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - return(make_simple_ratio(sc, 1, integer(p))); /* this checks for int */ - case T_RATIO: - return(make_simple_ratio(sc, denominator(p), numerator(p))); - case T_REAL: - if (real(p) == 0.0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - return(make_real(sc, 1.0 / real(p))); - case T_COMPLEX: - return(complex_invert(sc, p)); - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p), 0) == 0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - if ((mpz_cmp_ui(big_integer(p), 1) == 0) || (mpz_cmp_si(big_integer(p), -1) == 0)) - return(p); - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set_si(big_ratio(x), 1, 1); - mpq_set_den(big_ratio(x), big_integer(p)); - mpq_canonicalize(big_ratio(x)); - return(x); - - case T_BIG_RATIO: - if (mpz_cmp_ui(mpq_numref(big_ratio(p)), 1) == 0) - return(mpz_to_integer(sc, mpq_denref(big_ratio(p)))); - if (mpz_cmp_si(mpq_numref(big_ratio(p)), -1) == 0) - { - mpz_neg(sc->mpz_1, mpq_denref(big_ratio(p))); - return(mpz_to_integer(sc, sc->mpz_1)); - } - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_inv(big_ratio(x), big_ratio(p)); - mpq_canonicalize(big_ratio(x)); - return(x); - - case T_BIG_REAL: - if (mpfr_zero_p(big_real(p))) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - x = mpfr_to_big_real(sc, big_real(p)); - mpfr_ui_div(big_real(x), 1, big_real(x), MPFR_RNDN); - return(x); - - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(p)))) || (!mpfr_number_p(mpc_imagref(big_complex(p))))) - return(complex_NaN); - mpc_ui_div(sc->mpc_1, 1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */ -#endif - default: - check_method(sc, p, sc->divide_symbol, set_plist_1(sc, p)); - wrong_type_error_nr(sc, sc->divide_symbol, 1, p, a_number_string); - } - return(NULL); -} - -static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - /* splitting out real/real here saves very little */ - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - /* -------- integer x -------- */ - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */ - return(invert_p_p(sc, y)); - return(make_ratio(sc, integer(x), integer(y))); - - case T_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(integer(x), denominator(y), &dn)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_set_si(sc->mpq_2, numerator(y), denominator(y)); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer / ratio overflow: (/ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, integer(x) * inverted_fraction(y))); - } -#endif - return(make_ratio_with_div_check(sc, sc->divide_symbol, dn, numerator(y))); - } -#else - return(make_ratio_with_div_check(sc, sc->divide_symbol, integer(x) * denominator(y), numerator(y))); -#endif - - case T_REAL: - if (is_NaN(real(y))) return(y); - if (is_inf(real(y))) return(real_zero); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); -#if WITH_GMP - if ((s7_int_abs(integer(x))) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (s7_double)(integer(x)) / real(y))); - - case T_COMPLEX: - { - s7_double den, r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y); - den = 1.0 / (r2 * r2 + i2 * i2); - /* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */ - return(s7_make_complex(sc, r1 * r2 * den, -(r1 * i2 * den))); - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_set_den(sc->mpq_1, big_integer(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - break; - - /* -------- ratio x -------- */ - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(denominator(x), integer(y), &dn)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_si(sc->mpq_2, integer(y), 1); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) - s7_warn(sc, 128, "ratio / integer overflow: (/ %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); - return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y)))); - } -#endif - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), dn)); - } -#else - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), denominator(x) * integer(y))); -#endif - - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, n2)); -#if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(n1, d2, &n1)) || - (multiply_overflow(n2, d1, &d1))) - { -#if WITH_GMP - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */ - mpq_set_si(sc->mpq_2, n2, d2); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); -#else - s7_double r1, r2; - if (WITH_WARNINGS) - s7_warn(sc, 128, "ratio / ratio overflow: (/ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", numerator(x), denominator(x), numerator(y), denominator(y)); - r1 = fraction(x); - r2 = inverted_fraction(y); - return(make_real(sc, r1 * r2)); -#endif - } - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, d1)); -#else - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1 * d2, n2 * d1)); -#endif - } - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - return(make_real(sc, fraction(x) / real(y))); - - case T_COMPLEX: - { - s7_double rx = fraction(x), r2 = real_part(y), i2 = imag_part(y); - s7_double den = 1.0 / (r2 * r2 + i2 * i2); - return(s7_make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_set_si(sc->mpq_2, numerator(x), denominator(x)); - mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - - /* -------- real x -------- */ - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (is_NaN(real(x))) return(x); /* what is (/ +nan.0 0)? */ - if (is_inf(real(x))) - return((real(x) > 0.0) ? ((integer(y) > 0) ? real_infinity : real_minus_infinity) : ((integer(y) > 0) ? real_minus_infinity : real_infinity)); - return(make_real(sc, (long_double)real(x) / (long_double)integer(y))); - - case T_RATIO: - if (is_NaN(real(x))) return(x); - if (is_inf(real(x))) - return((real(x) > 0) ? ((numerator(y) > 0) ? real_infinity : real_minus_infinity) : ((numerator(y) > 0) ? real_minus_infinity : real_infinity)); - return(make_real(sc, real(x) * inverted_fraction(y))); - - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (is_NaN(real(x))) return(x); - if (is_inf(real(y))) - return((is_inf(real(x))) ? real_NaN : real_zero); - return(make_real(sc, real(x) / real(y))); - - case T_COMPLEX: - { - s7_double den, r2, i2; - if (is_NaN(real(x))) return(complex_NaN); - r2 = real_part(y); - i2 = imag_part(y); - if ((is_NaN(r2)) || (is_inf(r2))) return(complex_NaN); - if ((is_NaN(i2)) || (is_inf(i2))) return(complex_NaN); - den = 1.0 / (r2 * r2 + i2 * i2); - return(s7_make_complex(sc, real(x) * r2 * den, -real(x) * i2 * den)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_d_div(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((is_NaN(real(x))) || (!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - - /* -------- complex x -------- */ - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - { - s7_double r1; - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - r1 = (long_double)1.0 / (long_double)integer(y); - return(s7_make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); - } - - case T_RATIO: - { - s7_double frac = inverted_fraction(y); - return(make_complex(sc, real_part(x) * frac, imag_part(x) * frac)); - } - - case T_REAL: - { - s7_double r1; - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - r1 = 1.0 / real(y); - return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */ - } - - case T_COMPLEX: - { - s7_double r1 = real_part(x), r2, i1, i2, den; - if (is_NaN(r1)) return(x); - i1 = imag_part(x); - if (is_NaN(i1)) return(x); - r2 = real_part(y); - if (is_NaN(r2)) return(y); - if (is_inf(r2)) return(complex_NaN); - i2 = imag_part(y); - if (is_NaN(i2)) return(y); - den = 1.0 / (r2 * r2 + i2 * i2); - return(s7_make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpz_set_si(sc->mpz_1, integer(y)); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_set_den(sc->mpq_1, sc->mpz_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */ - mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_set_den(sc->mpq_1, big_integer(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, 0, 1); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } -#endif - - default: /* x is not a built-in number */ - return(method_or_bust_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */ - } - return(NULL); /* make the compiler happy */ -} - -static s7_pointer g_divide(s7_scheme *sc, s7_pointer args) -{ - #define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument" - #define Q_divide sc->pcl_n - - s7_pointer x = car(args), p = cdr(args); - if (is_null(p)) /* (/ x) */ - { - if (!is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->divide_symbol, a_number_string)); - return(invert_p_p(sc, x)); - } - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = divide_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args) {return(invert_p_p(sc, car(args)));} -static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args) {return(divide_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) -{ - /* (/ x 2) */ - s7_pointer num = car(args); - if (is_t_integer(num)) - { - s7_int i = integer(num); - if (i & 1) - { - s7_pointer x; - new_cell(sc, x, T_RATIO); - numerator(x) = i; - denominator(x) = 2; - return(x); - } - return(make_integer(sc, i >> 1)); - } - switch (type(num)) - { - case T_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(denominator(num), 2, &dn)) - { - if ((numerator(num) & 1) == 1) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); - mpq_set_si(sc->mpq_2, 1, 2); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / 2 overflow: (/ %" ld64 "/%" ld64 " 2)\n", numerator(num), denominator(num)); - return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num))); - } -#endif - return(make_ratio(sc, numerator(num) / 2, denominator(num))); - } - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(num), dn)); - } -#else - return(make_ratio(sc, numerator(num), denominator(num) * 2)); -#endif - - case T_REAL: return(make_real(sc, real(num) * 0.5)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(num) * 0.5, imag_part(num) * 0.5)); - -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(num)); - mpz_mul_ui(mpq_denref(sc->mpq_1), mpq_denref(sc->mpq_1), 2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, 2, 1); - mpq_div(sc->mpq_1, big_ratio(num), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_div_si(sc->mpfr_1, big_real(num), 2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, 2, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(num), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_pp(sc, num, sc->divide_symbol, num, int_two, a_number_string, 1)); - } -} - -static s7_pointer g_invert_x(s7_scheme *sc, s7_pointer args) -{ - /* (/ 1.0 x) */ - s7_pointer x = cadr(args); - if (is_t_real(x)) - { - s7_double rl = real(x); - if (rl == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, car(args), x); - return((is_NaN(rl)) ? x : make_real(sc, 1.0 / rl)); - } - return(g_divide(sc, args)); -} - -static s7_double divide_d_7d(s7_scheme *sc, s7_double x) -{ - if (x == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero); - return(1.0 / x); -} - -static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) -{ - if (x2 == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero); - return(x1 / x2); -} - -static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(make_ratio_with_div_check(sc, sc->divide_symbol, x, y));} -static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(make_ratio_with_div_check(sc, sc->divide_symbol, 1, x));} - -static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args == 1) - return(sc->invert_1); - if ((ops) && (args == 2)) - { - s7_pointer arg1 = cadr(expr); - if ((is_t_real(arg1)) && (real(arg1) == 1.0)) - return(sc->invert_x); - return(((is_t_integer(caddr(expr))) && (integer(caddr(expr)) == 2)) ? sc->divide_by_2 : sc->divide_2); - } - return(f); -} - - -/* -------------------------------- quotient -------------------------------- */ -static inline s7_int quotient_i_7ii(s7_scheme *sc, s7_int x, s7_int y) -{ - if ((y > 0) || (y < -1)) return(x / y); - if (y == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_integer(sc, x), int_zero); - if (x == S7_INT64_MIN) /* (quotient most-negative-fixnum -1) */ - sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, set_elist_2(sc, leastfix, minus_one), it_is_too_large_string); - return(-x); /* (quotient x -1) */ -} - -#if (!WITH_GMP) -static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_double xf) /* can't use "truncate" -- it's in unistd.h */ -{ - if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, caller, wrap_real(sc, xf), it_is_too_large_string); - return(make_integer(sc, (xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf))); -} - -static s7_int c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y) -{ - s7_double xf; - if (y == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_real(sc, x), real_zero); - if ((is_inf(y)) || (is_NaN(y))) /* here we can't return NAN so I guess we should signal an error */ - wrong_type_error_nr(sc, sc->quotient_symbol, 2, wrap_real(sc, y), a_normal_real_string); - xf = x / y; - if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, wrap_real(sc, xf), it_is_too_large_string); - return((xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf)); -} -#endif - -static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */ - -static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - if ((is_real(x)) && (is_real(y))) - { - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if ((s7_is_integer(x)) && (s7_is_integer(y))) - { - if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); - if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); - mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2); - } - else - if ((!is_rational(x)) || (!is_rational(y))) - { - if (any_real_to_mpfr(sc, x, sc->mpfr_1)) return(real_NaN); - if (any_real_to_mpfr(sc, y, sc->mpfr_2)) return(real_NaN); - mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); - } - else - { - any_rational_to_mpq(sc, x, sc->mpq_1); - any_rational_to_mpq(sc, y, sc->mpq_2); - mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); - mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - } - return(mpz_to_integer(sc, sc->mpz_1)); - } - return(method_or_bust_pp(sc, (is_real(x)) ? y : x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1)); -#else - - s7_int d1, d2, n1, n2; - if ((is_t_integer(x)) && (is_t_integer(y))) - return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y)))); - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - /* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */ - goto RATIO_QUO_RATIO; - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */ - - default: - return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - n1 = numerator(x); - d1 = denominator(x); - n2 = integer(y); - d2 = 1; - goto RATIO_QUO_RATIO; - /* this can lose: - * (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1 - * (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0 - */ - - case T_RATIO: - parcel_out_fractions(x, y); - RATIO_QUO_RATIO: - if (d1 == d2) - return(make_integer(sc, n1 / n2)); /* (quotient 3/9223372036854775807 1/9223372036854775807) */ - if (n1 == n2) - return(make_integer(sc, d2 / d1)); /* (quotient 9223372036854775807/2 9223372036854775807/8) */ -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1; - if ((multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1))) - return(s7_truncate(sc, sc->quotient_symbol, ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1))); - return(make_integer(sc, n1d2 / n2d1)); - } -#else - return(make_integer(sc, (n1 * d2) / (n2 * d1))); -#endif - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y))); - - default: - return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_REAL: - if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) - return(real_NaN); - /* if infs allowed we need to return infs/nans, else: - * (quotient inf.0 1e-309) -> -9223372036854775808 - * (quotient inf.0 inf.0) -> -9223372036854775808 - */ - - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - return(s7_truncate(sc, sc->quotient_symbol, (long_double)real(x) / (long_double)integer(y))); - - case T_RATIO: return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y))); - case T_REAL: return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ - default: return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - default: - return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } -#endif -} - -static s7_pointer quotient_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if ((is_t_integer(x)) && ((y > 0) || (y < -1))) return(make_integer(sc, integer(x) / y)); - return(quotient_p_pp(sc, x, wrap_integer(sc, y))); -} - -static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) -{ - #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" - #define Q_quotient sc->pcl_r - /* sig was '(integer? ...) but quotient can return NaN */ - /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */ - return(quotient_p_pp(sc, car(args), cadr(args))); -} - - -/* -------------------------------- remainder -------------------------------- */ -#if WITH_GMP -static s7_pointer big_mod_or_rem(s7_scheme *sc, s7_pointer x, s7_pointer y, bool use_floor) -{ - if ((is_real(x)) && (is_real(y))) - { - if ((s7_is_integer(x)) && (s7_is_integer(y))) - { - if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); - if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); - if (use_floor) - mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); - else mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); - mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2); - mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3); - return(mpz_to_integer(sc, sc->mpz_1)); - } - if ((!is_rational(x)) || (!is_rational(y))) - { - any_real_to_mpfr(sc, x, sc->mpfr_1); - any_real_to_mpfr(sc, y, sc->mpfr_2); - mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - if (use_floor) - mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD); - else mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); - mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - any_rational_to_mpq(sc, x, sc->mpq_1); - any_rational_to_mpq(sc, y, sc->mpq_2); - mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); - if (use_floor) - mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - else mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - mpz_mul(mpq_numref(sc->mpq_2), sc->mpz_1, mpq_numref(sc->mpq_2)); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } - return(method_or_bust_pp(sc, (is_real(x)) ? y : x, (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1)); -} -#endif - -#define REMAINDER_FLOAT_LIMIT 1e13 - -static inline s7_int remainder_i_7ii(s7_scheme *sc, s7_int x, s7_int y) -{ - if ((y > 1) || (y < -1)) return(x % y); /* avoid floating exception if (remainder -9223372036854775808 -1)! */ - if (y == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_integer(sc, x), int_zero); - return(0); -} - -static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y) -{ - s7_int quo; - s7_double pre_quo; - if ((is_inf(y)) || (is_NaN(y))) - return(NAN); - pre_quo = x / y; - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, wrap_real(sc, x), wrap_real(sc, y)), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(x - (y * quo)); -} - -static s7_int remainder_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 % i2);} /* i2 > 1 */ -static s7_double remainder_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) -{ - if (x2 == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_real(sc, x1), real_zero); - if ((is_inf(x1)) || (is_NaN(x1))) /* match remainder_p_pp */ - return(NAN); - return(c_rem_dbl(sc, x1, x2)); -} - -static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(big_mod_or_rem(sc, x, y, false)); -#else - s7_int quo, d1, d2, n1, n2; - s7_double pre_quo; - - if ((is_t_integer(x)) && (is_t_integer(y))) - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - goto RATIO_REM_RATIO; - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - pre_quo = (long_double)integer(x) / (long_double)real(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, integer(x) - real(y) * quo)); - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - n2 = integer(y); - if (n2 == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - n1 = numerator(x); - d1 = denominator(x); - d2 = 1; - goto RATIO_REM_RATIO; - - case T_RATIO: - parcel_out_fractions(x, y); - RATIO_REM_RATIO: - if (d1 == d2) - quo = (s7_int)(n1 / n2); - else - { - if (n1 == n2) - quo = (s7_int)(d2 / d1); - else - { -#if HAVE_OVERFLOW_CHECKS - s7_int n1d2, n2d1; - if ((multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1))) - { - pre_quo = ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - } - else quo = n1d2 / n2d1; -#else - quo = (n1 * d2) / (n2 * d1); -#endif - }} - if (quo == 0) - return(x); - -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn, nq; - if (!multiply_overflow(n2, quo, &nq)) - { - if ((d1 == d2) && - (!subtract_overflow(n1, nq, &dn))) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, dn, d1)); - - if ((!multiply_overflow(n1, d2, &dn)) && - (!multiply_overflow(nq, d1, &nq)) && - (!subtract_overflow(dn, nq, &nq)) && - (!multiply_overflow(d1, d2, &d1))) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, nq, d1)); - }} -#else - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 - n2 * quo, d1)); - - return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 * d2 - n2 * d1 * quo, d1 * d2)); -#endif - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), intermediate_too_large_string); - - case T_REAL: - { - s7_double frac; - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT) - return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); - frac = (s7_double)fraction(x); - pre_quo = frac / real(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, frac - real(y) * quo)); - } - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_REAL: - if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) - { - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(real_NaN); - } - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - /* actually here (and elsewhere) if y > INT64_TO_DOUBLE_LIMIT, the result is probably wrong */ - pre_quo = (long_double)real(x) / (long_double)integer(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, real(x) - integer(y) * quo)); - /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */ - - case T_RATIO: - if (s7_int_abs(numerator(y)) > QUOTIENT_INT_LIMIT) - return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); - { - s7_double frac = (s7_double)fraction(y); - pre_quo = real(x) / frac; - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, real(x) - frac * quo)); - } - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(make_real(sc, c_rem_dbl(sc, real(x), real(y)))); - /* see under sin -- this calculation is completely bogus if "a" is large - * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688, - * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument! - * Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range). - */ - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - default: - return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 1)); - } -#endif -} - -static s7_pointer remainder_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if ((is_t_integer(x)) && ((y > 1) || (y < -1))) return(make_integer(sc, integer(x) % y)); - return(remainder_p_pp(sc, x, wrap_integer(sc, y))); -} - -static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) -{ - #define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1" - #define Q_remainder sc->pcl_r - /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */ - - s7_pointer x = car(args), y = cadr(args); - if ((is_t_integer(x)) && (is_t_integer(y))) - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - return(remainder_p_pp(sc, x, y)); -} - - -/* -------------------------------- modulo -------------------------------- */ -static s7_int modulo_i_ii(s7_int x, s7_int y) -{ - s7_int z; - if (y > 1) - { - z = x % y; - return((z >= 0) ? z : z + y); - } - if (y < -1) - { - z = x % y; - return((z > 0) ? z + y : z); - } - if (y == 0) return(x); /* else arithmetic exception */ - return(0); -} - -static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2) /* here we know i2 > 1 */ -{ - s7_int z = i1 % i2; - return((z < 0) ? (z + i2) : z); -} - -static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) -{ - s7_double c; - if ((is_NaN(x1)) || (is_NaN(x2)) || (is_inf(x1)) || (is_inf(x2))) return(NAN); - if (x2 == 0.0) return(x1); - if (fabs(x1) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, wrap_real(sc, x1), it_is_too_large_string); - c = x1 / x2; - if ((c > 1e19) || (c < -1e19)) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, wrap_real(sc, x1), wrap_real(sc, x2)), - intermediate_too_large_string); - return(x1 - x2 * (s7_int)floor(c)); -} - -static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - /* as tricky as expt, so just use bignums; mpz_mod|_ui = mpz_fdiv_r_ui, but sign ignored -- probably not worth the code - * originally subtract_p_pp(sc, x, multiply_p_pp(sc, y, floor_p_p(sc, divide_p_pp(sc, x, y)))) - * quotient is truncate_p_p(sc, divide_p_pp(sc, x, y)) - * remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y))) - */ - if (!is_zero(y)) return(big_mod_or_rem(sc, x, y, true)); - if (is_real(x)) return(x); - return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1)); -#else - s7_double a, b; - s7_int n1, n2, d1, d2; - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, modulo_i_ii(integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - if ((n1 == n2) && (d1 > d2)) return(x); /* signs match so this should be ok */ - goto RATIO_MOD_RATIO; - - case T_REAL: - if ((integer(x) == S7_INT64_MIN) || (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT)) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); - b = real(y); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - if (is_inf(b)) return(real_NaN); - a = (s7_double)integer(x); - goto REAL_MOD; - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) return(x); - n1 = numerator(x); - d1 = denominator(x); - n2 = integer(y); - - if ((n2 > 0) && (n1 > 0) && (n2 > n1)) return(x); - if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x); - if (n2 == S7_INT64_MIN) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - /* the problem here is that (modulo 3/2 most-negative-fixnum) - * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it. - */ - if ((n1 == n2) && (d1 > 1)) return(x); - d2 = 1; - goto RATIO_MOD_RATIO; - - case T_RATIO: - parcel_out_fractions(x, y); - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->modulo_symbol, modulo_i_ii(n1, n2), d1)); - if ((n1 == n2) && (d1 > d2)) return(x); - - RATIO_MOD_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int n2d1, n1d2, d1d2, fl; - if (!multiply_overflow(n2, d1, &n2d1)) - { - if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */ - return(int_zero); - - if (!multiply_overflow(n1, d2, &n1d2)) - { - fl = (s7_int)(n1d2 / n2d1); - if (((n1 < 0) && (n2 > 0)) || - ((n1 > 0) && (n2 < 0))) - fl -= 1; - if (fl == 0) - return(x); - - if ((!multiply_overflow(d1, d2, &d1d2)) && - (!multiply_overflow(fl, n2d1, &fl)) && - (!subtract_overflow(n1d2, fl, &fl))) - return(make_ratio_with_div_check(sc, sc->modulo_symbol, fl, d1d2)); - }}} -#else - { - s7_int fl; - s7_int n1d2 = n1 * d2; - s7_int n2d1 = n2 * d1; - - if (n2d1 == 1) - return(int_zero); - - /* can't use "floor" here (float->int ruins everything) */ - fl = (s7_int)(n1d2 / n2d1); - if (((n1 < 0) && (n2 > 0)) || - ((n1 > 0) && (n2 < 0))) - fl -= 1; - - if (fl == 0) - return(x); - - return(make_ratio_with_div_check(sc, sc->modulo_symbol, n1d2 - (n2d1 * fl), d1 * d2)); - } -#endif - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - case T_REAL: - b = real(y); - if (is_inf(b)) return(real_NaN); - if (fabs(b) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - a = fraction(x); - return(make_real(sc, a - b * (s7_int)floor(a / b))); - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_REAL: - { - s7_double c; - a = real(x); - if (!is_real(y)) - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - if (is_NaN(a)) return(x); - if (is_inf(a)) return(real_NaN); /* not b */ - if (fabs(a) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); - - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) return(x); - if ((integer(y) == S7_INT64_MIN) || (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT)) - out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); - b = (s7_double)integer(y); - goto REAL_MOD; - - case T_RATIO: - b = fraction(y); - goto REAL_MOD; - - case T_REAL: - b = real(y); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - if (is_inf(b)) return(real_NaN); - REAL_MOD: - c = a / b; - if (fabs(c) > 1e19) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - return(make_real(sc, a - b * (s7_int)floor(c))); - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - }} - - default: - return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1)); - } -#endif -} - -static s7_pointer modulo_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if (is_t_integer(x)) return(make_integer(sc, modulo_i_ii(integer(x), y))); - return(modulo_p_pp(sc, x, wrap_integer(sc, y))); -} - -static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args) -{ - #define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1. The arguments can be real numbers." - #define Q_modulo sc->pcl_r - /* (define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) from slib - * (mod x 0) = x according to "Concrete Mathematics" - */ - return(modulo_p_pp(sc, car(args), cadr(args))); -} - - -/* ---------------------------------------- max ---------------------------------------- */ -static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p) -{ - s7_pointer f = find_method_with_let(sc, p, sc->is_real_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - return(false); -} - -#define is_real_via_method(sc, p) ((is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p)))) - -#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, sc->type_names[T_REAL], 1) -#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, sc->type_names[T_REAL], 2) - -static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - /* same basic code as lt_b_7_pp (or any relop) but max returns NaN if NaN encountered, and methods for < and max return - * different results, so it seems simpler to repeat the other code. - */ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return((integer(x) < integer(y)) ? y : x); - if (is_t_real(x)) - return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); - if (is_t_ratio(x)) - return((fraction(x) < fraction(y)) ? y : x); -#if WITH_GMP - if (is_t_big_integer(x)) - return((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x); - if (is_t_big_ratio(x)) - return((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x); - if (is_t_big_real(x)) - return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: - return((integer(x) < fraction(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((integer(x) < real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - return((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((fraction(x) < integer(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((fraction(x) < real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - if (is_NaN(real(x))) return(x); - return((real(x) < integer(y)) ? y : x); - case T_RATIO: - return((real(x) < fraction(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x); - case T_BIG_REAL: - if (is_NaN(real(x))) return(x); - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y); - default: - return(max_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x); - case T_RATIO: - return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); - case T_BIG_INTEGER: - return((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y); - default: - return(max_out_y(sc, x, y)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x); - case T_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x); - case T_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - if (is_NaN(real(y))) return(y); - return((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x); - case T_BIG_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x); - default: - return(max_out_y(sc, x, y)); - } -#endif - default: - return(max_out_x(sc, x, y)); - } - return(x); -} - -static s7_pointer g_max(s7_scheme *sc, s7_pointer args) -{ - #define H_max "(max ...) returns the maximum of its arguments" - #define Q_max sc->pcl_r - - s7_pointer x = car(args); - if (is_null(cdr(args))) - { - if (is_real(x)) return(x); - return(method_or_bust_p(sc, x, sc->max_symbol, sc->type_names[T_REAL])); - } - for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p)) - x = max_p_pp(sc, x, car(p)); - return(x); -} - -static s7_pointer g_max_2(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_max_3(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));} - -static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f)); -} - -static s7_int max_i_ii(s7_int i1, s7_int i2) {return((i1 > i2) ? i1 : i2);} -static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));} -static s7_double max_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 > x2) ? x1 : x2);} -static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(max_d_dd(x1, max_d_dd(x2, x3)));} -static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(max_d_dd(x1, max_d_ddd(x2, x3, x4)));} - - -/* ---------------------------------------- min ---------------------------------------- */ -#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, sc->type_names[T_REAL], 1) -#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, sc->type_names[T_REAL], 2) - -static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return((integer(x) > integer(y)) ? y : x); - if (is_t_real(x)) - return(((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); - if (is_t_ratio(x)) - return((fraction(x) > fraction(y)) ? y : x); -#if WITH_GMP - if (is_t_big_integer(x)) - return((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x); - if (is_t_big_ratio(x)) - return((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x); - if (is_t_big_real(x)) - return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return((integer(x) > fraction(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((integer(x) > real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y); - case T_BIG_RATIO: return((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((fraction(x) > integer(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((fraction(x) > real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - if (is_NaN(real(x))) return(x); - return((real(x) > integer(y)) ? y : x); - case T_RATIO: - return((real(x) > fraction(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x); - - case T_BIG_RATIO: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x); - - case T_BIG_REAL: - if (is_NaN(real(x))) return(x); - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y); - default: - return(min_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x); - case T_RATIO: - return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); - case T_BIG_INTEGER: - return((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y); - default: - return(min_out_y(sc, x, y)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x); - case T_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x); - case T_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - if (is_NaN(real(y))) return(y); - return((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x); - case T_BIG_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x); - case T_BIG_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x); - default: - return(min_out_y(sc, x, y)); - } -#endif - default: - return(min_out_x(sc, x, y)); - } - return(x); -} - -static s7_pointer g_min(s7_scheme *sc, s7_pointer args) -{ - #define H_min "(min ...) returns the minimum of its arguments" - #define Q_min sc->pcl_r - - s7_pointer x = car(args); - if (is_null(cdr(args))) - { - if (is_real(x)) return(x); - return(method_or_bust_p(sc, x, sc->min_symbol, sc->type_names[T_REAL])); - } - for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p)) - x = min_p_pp(sc, x, car(p)); - return(x); -} - -static s7_pointer g_min_2(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_min_3(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));} - -static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f)); -} - -static s7_int min_i_ii(s7_int i1, s7_int i2) {return((i1 < i2) ? i1 : i2);} -static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));} -static s7_double min_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 < x2) ? x1 : x2);} -static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(min_d_dd(x1, min_d_dd(x2, x3)));} -static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(min_d_dd(x1, min_d_ddd(x2, x3, x4)));} - - -/* ---------------------------------------- = ---------------------------------------- */ -static bool eq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string); - return(false); -} - -static bool eq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->num_eq_symbol, 2, y, a_number_string); - return(false); -} - -static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) == integer(y)); - if (is_t_real(x)) - return(real(x) == real(y)); - if (is_t_complex(x)) - return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); - if (is_t_ratio(x)) - return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); - if (is_t_big_ratio(x)) - return(mpq_equal(big_ratio(x), big_ratio(y))); - if (is_t_big_real(x)) - return(mpfr_equal_p(big_real(x), big_real(y))); - if (is_t_big_complex(x)) /* mpc_cmp can't handle NaN */ - { - if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - return(mpc_cmp(big_complex(x), big_complex(y)) == 0); - } -#endif - } - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: - return(false); - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) - { - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0); - } -#endif - return(integer(x) == real(y)); - case T_COMPLEX: - return(false); -#if WITH_GMP - case T_BIG_INTEGER: - return((mpz_fits_slong_p(big_integer(y))) && (integer(x) == mpz_get_si(big_integer(y)))); - case T_BIG_RATIO: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) == 0)); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(false); - case T_REAL: return(fraction(x) == real(y)); - case T_COMPLEX: return(false); -#if WITH_GMP - case T_BIG_INTEGER: - return(false); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_equal(sc->mpq_1, big_ratio(y))); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) == 0); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } - break; - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - return(real(x) == integer(y)); - case T_RATIO: - return(real(x) == fraction(y)); - case T_COMPLEX: - return(false); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0)); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } - break; - - case T_COMPLEX: - if (is_real(y)) return(false); -#if WITH_GMP - if (is_t_big_complex(y)) - { - if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - return(mpc_cmp(big_complex(y), sc->mpc_1) == 0); - } -#endif - return(eq_out_y(sc, x, y)); - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return((mpz_fits_slong_p(big_integer(x))) && (integer(y) == mpz_get_si(big_integer(x)))); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0); - case T_RATIO: case T_COMPLEX: case T_BIG_RATIO: case T_BIG_COMPLEX: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0)); - default: return(eq_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpq_equal(sc->mpq_1, big_ratio(x))); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0); - case T_INTEGER: case T_BIG_INTEGER: case T_COMPLEX: case T_BIG_COMPLEX: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0)); - default: return(eq_out_y(sc, x, y)); - } - - case T_BIG_REAL: - if ((is_number(y)) && (mpfr_nan_p(big_real(x)))) return(false); - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) == 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) == 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) == 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) == 0); - case T_COMPLEX: case T_BIG_COMPLEX: - return(false); - default: return(eq_out_y(sc, x, y)); - } - - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_RATIO: case T_REAL: case T_INTEGER: case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(false); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - return(mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */ - default: return(eq_out_y(sc, x, y)); - } -#endif - default: return(eq_out_x(sc, x, y)); - } - return(false); -} - -static bool is_number_via_method(s7_scheme *sc, s7_pointer p) -{ - if (is_number(p)) - return(true); - if (has_active_methods(sc, p)) - { - s7_pointer f = find_method_with_let(sc, p, sc->is_number_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -static s7_pointer g_num_eq(s7_scheme *sc, s7_pointer args) -{ - #define H_num_eq "(= z1 ...) returns #t if all its arguments are equal" - #define Q_num_eq s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol) - - s7_pointer x = car(args), p = cdr(args); - if (is_null(cdr(p))) - return(make_boolean(sc, num_eq_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); p = cdr(p)) - if (!num_eq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_number_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(p, args), car(p), a_number_string); - return(sc->F); - } - return(sc->T); -} - -static bool num_eq_b_ii(s7_int i1, s7_int i2) {return(i1 == i2);} -static bool num_eq_b_dd(s7_double i1, s7_double i2) {return(i1 == i2);} - -static s7_pointer num_eq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 == x2));} -static s7_pointer num_eq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 == x2));} -static s7_pointer num_eq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, num_eq_b_7pp(sc, x, y)));} - -static s7_pointer num_eq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) - return((integer(p1) == p2) ? sc->T : sc->F); - if (is_t_real(p1)) - return((real(p1) == p2) ? sc->T : sc->F); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(((mpz_fits_slong_p(big_integer(p1))) && (p2 == mpz_get_si(big_integer(p1)))) ? sc->T : sc->F); - if (is_t_big_real(p1)) - return((mpfr_cmp_si(big_real(p1), p2) == 0) ? sc->T : sc->F); -#endif - return((is_number(p1)) ? sc->F : make_boolean(sc, eq_out_x(sc, p1, make_integer(sc, p2)))); -} - -static bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if (is_t_integer(x)) - return(integer(x) == y); - if (is_t_real(x)) - return(real(x) == y); -#if WITH_GMP - if (is_t_big_integer(x)) - return((mpz_fits_slong_p(big_integer(x))) && (y == mpz_get_si(big_integer(x)))); - if (is_t_big_real(x)) - return(mpfr_cmp_si(big_real(x), y) == 0); -#endif - if (!is_number(x)) /* complex/ratio */ - sole_arg_wrong_type_error_nr(sc, sc->num_eq_symbol, x, a_number_string); - /* return(eq_out_x(sc, x, make_integer(sc, y))); */ /* much slower? see thash */ - return(false); -} - -static s7_pointer g_num_eq_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args), y = cadr(args); - if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */ - return(make_boolean(sc, integer(x) == integer(y))); - return(make_boolean(sc, num_eq_b_7pp(sc, x, y))); -} - -static inline s7_pointer num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) == integer(y))); - if (is_t_real(x)) - return(make_boolean(sc, real(x) == integer(y))); - if (!is_number(x)) - return(make_boolean(sc, eq_out_x(sc, x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), integer(y)) == 0)); - if (is_t_big_real(x)) - { - if (mpfr_nan_p(big_real(x))) return(sc->F); - return(make_boolean(sc, mpfr_cmp_si(big_real(x), integer(y)) == 0)); - } - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), integer(y), 1) == 0)); -#endif - return(sc->F); -} - -static s7_pointer g_num_eq_xi(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, car(args), cadr(args)));} -static s7_pointer g_num_eq_ix(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, cadr(args), car(args)));} - -static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(ur_f); - if ((ops) && (is_t_integer(caddr(expr)))) - return(sc->num_eq_xi); - return(((ops) && (is_t_integer(cadr(expr)))) ? sc->num_eq_ix : sc->num_eq_2); -} - - -/* ---------------------------------------- < ---------------------------------------- */ -static bool lt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->lt_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ - wrong_type_error_nr(sc, sc->lt_symbol, 1, x, sc->type_names[T_REAL]); - return(false); -} - -static bool lt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->lt_symbol, list_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->lt_symbol, 2, y, sc->type_names[T_REAL]); - return(false); -} - -static bool lt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) < integer(y)); - if (is_t_real(x)) - return(real(x) < real(y)); - if (is_t_ratio(x)) - return(fraction(x) < fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) < 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) < 0); - if (is_t_big_real(x)) - return(mpfr_less_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) < fraction(y)); /* ?? */ - case T_REAL: return(integer(x) < real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) > 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) > 0); - case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) < integer(y)); - case T_REAL: return(fraction(x) < real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) < integer(y)); - case T_RATIO: return(real(x) < fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_d(big_real(y), real(x)) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) < 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) < 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_z(big_real(y), big_integer(x)) > 0); - default: return(lt_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) < 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_q(big_real(y), big_ratio(x)) > 0); - default: return(lt_out_y(sc, x, y)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) < 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) < 0); - case T_REAL: - return(mpfr_cmp_d(big_real(x), real(y)) < 0); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) < 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) < 0); - default: return(lt_out_y(sc, x, y)); - } -#endif - default: return(lt_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_less(s7_scheme *sc, s7_pointer args) -{ - #define H_less "(< x1 ...) returns #t if its arguments are in increasing order" - #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - if (is_null(cdr(p))) - return(make_boolean(sc, lt_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); p = cdr(p)) - { - if (!lt_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->lt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - x = car(p); - } - return(sc->T); -} - -static bool ratio_lt_pi(s7_pointer x, s7_int y) -{ - if ((y >= 0) && (numerator(x) < 0)) - return(true); - if ((y <= 0) && (numerator(x) > 0)) - return(false); - if (denominator(x) < S7_INT32_MAX) - return(numerator(x) < (y * denominator(x))); - return(fraction(x) < y); -} - -static s7_pointer g_less_x0(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args); - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) < 0)); - if (is_small_real(x)) - return(make_boolean(sc, is_negative(sc, x))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0)); - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_si(big_real(x), 0) < 0)); - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), 0, 1) < 0)); -#endif - return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} - -static s7_pointer g_less_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) < y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) < y)); - if (is_t_ratio(x)) - return(make_boolean(sc, ratio_lt_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) < 0)); - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) < 0)); - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) < 0)); -#endif - return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} - -static s7_pointer g_less_xf(s7_scheme *sc, s7_pointer args) -{ - s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */ - s7_pointer x = car(args); - - if (is_t_real(x)) - return(make_boolean(sc, real(x) < y)); - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) < y)); - if (is_t_ratio(x)) - return(make_boolean(sc, fraction(x) < y)); -#if WITH_GMP - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) < 0)); - if (is_t_big_integer(x)) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) > 0)); - } - if (is_t_big_ratio(x)) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) > 0)); - } -#endif - return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} - -static inline s7_pointer lt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, lt_b_7pp(sc, p1, p2)));} -static bool lt_b_ii(s7_int i1, s7_int i2) {return(i1 < i2);} -static bool lt_b_dd(s7_double i1, s7_double i2) {return(i1 < i2);} -static s7_pointer lt_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 < x2));} -static s7_pointer lt_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 < x2));} - -static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) < p2); - if (is_t_real(p1)) return(real(p1) < p2); - if (is_t_ratio(p1)) return(ratio_lt_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) < 0); - if (is_t_big_real(p1)) - return(mpfr_cmp_si(big_real(p1), p2) < 0); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) < 0); -#endif - return(lt_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args) {return(lt_p_pp(sc, car(args), cadr(args)));} -static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, lt_b_pi(sc, p1, p2)));} - -static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if (is_t_integer(arg2)) - { - if (integer(arg2) == 0) - return(sc->less_x0); - - if ((integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->less_xi); - } - if (is_t_real(arg2)) - return(sc->less_xf); - } - return(sc->less_2); -} - - -/* ---------------------------------------- <= ---------------------------------------- */ -static bool leq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->leq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ - wrong_type_error_nr(sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); - return(false); -} - -static bool leq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->leq_symbol, list_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->leq_symbol, 2, y, sc->type_names[T_REAL]); - return(false); -} - -static bool leq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) <= integer(y)); - if (is_t_real(x)) - return(real(x) <= real(y)); - if (is_t_ratio(x)) - return(fraction(x) <= fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) <= 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) <= 0); - if (is_t_big_real(x)) - return(mpfr_lessequal_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) <= fraction(y)); /* ?? */ - case T_REAL: return(integer(x) <= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) >= 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) >= 0)); -#endif - default: return(leq_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) <= integer(y)); - case T_REAL: return(fraction(x) <= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) >= 0); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0); -#endif - default: return(leq_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) <= integer(y)); - case T_RATIO: return(real(x) <= fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) >= 0)); -#endif - default: return(leq_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) <= 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0)); - default: return(leq_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) <= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0)); - default: return(leq_out_y(sc, x, y)); - } - - case T_BIG_REAL: - if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false); - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) <= 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) <= 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) <= 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0); - default: return(leq_out_y(sc, x, y)); - } -#endif - default: return(leq_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in non-decreasing order" - #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - - if (is_null(cdr(p))) - return(make_boolean(sc, leq_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); x = car(p), p = cdr(p)) - if (!leq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->leq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - return(sc->T); -} - -static inline s7_pointer leq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, leq_b_7pp(sc, p1, p2)));} -static bool leq_b_ii(s7_int i1, s7_int i2) {return(i1 <= i2);} -static bool leq_b_dd(s7_double i1, s7_double i2) {return(i1 <= i2);} -static s7_pointer leq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 <= x2));} -static s7_pointer leq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 <= x2));} - -static bool ratio_leq_pi(s7_pointer x, s7_int y) -{ - if ((y >= 0) && (numerator(x) <= 0)) - return(true); - if ((y <= 0) && (numerator(x) > 0)) - return(false); - if (denominator(x) < S7_INT32_MAX) - return(numerator(x) <= (y * denominator(x))); - return(fraction(x) <= y); -} - -static s7_pointer g_leq_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) <= y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) <= y)); - if (is_t_ratio(x)) - return(make_boolean(sc, ratio_leq_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) <= 0)); - if (is_t_big_real(x)) - { - if (mpfr_nan_p(big_real(x))) return(sc->F); - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) <= 0)); - } - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) <= 0)); -#endif - return(method_or_bust(sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1)); -} - -static bool leq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) <= p2); - if (is_t_real(p1)) return(real(p1) <= p2); - if (is_t_ratio(p1)) return(ratio_leq_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) <= 0); - if (is_t_big_real(p1)) - return(mpfr_cmp_si(big_real(p1), p2) <= 0); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) <= 0); -#endif - return(leq_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, leq_b_pi(sc, p1, p2)));} -static s7_pointer g_leq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, leq_b_7pp(sc, car(args), cadr(args))));} -static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = cdr(args); - if (is_t_integer(car(p))) - { - if (integer(car(args)) > integer(car(p))) - { - if (!is_real_via_method(sc, cadr(p))) - wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(p), sc->type_names[T_REAL]); - return(sc->F); - } - if (is_t_integer(cadr(p))) - return((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T); - } - return(g_less_or_equal(sc, args)); -} - -static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args == 2) - { - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->leq_xi); - } - return(sc->leq_2); - } - if ((args == 3) && (is_t_integer(cadr(expr)))) - return(sc->leq_ixx); - return(f); -} - - -/* ---------------------------------------- > ---------------------------------------- */ -static bool gt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->gt_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ - wrong_type_error_nr(sc, sc->gt_symbol, 1, x, sc->type_names[T_REAL]); - return(false); -} - -static bool gt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->gt_symbol, list_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->gt_symbol, 2, y, sc->type_names[T_REAL]); - return(false); -} - -static bool gt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) > integer(y)); - if (is_t_real(x)) - return(real(x) > real(y)); - if (is_t_ratio(x)) - return(fraction(x) > fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) > 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) > 0); - if (is_t_big_real(x)) - return(mpfr_greater_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) > fraction(y)); /* ?? */ - case T_REAL: return(integer(x) > real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) < 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) < 0); - case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) > integer(y)); - case T_REAL: return(fraction(x) > real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) > integer(y)); - case T_RATIO: return(real(x) > fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_d(big_real(y), real(x)) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) > 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_z(big_real(y), big_integer(x)) < 0); - default: return(gt_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) > 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_q(big_real(y), big_ratio(x)) < 0); - default: return(gt_out_y(sc, x, y)); - } - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) > 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) > 0); - case T_REAL: - return(mpfr_cmp_d(big_real(x), real(y)) > 0); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) > 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) > 0); - default: return(gt_out_y(sc, x, y)); - } -#endif - default: return(gt_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order" - #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - - if (is_null(cdr(p))) - return(make_boolean(sc, gt_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); x = car(p), p = cdr(p)) - if (!gt_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->gt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - return(sc->T); -} - -static s7_pointer g_greater_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) > y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) > y)); - if (is_t_ratio(x)) - return(make_boolean(sc, !ratio_leq_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) > 0)); - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) > 0)); - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) > 0)); -#endif - return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); -} - -static s7_pointer g_greater_xf(s7_scheme *sc, s7_pointer args) -{ - s7_double y = real(cadr(args)); - s7_pointer x = car(args); - - if (is_t_real(x)) - return(make_boolean(sc, real(x) > y)); - - switch (type(x)) - { - case T_INTEGER: return(make_boolean(sc, integer(x) > y)); - - case T_RATIO: - /* (> 9223372036854775807/9223372036854775806 1.0) */ - if (denominator(x) < S7_INT32_MAX) /* y range check was handled in greater_chooser */ - return(make_boolean(sc, (numerator(x) > (y * denominator(x))))); - return(make_boolean(sc, fraction(x) > y)); - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) < 0)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) < 0)); - case T_BIG_REAL: - return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) > 0)); -#endif - default: - return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); - } - return(sc->T); -} - -static inline s7_pointer gt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, gt_b_7pp(sc, p1, p2)));} -static bool gt_b_ii(s7_int i1, s7_int i2) {return(i1 > i2);} -static bool gt_b_dd(s7_double i1, s7_double i2) {return(i1 > i2);} -static s7_pointer gt_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 > x2));} -static s7_pointer gt_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 > x2));} - -static bool gt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) > p2); - if (is_t_real(p1)) return(real(p1) > p2); - if (is_t_ratio(p1)) return(!ratio_leq_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) > 0); - if (is_t_big_real(p1)) - return(mpfr_cmp_si(big_real(p1), p2) > 0); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) > 0); -#endif - return(gt_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer gt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, gt_b_pi(sc, p1, p2)));} - -static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args) -{ - /* ridiculous repetition, but overheads are killing this poor thing */ - s7_pointer x = car(args), y = cadr(args); - if (type(x) == type(y)) - { - if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(y))); - if (is_t_real(x)) return(make_boolean(sc, real(x) > real(y))); - if (is_t_ratio(x)) return(make_boolean(sc, fraction(x) > fraction(y))); - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(gt_p_pp(sc, x, y)); - case T_REAL: return(make_boolean(sc, integer(x) > real(y))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); -#endif - default: return(make_boolean(sc, gt_out_y(sc, x, y))); - } - break; - - case T_RATIO: return(gt_p_pp(sc, x, y)); - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(make_boolean(sc, real(x) > integer(y))); - case T_RATIO: return(make_boolean(sc, real(x) > fraction(y))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); -#endif - default: return(make_boolean(sc, gt_out_y(sc, x, y))); - } - break; -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); -#endif - - default: return(make_boolean(sc, gt_out_x(sc, x, y))); - } - return(sc->T); -} - -static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->greater_xi); - if ((is_t_real(arg2)) && - (real(arg2) < S7_INT32_MAX) && - (real(arg2) > S7_INT32_MIN)) - return(sc->greater_xf); - } - return(sc->greater_2); -} - - -/* ---------------------------------------- >= ---------------------------------------- */ -static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (!has_active_methods(sc, x)) - wrong_type_error_nr(sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]); - return(find_and_apply_method(sc, x, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ -} - -static bool geq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (!has_active_methods(sc, y)) - wrong_type_error_nr(sc, sc->geq_symbol, 2, y, sc->type_names[T_REAL]); - return(find_and_apply_method(sc, y, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ -} - -static bool geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) >= integer(y)); - if (is_t_real(x)) - return(real(x) >= real(y)); - if (is_t_ratio(x)) - return(fraction(x) >= fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) >= 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) >= 0); - if (is_t_big_real(x)) - return(mpfr_greaterequal_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) >= fraction(y)); /* ?? */ - case T_REAL: return(integer(x) >= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) <= 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) <= 0)); -#endif - default: return(geq_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) >= integer(y)); - case T_REAL: return(fraction(x) >= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) <= 0); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0); -#endif - default: return(geq_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) >= integer(y)); - case T_RATIO: return(real(x) >= fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) <= 0)); -#endif - default: return(geq_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) >= 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0)); - default: return(geq_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) >= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0)); - default: return(geq_out_y(sc, x, y)); - } - - case T_BIG_REAL: - if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false); - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) >= 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) >= 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) >= 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0); - default: return(geq_out_y(sc, x, y)); - } -#endif - default: return(geq_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in non-increasing order" - #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - if (is_null(cdr(p))) - return(make_boolean(sc, geq_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); x = car(p), p = cdr(p)) - if (!geq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->geq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - return(sc->T); -} - -static inline s7_pointer geq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, geq_b_7pp(sc, p1, p2)));} -static bool geq_b_ii(s7_int i1, s7_int i2) {return(i1 >= i2);} -static bool geq_b_dd(s7_double i1, s7_double i2) {return(i1 >= i2);} -static s7_pointer geq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 >= x2));} -static s7_pointer geq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 >= x2));} - -static s7_pointer g_geq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, geq_b_7pp(sc, car(args), cadr(args))));} - -static s7_pointer g_geq_xf(s7_scheme *sc, s7_pointer args) -{ - s7_double y = real(cadr(args)); - s7_pointer x = car(args); - return(make_boolean(sc, ((is_t_real(x)) ? (real(x) >= y) : geq_b_7pp(sc, car(args), cadr(args))))); -} - -static s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) >= y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) >= y)); - if (is_t_ratio(x)) - return(make_boolean(sc, !ratio_lt_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) >= 0)); - if (is_t_big_real(x)) - { - if (mpfr_nan_p(big_real(x))) return(sc->F); - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) >= 0)); - } - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) >= 0)); -#endif - return(method_or_bust(sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1)); -} - -static bool geq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) >= p2); - if (is_t_real(p1)) return(real(p1) >= p2); - if (is_t_ratio(p1)) return(!ratio_lt_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) >= 0); - if (is_t_big_real(p1)) - return((!mpfr_nan_p(big_real(p1))) && (mpfr_cmp_si(big_real(p1), p2) >= 0)); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) >= 0); -#endif - return(geq_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, geq_b_pi(sc, p1, p2)));} - -static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->geq_xi); - if ((is_t_real(arg2)) && - (real(arg2) < S7_INT32_MAX) && - (real(arg2) > S7_INT32_MIN)) - return(sc->geq_xf); - } - return(sc->geq_2); -} - - -/* ---------------------------------------- real-part ---------------------------------------- */ -s7_double s7_real_part(s7_pointer x) -{ - switch(type(x)) - { - case T_INTEGER: return((s7_double)integer(x)); - case T_RATIO: return(fraction(x)); - case T_REAL: return(real(x)); - case T_COMPLEX: return(real_part(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x))); - case T_BIG_RATIO: return((s7_double)((long_double)mpz_get_si(mpq_numref(big_ratio(x))) / - (long_double)mpz_get_si(mpq_denref(big_ratio(x))))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); - case T_BIG_COMPLEX: return((s7_double)mpfr_get_d(mpc_realref(big_complex(x)), MPFR_RNDN)); -#endif - } - return(0.0); -} - -static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_complex(p)) return(make_real(sc, real_part(p))); - switch (type(p)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - return(p); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(p); - case T_BIG_COMPLEX: - { - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpc_real(big_real(x), big_complex(p), MPFR_RNDN); - return(x); - } -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->real_part_symbol, a_number_string)); - } -} - -static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args) -{ - #define H_real_part "(real-part num) returns the real part of num" - #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - return(real_part_p_p(sc, car(args))); -} - - -/* ---------------------------------------- imag-part ---------------------------------------- */ -s7_double s7_imag_part(s7_pointer x) -{ - if (is_t_complex(x)) - return(imag_part(x)); -#if WITH_GMP - if (is_t_big_complex(x)) - return((s7_double)mpfr_get_d(mpc_imagref(big_complex(x)), MPFR_RNDN)); -#endif - return(0.0); -} - -static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_complex(p)) return(make_real(sc, imag_part(p))); - switch (type(p)) - { - case T_INTEGER: case T_RATIO: - return(int_zero); - case T_REAL: - return(real_zero); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: - return(int_zero); - case T_BIG_REAL: - return(real_zero); - case T_BIG_COMPLEX: - { - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpc_imag(big_real(x), big_complex(p), MPFR_RNDN); - return(x); - } -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->imag_part_symbol, a_number_string)); - } -} - -static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args) -{ - #define H_imag_part "(imag-part num) returns the imaginary part of num" - #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */ - return(imag_part_p_p(sc, car(args))); -} - - -/* ---------------------------------------- numerator denominator ---------------------------------------- */ -static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_ratio(p)) return(numerator(p)); - if (is_t_integer(p)) return(integer(p)); -#if WITH_GMP - if (is_t_big_ratio(p)) return(mpz_get_si(mpq_numref(big_ratio(p)))); - if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p))); -#endif - return(integer(sole_arg_method_or_bust_p(sc, p, sc->numerator_symbol, a_rational_string))); -} - -static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args) -{ - #define H_numerator "(numerator rat) returns the numerator of the rational number rat" - #define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol) - - s7_pointer x = car(args); - switch (type(x)) - { - case T_RATIO: return(make_integer(sc, numerator(x))); - case T_INTEGER: return(x); -#if WITH_GMP - case T_BIG_INTEGER: return(x); - case T_BIG_RATIO: return(mpz_to_integer(sc, mpq_numref(big_ratio(x)))); -#endif - default: return(sole_arg_method_or_bust_p(sc, x, sc->numerator_symbol, a_rational_string)); - } -} - - -static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args) -{ - #define H_denominator "(denominator rat) returns the denominator of the rational number rat" - #define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol) - - s7_pointer x = car(args); - switch (type(x)) - { - case T_RATIO: return(make_integer(sc, denominator(x))); - case T_INTEGER: return(int_one); -#if WITH_GMP - case T_BIG_INTEGER: return(int_one); - case T_BIG_RATIO: return(mpz_to_integer(sc, mpq_denref(big_ratio(x)))); -#endif - default: return(sole_arg_method_or_bust_p(sc, x, sc->denominator_symbol, a_rational_string)); - } -} - -static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_ratio(p)) return(denominator(p)); - if (is_t_integer(p)) return(1); -#if WITH_GMP - if (is_t_big_ratio(p)) return(mpz_get_si(mpq_denref(big_ratio(p)))); - if (is_t_big_integer(p)) return(1); -#endif - return(integer(sole_arg_method_or_bust_p(sc, p, sc->denominator_symbol, a_rational_string))); -} - - -/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */ -static s7_pointer g_is_number(s7_scheme *sc, s7_pointer args) -{ - #define H_is_number "(number? obj) returns #t if obj is a number" - #define Q_is_number sc->pl_bt - check_boolean_method(sc, is_number, sc->is_number_symbol, args); -} - -bool s7_is_bignum(s7_pointer obj) {return(is_big_number(obj));} - -static s7_pointer g_is_bignum(s7_scheme *sc, s7_pointer args) -{ - #define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number." - #define Q_is_bignum sc->pl_bt - return(s7_make_boolean(sc, is_big_number(car(args)))); -} - -static s7_pointer g_is_integer(s7_scheme *sc, s7_pointer args) -{ - #define H_is_integer "(integer? obj) returns #t if obj is an integer" - #define Q_is_integer sc->pl_bt - check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args); -} - -static bool is_byte(s7_pointer p) {return((s7_is_integer(p)) && (s7_integer(p) >= 0) && (s7_integer(p) < 256));} -static s7_pointer g_is_byte(s7_scheme *sc, s7_pointer args) -{ - #define H_is_byte "(byte? obj) returns #t if obj is a byte (an integer between 0 and 255)" - #define Q_is_byte sc->pl_bt - check_boolean_method(sc, is_byte, sc->is_byte_symbol, args); -} - -static s7_pointer g_is_real(s7_scheme *sc, s7_pointer args) -{ - #define H_is_real "(real? obj) returns #t if obj is a real number" - #define Q_is_real sc->pl_bt - check_boolean_method(sc, is_real, sc->is_real_symbol, args); -} - -static s7_pointer g_is_complex(s7_scheme *sc, s7_pointer args) -{ - #define H_is_complex "(complex? obj) returns #t if obj is a number" - #define Q_is_complex sc->pl_bt - check_boolean_method(sc, is_number, sc->is_complex_symbol, args); -} - -static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args) -{ - #define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)" - #define Q_is_rational sc->pl_bt - check_boolean_method(sc, is_rational, sc->is_rational_symbol, args); - /* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t, and similarly for exact? etc */ -} - -static s7_pointer g_is_float(s7_scheme *sc, s7_pointer args) -{ - #define H_is_float "(float? x) returns #t is x is real and not rational." - #define Q_is_float sc->pl_bt - s7_pointer p = car(args); -#if WITH_GMP - return(make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); /* (float? pi) */ -#else - return(make_boolean(sc, is_t_real(p))); -#endif -} - -#if WITH_GMP -static bool is_float_b(s7_pointer p) {return((is_t_real(p)) || (is_t_big_real(p)));} -#else -static bool is_float_b(s7_pointer p) {return(is_t_real(p));} -#endif - - -/* ---------------------------------------- nan? ---------------------------------------- */ -static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_real(x)) return(is_NaN(real(x))); - switch (type(x)) - { - case T_INTEGER: - case T_RATIO: return(false); - /* case T_REAL: return(is_NaN(real(x))); */ - case T_COMPLEX: return((is_NaN(real_part(x))) || (is_NaN(imag_part(x)))); -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: return(false); - case T_BIG_REAL: return(mpfr_nan_p(big_real(x)) != 0); - case T_BIG_COMPLEX: return((mpfr_nan_p(mpc_realref(big_complex(x))) != 0) || (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0)); -#endif - default: - if (is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F); - } - return(false); -} - -static s7_pointer g_is_nan(s7_scheme *sc, s7_pointer args) -{ - #define H_is_nan "(nan? obj) returns #t if obj is a NaN" - #define Q_is_nan sc->pl_bt - return(make_boolean(sc, is_nan_b_7p(sc, car(args)))); -} - - -/* ---------------------------------------- infinite? ---------------------------------------- */ -static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - case T_RATIO: return(false); - case T_REAL: return(is_inf(real(x))); - case T_COMPLEX: return((is_inf(real_part(x))) || (is_inf(imag_part(x)))); -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: return(false); - case T_BIG_REAL: return(mpfr_inf_p(big_real(x)) != 0); - case T_BIG_COMPLEX: - return((mpfr_inf_p(mpc_realref(big_complex(x))) != 0) || - (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0)); -#endif - default: - if (is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F); - } - return(false); -} - -static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args) -{ - #define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real" - #define Q_is_infinite sc->pl_bt - return(make_boolean(sc, is_infinite_b_7p(sc, car(args)))); -} - - -/* ---------------------------------------- even? odd?---------------------------------------- */ -static bool is_even_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) - return((integer(p) & 1) == 0); -#if WITH_GMP - if (is_t_big_integer(p)) - return(mpz_even_p(big_integer(p))); -#endif - return(method_or_bust_p(sc, p, sc->is_even_symbol, sc->type_names[T_INTEGER]) != sc->F); -} - -static s7_pointer is_even_p_p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_integer(x)) - return(make_boolean(sc, (integer(x) & 1) == 0)); - return(make_boolean(sc, is_even_b_7p(sc, x))); -} - -static bool is_even_i(s7_int i1) {return((i1 & 1) == 0);} - -static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args) -{ - #define H_is_even "(even? int) returns #t if the integer int32_t is even" - #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - return(make_boolean(sc, is_even_b_7p(sc, car(args)))); -} - - -static bool is_odd_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) - return((integer(p) & 1) == 1); -#if WITH_GMP - if (is_t_big_integer(p)) - return(mpz_odd_p(big_integer(p))); -#endif - return(method_or_bust_p(sc, p, sc->is_odd_symbol, sc->type_names[T_INTEGER]) != sc->F); -} - -static s7_pointer is_odd_p_p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_integer(x)) - return(make_boolean(sc, (integer(x) & 1) == 1)); - return(make_boolean(sc, is_odd_b_7p(sc, x))); -} - -static bool is_odd_i(s7_int i1) {return((i1 & 1) == 1);} - -static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args) -{ - #define H_is_odd "(odd? int) returns #t if the integer int32_t is odd" - #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - return(make_boolean(sc, is_odd_b_7p(sc, car(args)))); -} - - -/* ---------------------------------------- zero? ---------------------------------------- */ -static bool is_zero(s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) == 0); - case T_REAL: return(real(x) == 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) == 0); - case T_BIG_REAL: return(mpfr_zero_p(big_real(x))); -#endif - default: - return(false); /* ratios and complex numbers here are already collapsed into integers and reals */ - } -} - -static bool is_zero_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p) == 0); - if (is_t_real(p)) return(real(p) == 0.0); -#if WITH_GMP - if (is_number(p)) return(is_zero(p)); -#else - if (is_number(p)) return(false); -#endif - return(sole_arg_method_or_bust_p(sc, p, sc->is_zero_symbol, a_number_string) != sc->F); -} - -static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args) -{ - #define H_is_zero "(zero? num) returns #t if the number num is zero" - #define Q_is_zero sc->pl_bn - return(make_boolean(sc, is_zero_b_7p(sc, car(args)))); -} - -static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_zero_b_7p(sc, p)));} -static bool is_zero_i(s7_int p) {return(p == 0);} -static bool is_zero_d(s7_double p) {return(p == 0.0);} - - -/* -------------------------------- positive? -------------------------------- */ -static bool is_positive(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) > 0); - case T_RATIO: return(numerator(x) > 0); - case T_REAL: return(real(x) > 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) > 0); - case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) > 0); - case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) > 0); -#endif - default: - sole_arg_wrong_type_error_nr(sc, sc->is_positive_symbol, x, sc->type_names[T_REAL]); - } - return(false); -} - -static bool is_positive_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p) > 0); - if (is_t_real(p)) return(real(p) > 0.0); -#if WITH_GMP - if (is_number(p)) return(is_positive(sc, p)); -#else - if (is_t_ratio(p)) return(numerator(p) > 0); -#endif - return(method_or_bust_p(sc, p, sc->is_positive_symbol, sc->type_names[T_REAL]) != sc->F); -} - -static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args) -{ - #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)" - #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) - return(make_boolean(sc, is_positive_b_7p(sc, car(args)))); -} - -static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_positive_b_7p(sc, p)));} -static bool is_positive_i(s7_int p) {return(p > 0);} -static bool is_positive_d(s7_double p) {return(p > 0.0);} - - -/* -------------------------------- negative? -------------------------------- */ -static bool is_negative(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) < 0); - case T_RATIO: return(numerator(x) < 0); - case T_REAL: return(real(x) < 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) < 0); - case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) < 0); - case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) < 0); -#endif - default: - sole_arg_wrong_type_error_nr(sc, sc->is_negative_symbol, x, sc->type_names[T_REAL]); - } - return(false); -} - -static bool is_negative_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p) < 0); - if (is_t_real(p)) return(real(p) < 0.0); -#if WITH_GMP - if (is_number(p)) return(is_negative(sc, p)); -#else - if (is_t_ratio(p)) return(numerator(p) < 0); -#endif - return(method_or_bust_p(sc, p, sc->is_negative_symbol, sc->type_names[T_REAL]) != sc->F); -} - -static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args) -{ - #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)" - #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) - return(make_boolean(sc, is_negative_b_7p(sc, car(args)))); -} - -static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_negative_b_7p(sc, p)));} -static bool is_negative_i(s7_int p) {return(p < 0);} -static bool is_negative_d(s7_double p) {return(p < 0.0);} - - -#if (!WITH_PURE_S7) -/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */ -static s7_pointer exact_to_inexact_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: -#if WITH_GMP - if ((integer(x) > INT64_TO_DOUBLE_LIMIT) || (integer(x) < -INT64_TO_DOUBLE_LIMIT)) - return(s7_number_to_big_real(sc, x)); -#endif - return(make_real(sc, (s7_double)(integer(x)))); - - case T_RATIO: -#if WITH_GMP - if ((numerator(x) > INT64_TO_DOUBLE_LIMIT) || (numerator(x) < -INT64_TO_DOUBLE_LIMIT) || - (denominator(x) > INT64_TO_DOUBLE_LIMIT)) /* just a guess */ - return(s7_number_to_big_real(sc, x)); -#endif - return(make_real(sc, (s7_double)(fraction(x)))); - -#if WITH_GMP - case T_BIG_INTEGER: - return(big_integer_to_big_real(sc, x)); - case T_BIG_RATIO: - return(big_ratio_to_big_real(sc, x)); -#endif - case T_REAL: case T_BIG_REAL: - case T_COMPLEX: case T_BIG_COMPLEX: - return(x); /* apparently (exact->inexact 1+i) is not an error */ - default: - return(sole_arg_method_or_bust_p(sc, x, sc->exact_to_inexact_symbol, a_number_string)); - } -} - -static s7_pointer g_exact_to_inexact(s7_scheme *sc, s7_pointer args) -{ - #define H_exact_to_inexact "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5" - #define Q_exact_to_inexact s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol) - /* arg can be complex -> itself! */ - return(exact_to_inexact_p_p(sc, car(args))); -} - -static s7_pointer inexact_to_exact_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: case T_BIG_INTEGER: - case T_RATIO: case T_BIG_RATIO: - return(x); - -#if WITH_GMP - case T_BIG_REAL: - return(big_rationalize(sc, set_plist_1(sc, x))); -#endif - - case T_REAL: - { - s7_int numer = 0, denom = 1; - s7_double val = real(x); - if ((is_inf(val)) || (is_NaN(val))) - sole_arg_wrong_type_error_nr(sc, sc->inexact_to_exact_symbol, x, a_normal_real_string); - - if ((val > DOUBLE_TO_INT64_LIMIT) || (val < -(DOUBLE_TO_INT64_LIMIT))) - { -#if WITH_GMP - return(big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */ -#else - sole_arg_out_of_range_error_nr(sc, sc->inexact_to_exact_symbol, x, it_is_too_large_string); -#endif - } - /* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */ - if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom)) - return(make_ratio(sc, numer, denom)); - } - - default: - return(method_or_bust_p(sc, x, sc->inexact_to_exact_symbol, sc->type_names[T_REAL])); - } - return(x); -} - -static s7_pointer g_inexact_to_exact(s7_scheme *sc, s7_pointer args) -{ - #define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2" - #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) - return(inexact_to_exact_p_p(sc, car(args))); -} - -static s7_pointer g_is_exact(s7_scheme *sc, s7_pointer args) -{ - #define H_is_exact "(exact? num) returns #t if num is exact (an integer or a ratio)" - #define Q_is_exact sc->pl_bn - - s7_pointer x = car(args); - switch (type(x)) - { - case T_INTEGER: case T_BIG_INTEGER: - case T_RATIO: case T_BIG_RATIO: - return(sc->T); - case T_REAL: case T_BIG_REAL: - case T_COMPLEX: case T_BIG_COMPLEX: - return(sc->F); - default: - return(sole_arg_method_or_bust_p(sc, x, sc->is_exact_symbol, a_number_string)); - } -} - -static bool is_exact_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_number(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->is_exact_symbol, a_number_string) != sc->F); - return(is_rational(p)); -} - - -static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args) -{ - #define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)" - #define Q_is_inexact sc->pl_bn - - s7_pointer x = car(args); - switch (type(x)) - { - case T_INTEGER: case T_BIG_INTEGER: - case T_RATIO: case T_BIG_RATIO: - return(sc->F); - case T_REAL: case T_BIG_REAL: - case T_COMPLEX: case T_BIG_COMPLEX: - return(sc->T); - default: - return(sole_arg_method_or_bust_p(sc, x, sc->is_inexact_symbol, a_number_string)); - } -} - -static bool is_inexact_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_number(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->is_inexact_symbol, a_number_string) != sc->F); - return(!is_rational(p)); -} - - -/* ---------------------------------------- integer-length ---------------------------------------- */ -static int32_t integer_length(s7_int a) -{ - if (a < 0) - { - if (a == S7_INT64_MIN) return(63); - a = -a; - } - if (a < 256LL) return(intlen_bits[a]); /* in gmp, sbcl and clisp (integer-length 0) is 0 */ - if (a < 65536LL) return(8 + intlen_bits[a >> 8]); - if (a < 16777216LL) return(16 + intlen_bits[a >> 16]); - if (a < 4294967296LL) return(24 + intlen_bits[a >> 24]); - if (a < 1099511627776LL) return(32 + intlen_bits[a >> 32]); - if (a < 281474976710656LL) return(40 + intlen_bits[a >> 40]); - if (a < 72057594037927936LL) return(48 + intlen_bits[a >> 48]); - return(56 + intlen_bits[a >> 56]); -} - -static s7_pointer g_integer_length(s7_scheme *sc, s7_pointer args) -{ - #define H_integer_length "(integer-length arg) returns the number of bits required to represent the integer 'arg': \ -(ceiling (log (if (< arg 0) (- arg) (+ arg 1)) 2))" - #define Q_integer_length sc->pcl_i - - s7_pointer p = car(args); - if (is_t_integer(p)) - { - s7_int x = integer(p); - return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x))); - } -#if WITH_GMP - if (is_t_big_integer(p)) - return(make_integer(sc, mpz_sizeinbase(big_integer(p), 2))); -#endif - return(sole_arg_method_or_bust(sc, p, sc->integer_length_symbol, args, sc->type_names[T_INTEGER])); -} - -static s7_int integer_length_i_i(s7_int x) {return((x < 0) ? integer_length(-(x + 1)) : integer_length(x));} -#endif /* !pure s7 */ - - -/* ---------------------------------------- integer-decode-float ---------------------------------------- */ -static s7_pointer g_integer_decode_float(s7_scheme *sc, s7_pointer args) -{ - #define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \ -sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" - #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol) - - decode_float_t num; - s7_pointer x = car(args); - if (is_t_real(x)) - { - if (real(x) == 0.0) - return(list_3(sc, int_zero, int_zero, int_one)); - num.fx = (double)real(x); - return(list_3(sc, - make_integer_unchecked(sc, (s7_int)((num.ix & 0xfffffffffffffLL) | 0x10000000000000LL)), - make_integer(sc, (s7_int)(((num.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)), - ((num.ix & 0x8000000000000000LL) != 0) ? minus_one : int_one)); - } -#if WITH_GMP - if (is_t_big_real(x)) - { - mp_exp_t exp_n; - bool neg; - exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x)); - neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0); - if (neg) mpz_abs(sc->mpz_1, sc->mpz_1); - return(list_3(sc, mpz_to_integer(sc, sc->mpz_1), make_integer(sc, exp_n), (neg) ? minus_one : int_one)); - /* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */ - } -#endif - return(sole_arg_method_or_bust_p(sc, x, sc->integer_decode_float_symbol, wrap_string(sc, "a non-rational real", 19))); -} - - -/* -------------------------------- logior -------------------------------- */ -#if WITH_GMP -static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args) -{ - mpz_set_si(sc->mpz_1, start); - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer i = car(x); - switch (type(i)) - { - case T_BIG_INTEGER: - mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logior_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logior_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} - return(mpz_to_integer(sc, sc->mpz_1)); -} -#endif - -static s7_pointer g_logior(s7_scheme *sc, s7_pointer args) -{ - #define H_logior "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)" - #define Q_logior sc->pcl_i - - s7_int result = 0; - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { -#if WITH_GMP - if (is_t_big_integer(car(x))) - return(big_logior(sc, result, x)); -#endif - if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logior_symbol, - (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); - result |= integer(car(x)); - } - return(make_integer(sc, result)); -} - -static s7_int logior_i_ii(s7_int i1, s7_int i2) {return(i1 | i2);} -static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 | i2 | i3);} - - -/* -------------------------------- logxor -------------------------------- */ -#if WITH_GMP -static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args) -{ - mpz_set_si(sc->mpz_1, start); - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer i = car(x); - switch (type(i)) - { - case T_BIG_INTEGER: - mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logxor_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logxor_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} - return(mpz_to_integer(sc, sc->mpz_1)); -} -#endif - -static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args) -{ - #define H_logxor "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)" - #define Q_logxor sc->pcl_i - - s7_int result = 0; - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { -#if WITH_GMP - if (is_t_big_integer(car(x))) - return(big_logxor(sc, result, x)); -#endif - if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logxor_symbol, - (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); - result ^= integer(car(x)); - } - return(make_integer(sc, result)); -} - -static s7_int logxor_i_ii(s7_int i1, s7_int i2) {return(i1 ^ i2);} -static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 ^ i2 ^ i3);} - - -/* -------------------------------- logand -------------------------------- */ -#if WITH_GMP -static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args) -{ - mpz_set_si(sc->mpz_1, start); - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer i = car(x); - switch (type(i)) - { - case T_BIG_INTEGER: - mpz_and(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logand_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logand_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} - return(mpz_to_integer(sc, sc->mpz_1)); -} -#endif - -static s7_pointer g_logand(s7_scheme *sc, s7_pointer args) -{ - #define H_logand "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)" - #define Q_logand sc->pcl_i - - s7_int result = -1; - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { -#if WITH_GMP - if (is_t_big_integer(car(x))) - return(big_logand(sc, result, x)); -#endif - if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logand_symbol, - (result == -1) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); - result &= integer(car(x)); - } - return(make_integer(sc, result)); -} - -static s7_int logand_i_ii(s7_int i1, s7_int i2) {return(i1 & i2);} -static s7_int logand_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 & i2 & i3);} - - -/* -------------------------------- lognot -------------------------------- */ -static s7_pointer g_lognot(s7_scheme *sc, s7_pointer args) -{ - #define H_lognot "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1" - #define Q_lognot sc->pcl_i - - s7_pointer x = car(args); - if (is_t_integer(x)) - return(make_integer(sc, ~integer(x))); - -#if WITH_GMP - if (is_t_big_integer(x)) - { - mpz_com(sc->mpz_1, big_integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#endif - return(sole_arg_method_or_bust(sc, x, sc->lognot_symbol, args, sc->type_names[T_INTEGER])); -} - -static s7_int lognot_i_i(s7_int i1) {return(~i1);} - - -/* -------------------------------- logbit? -------------------------------- */ -/* logbit? CL is (logbitp index int) using 2^index, but that order strikes me as backwards - * at least gmp got the arg order right! - */ - -static s7_pointer g_logbit(s7_scheme *sc, s7_pointer args) -{ - #define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \ -order here follows gmp, and is the opposite of the CL convention. (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))." - #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - - s7_pointer x = car(args), y = cadr(args); - s7_int index; /* index in gmp is mp_bitcnt which is an unsigned long int */ - - if (!s7_is_integer(x)) - return(method_or_bust(sc, x, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 1)); - if (!s7_is_integer(y)) - return(method_or_bust(sc, y, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 2)); - - index = s7_integer_clamped_if_gmp(sc, y); - if (index < 0) - out_of_range_error_nr(sc, sc->logbit_symbol, int_two, y, it_is_negative_string); - -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, (mpz_tstbit(big_integer(x), index) != 0))); -#endif - - if (index >= S7_INT_BITS) /* not sure about the >: (logbit? -1 64) ?? */ - return(make_boolean(sc, integer(x) < 0)); - /* (zero? (logand most-positive-fixnum (ash 1 63))) -> ash argument 2, 63, is out of range (shift is too large) - * so logbit? has a wider range than the logand/ash shuffle above. - */ - - /* all these int64_ts are necessary, else C turns it into an int, gets confused about signs etc */ - return(make_boolean(sc, ((((int64_t)(1LL << (int64_t)index)) & (int64_t)integer(x)) != 0))); -} - -static bool logbit_b_7ii(s7_scheme *sc, s7_int i1, s7_int i2) -{ - if (i2 < 0) - { - out_of_range_error_nr(sc, sc->logbit_symbol, int_two, wrap_integer(sc, i1), it_is_negative_string); - return(false); - } - if (i2 >= S7_INT_BITS) return(i1 < 0); - return((((int64_t)(1LL << (int64_t)i2)) & (int64_t)i1) != 0); -} - -static bool logbit_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (is_t_integer(p1)) - { - if (is_t_integer(p2)) - return(logbit_b_7ii(sc, integer(p1), integer(p2))); - return(method_or_bust(sc, p2, sc->logbit_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_INTEGER], 2) != sc->F); - } -#if WITH_GMP - return(g_logbit(sc, set_plist_2(sc, p1, p2))); -#else - return(method_or_bust(sc, p1, sc->logbit_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_INTEGER], 1) != sc->F); -#endif -} - - -/* -------------------------------- ash -------------------------------- */ -static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2) -{ - if (arg1 == 0) return(0); - if (arg2 >= S7_INT_BITS) - { - if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */ - return(S7_INT64_MIN); - out_of_range_error_nr(sc, sc->ash_symbol, int_two, wrap_integer(sc, arg2), it_is_too_large_string); - } - if (arg2 < -S7_INT_BITS) - return((arg1 < 0) ? -1 : 0); /* (ash -31 -100) */ - - /* I can't see any point in protecting this: (ash 9223372036854775807 1) -> -2, but anyone using ash must know something about bits */ - if (arg2 < 0) - return(arg1 >> -arg2); - if (arg1 < 0) - { - uint64_t z = (uint64_t)arg1; - return((s7_int)(z << arg2)); - } - return(arg1 << arg2); -} - -static s7_pointer g_ash(s7_scheme *sc, s7_pointer args) -{ - #define H_ash "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1" - #define Q_ash sc->pcl_i - -#if WITH_GMP - /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums */ - s7_pointer p0 = car(args), p1 = cadr(args); - - /* here, as in expt, there are cases like (ash 1 63) which need to be bignums so there's no easy way to tell when it's safe to drop into g_ash instead */ - if ((s7_is_integer(p0)) && /* this includes bignum ints... */ - (s7_is_integer(p1))) - { - s7_int shift; - bool p0_is_big = is_big_number(p0); - int32_t p0_compared_to_zero = 0; - - if (p0_is_big) - p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0); - else - if (integer(p0) > 0) - p0_compared_to_zero = 1; - else p0_compared_to_zero = (integer(p0) < 0) ? -1 : 0; - - if (p0_compared_to_zero == 0) - return(int_zero); - - if (is_big_number(p1)) - { - if (!mpz_fits_sint_p(big_integer(p1))) - { - if (mpz_cmp_ui(big_integer(p1), 0) > 0) - out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); - - /* here if p0 is negative, we need to return -1 */ - return((p0_compared_to_zero == 1) ? int_zero : minus_one); - } - shift = mpz_get_si(big_integer(p1)); - } - else - { - shift = integer(p1); - if (shift < S7_INT32_MIN) - return((p0_compared_to_zero == 1) ? int_zero : minus_one); - } - if (shift > S7_INT32_MAX) - out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); /* gmp calls abort if overflow here */ - - if (is_t_big_integer(p0)) - mpz_set(sc->mpz_1, big_integer(p0)); - else mpz_set_si(sc->mpz_1, integer(p0)); - - if (shift > 0) /* left */ - mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift); - else - if (shift < 0) /* right */ - mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift)); - - return(mpz_to_integer(sc, sc->mpz_1)); - } - /* else fall through */ -#endif - s7_pointer x = car(args), y = cadr(args); - - if (!s7_is_integer(x)) - return(method_or_bust(sc, x, sc->ash_symbol, args, sc->type_names[T_INTEGER], 1)); - if (!s7_is_integer(y)) - return(method_or_bust(sc, y, sc->ash_symbol, args, sc->type_names[T_INTEGER], 2)); - return(make_integer(sc, c_ash(sc, s7_integer_clamped_if_gmp(sc, x), s7_integer_clamped_if_gmp(sc, y)))); -} - -#if (!WITH_GMP) - static s7_int ash_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_ash(sc, i1, i2));} -#endif -static s7_int lsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 << i2);} /* this may need gmp special handling, and out-of-range as in c_ash */ -static s7_int rsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 >> (-i2));} -static s7_int rsh_i_i2_direct(s7_int i1, s7_int unused_i2) {return(i1 >> 1);} - - -/* -------------------------------- random-state -------------------------------- */ -/* random numbers. The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm. - * (random num) -> a number (0..num), if num == 0 return 0, use global default state - * (random num state) -> same but use this state - * (random-state seed) -> make a new state - * to save the current seed, use copy, to save it across load, random-state->list and list->random-state. - * random-state? returns #t if its arg is one of these guys - */ - -static s7_pointer random_state_copy(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(sc->F); /* I can't find a way to copy a gmp random generator */ -#else - s7_pointer new_r, obj = car(args); - if (!is_random_state(obj)) return(sc->F); - new_cell(sc, new_r, T_RANDOM_STATE); - random_seed(new_r) = random_seed(obj); - random_carry(new_r) = random_carry(obj); - return(new_r); -#endif -} -#if S7_DEBUGGING && (!WITH_GMP) - static s7_int last_carry = 0; - /* 2083801278 */ -#endif - -s7_pointer s7_random_state(s7_scheme *sc, s7_pointer args) -{ - #define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \ -Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\ - (let ((seed (random-state 1234))) (random 1.0 seed))" - #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol) - -#if WITH_GMP - s7_pointer r, seed; - if (is_null(args)) - return(sc->F); /* how to find current state, if any? */ - - seed = car(args); - if (!s7_is_integer(seed)) - return(sole_arg_method_or_bust(sc, seed, sc->random_state_symbol, args, sc->type_names[T_INTEGER])); - - if (is_t_integer(seed)) - seed = s7_int_to_big_integer(sc, integer(seed)); - - new_cell(sc, r, T_RANDOM_STATE); - gmp_randinit_default(random_gmp_state(r)); /* Mersenne twister */ - gmp_randseed(random_gmp_state(r), big_integer(seed)); /* this is ridiculously slow! */ - add_big_random_state(sc, r); - return(r); -#else - s7_pointer r1, r2, p; - s7_int i1, i2; - if (is_null(args)) - return(sc->default_random_state); - - r1 = car(args); - if (!s7_is_integer(r1)) - return(method_or_bust(sc, r1, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 1)); - i1 = integer(r1); - if (i1 < 0) - out_of_range_error_nr(sc, sc->random_state_symbol, int_one, r1, it_is_negative_string); - if (is_null(cdr(args))) - { - new_cell(sc, p, T_RANDOM_STATE); - random_seed(p) = (uint64_t)i1; - random_carry(p) = 1675393560; /* should this be dependent on the seed? */ -#if S7_DEBUGGING - last_carry = 1675393560; -#endif - return(p); - } - - r2 = cadr(args); - if (!s7_is_integer(r2)) - return(method_or_bust(sc, r2, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 2)); - i2 = integer(r2); - if (i2 < 0) - out_of_range_error_nr(sc, sc->random_state_symbol, int_two, r2, it_is_negative_string); - - new_cell(sc, p, T_RANDOM_STATE); - random_seed(p) = (uint64_t)i1; - random_carry(p) = (uint64_t)i2; -#if S7_DEBUGGING - last_carry = i2; -#endif - return(p); -#endif -} - -#define g_random_state s7_random_state - -static s7_pointer random_state_getter(s7_scheme *sc, s7_pointer r, s7_int loc) -{ -#if (!WITH_GMP) - if (loc == 0) return(make_integer(sc, random_seed(r))); - if (loc == 1) return(make_integer(sc, random_carry(r))); -#endif - return(sc->F); -} - -static s7_pointer random_state_setter(s7_scheme *sc, s7_pointer r, s7_int loc, s7_pointer val) -{ -#if (!WITH_GMP) - if (is_t_integer(val)) - { - s7_int i = s7_integer_clamped_if_gmp(sc, val); - if (loc == 0) random_seed(r) = i; - if (loc == 1) random_carry(r) = i; - } -#endif - return(sc->F); -} - - -/* -------------------------------- random-state? -------------------------------- */ -static s7_pointer g_is_random_state(s7_scheme *sc, s7_pointer args) -{ - #define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)." - #define Q_is_random_state sc->pl_bt - check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, args); -} - -bool s7_is_random_state(s7_pointer p) {return(type(p) == T_RANDOM_STATE);} - - -/* -------------------------------- random-state->list -------------------------------- */ -s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\ -You can later apply random-state to this list to continue a random number sequence from any point." - #define Q_random_state_to_list s7_make_signature(sc, 2, (WITH_GMP) ? sc->is_list_symbol : sc->is_pair_symbol, sc->is_random_state_symbol) - -#if WITH_GMP - if ((is_pair(args)) && - (!is_random_state(car(args)))) - return(method_or_bust(sc, car(args), sc->random_state_to_list_symbol, args, a_random_state_object_string, 1)); - return(sc->nil); -#else - s7_pointer r = (is_null(args)) ? sc->default_random_state : car(args); - if (!is_random_state(r)) - return(method_or_bust(sc, r, sc->random_state_to_list_symbol, args, a_random_state_object_string, 1)); - return(list_2(sc, make_integer(sc, random_seed(r)), make_integer_unchecked(sc, random_carry(r)))); -#endif -} - -#define g_random_state_to_list s7_random_state_to_list - -void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry) -{ -#if (!WITH_GMP) - s7_pointer p; - new_cell(sc, p, T_RANDOM_STATE); - random_seed(p) = (uint64_t)seed; - random_carry(p) = (uint64_t)carry; - sc->default_random_state = p; -#endif -} - - -/* -------------------------------- random -------------------------------- */ -#if WITH_GMP -static double next_random(s7_scheme *sc) -#else -static double next_random(s7_pointer r) -#endif -{ -#if (!WITH_GMP) - /* The multiply-with-carry generator for 32-bit integers: - * x(n)=a*x(n-1) + carry mod 2^32 - * Choose multiplier a from this list: - * 1791398085 1929682203 1683268614 1965537969 1675393560 1967773755 1517746329 1447497129 1655692410 1606218150 - * 2051013963 1075433238 1557985959 1781943330 1893513180 1631296680 2131995753 2083801278 1873196400 1554115554 - * ( or any 'a' for which both a*2^32-1 and a*2^31-1 are prime) - */ - #define RAN_MULT 2131995753UL - - double result; - uint64_t temp = random_seed(r) * RAN_MULT + random_carry(r); - random_seed(r) = (temp & 0xffffffffUL); - random_carry(r) = (temp >> 32); - result = (double)((uint32_t)(random_seed(r))) / 4294967295.5; - /* divisor was 2^32-1 = 4294967295.0, but somehow this can round up once in a billion tries? - * do we want the double just less than 2^32? - * can the multiply-add+logand above return 0? I'm getting 0's from (random (expt 2 62)) - */ - - /* (let ((mx 0) (mn 1000)) (do ((i 0 (+ i 1))) ((= i 10000)) (let ((val (random 123))) (set! mx (max mx val)) (set! mn (min mn val)))) (list mn mx)) */ - return(result); -#else - mpfr_urandomb(sc->mpfr_1, random_gmp_state(sc->default_random_state)); - return(mpfr_get_d(sc->mpfr_1, MPFR_RNDN)); -#endif -} - -static s7_pointer g_random(s7_scheme *sc, s7_pointer args) -{ - #define H_random "(random num (state #f)) returns a random number of the same type as num between zero and num, equalling num only if num is zero" - #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol) - s7_pointer r, num; - - /* if we disallow (random 0) the programmer has to protect every call on random with (if (eqv? x 0) 0 (random x)). If - * we claim we're using a half-open interval, then we should also disallow (random 0.0); otherwise the following - * must be true: (let* ((x 0.0) (y (random x))) (and (>= y 0.0) (< y x))). The definition above is consistent - * with (random 0) -> 0, simpler to use in practice, and certainly no worse than (/ 0 0) -> 1. - */ - if (is_null(cdr(args))) - r = sc->default_random_state; - else - { - r = cadr(args); - if (!is_random_state(r)) - return(method_or_bust(sc, r, sc->random_symbol, args, a_random_state_object_string, 2)); - } - num = car(args); - switch (type(num)) - { -#if (!WITH_GMP) - case T_INTEGER: - return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); - case T_RATIO: - { - s7_double x = fraction(num), error; - s7_int numer = 0, denom = 1; - /* the error here needs to take the size of the fraction into account. Otherwise, if - * error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807, - * c_rationalize will always return 0. But even that isn't foolproof: - * (random 1/562949953421312) -> 1/376367230475000 - */ - if ((x < 1.0e-10) && (x > -1.0e-10)) - { - /* 1e-12 is not tight enough: - * (random 1/2251799813685248) -> 1/2250240579436280 - * (random -1/4503599627370496) -> -1/4492889778435526 - * (random 1/140737488355328) -> 1/140730223985746 - * (random -1/35184372088832) -> -1/35183145492420 - * (random -1/70368744177664) -> -1/70366866392738 - * (random 1/4398046511104) -> 1/4398033095756 - * (random 1/137438953472) -> 1/137438941127 - */ - if (numerator(num) < -10) - numer = -(s7_int)(floor(-numerator(num) * next_random(r))); - else - if (numerator(num) > 10) - numer = (s7_int)floor(numerator(num) * next_random(r)); - else - { - int64_t diff = S7_INT64_MAX - denominator(num); - numer = numerator(num); - if (diff < 100) - return(make_ratio(sc, numer, denominator(num))); - denom = denominator(num) + (s7_int)floor(diff * next_random(r)); - return(make_ratio_with_div_check(sc, sc->random_symbol, numer, denom)); - } - return(make_ratio(sc, numer, denominator(num))); - } - error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; - c_rationalize(x * next_random(r), error, &numer, &denom); - return(make_ratio(sc, numer, denom)); - } - case T_REAL: - return(make_real(sc, real(num) * next_random(r))); - case T_COMPLEX: - return(s7_make_complex(sc, real_part(num) * next_random(r), imag_part(num) * next_random(r))); -#else - case T_INTEGER: - if (integer(num) == 0) return(int_zero); - mpz_set_si(sc->mpz_1, integer(num)); - mpz_urandomm(sc->mpz_1, random_gmp_state(r), sc->mpz_1); - if (integer(num) < 0) mpz_neg(sc->mpz_1, sc->mpz_1); - return(make_integer(sc, mpz_get_si(sc->mpz_1))); - case T_BIG_INTEGER: - if (mpz_cmp_si(big_integer(num), 0) == 0) return(int_zero); - mpz_urandomm(sc->mpz_1, random_gmp_state(r), big_integer(num)); - /* this does not work if num is a negative number -- you get positive results. so check num for sign, and negate result if necessary */ - if (mpz_cmp_ui(big_integer(num), 0) < 0) - mpz_neg(sc->mpz_1, sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, MPFR_RNDN); - return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2)))); - case T_BIG_RATIO: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(num), MPFR_RNDN); - mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, MPFR_RNDN); - return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2)))); - case T_REAL: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(num), MPFR_RNDN); - return(make_real(sc, mpfr_get_d(sc->mpfr_1, MPFR_RNDN))); - case T_BIG_REAL: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, big_real(num), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_urandom(sc->mpc_1, random_gmp_state(r)); - mpfr_mul_d(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), real_part(num), MPFR_RNDN); - mpfr_mul_d(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), imag_part(num), MPFR_RNDN); - return(s7_make_complex(sc, mpfr_get_d(mpc_realref(sc->mpc_1), MPFR_RNDN), mpfr_get_d(mpc_imagref(sc->mpc_1), MPFR_RNDN))); - case T_BIG_COMPLEX: - mpc_urandom(sc->mpc_1, random_gmp_state(r)); - mpfr_mul(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), mpc_realref(big_complex(num)), MPFR_RNDN); - mpfr_mul(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), mpc_imagref(big_complex(num)), MPFR_RNDN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust(sc, num, sc->random_symbol, args, a_number_string, 1)); - } - return(sc->F); -} - -s7_double s7_random(s7_scheme *sc, s7_pointer state) -{ -#if WITH_GMP - mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); - mpfr_urandomb(sc->mpfr_1, random_gmp_state((state) ? state : sc->default_random_state)); - return((s7_double)mpfr_get_d(sc->mpfr_1, MPFR_RNDN)); -#else - return(next_random((state) ? state : sc->default_random_state)); -#endif -} - -static s7_double random_d_7d(s7_scheme *sc, s7_double x) -{ -#if WITH_GMP - return(real(g_random(sc, set_plist_1(sc, wrap_real(sc, x))))); -#else - return(x * next_random(sc->default_random_state)); -#endif -} - -static s7_int random_i_7i(s7_scheme *sc, s7_int i) -{ -#if WITH_GMP - return(integer(g_random(sc, set_plist_1(sc, wrap_integer(sc, i))))); -#else - return((s7_int)(i * next_random(sc->default_random_state))); -#endif -} - -static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(g_random(sc, args)); -#else - return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_random_state)))); -#endif -} - -static s7_pointer g_random_f(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(g_random(sc, args)); -#else - return(make_real(sc, real(car(args)) * next_random(sc->default_random_state))); -#endif -} - -static s7_pointer g_random_1(s7_scheme *sc, s7_pointer args) -{ -#if (!WITH_GMP) - s7_pointer num = car(args), r = sc->default_random_state; - if (is_t_integer(num)) - return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); - if (is_t_real(num)) - return(make_real(sc, real(num) * next_random(r))); -#endif - return(g_random(sc, args)); -} - -static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num) -{ -#if (!WITH_GMP) - if (is_t_integer(num)) - return(make_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state)))); - if (is_t_real(num)) - return(make_real(sc, real(num) * next_random(sc->default_random_state))); -#endif - return(g_random(sc, set_plist_1(sc, num))); -} - -static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if ((ops) && (args == 1)) - { - s7_pointer arg1 = cadr(expr); - if (is_t_integer(arg1)) - return(sc->random_i); - return((is_t_real(arg1)) ? sc->random_f : sc->random_1); - } - return(f); -} - -static s7_pointer g_add_i_random(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(add_p_pp(sc, car(args), random_p_p(sc, cadadr(args)))); -#else - s7_int x = integer(car(args)), y = opt3_int(args); /* cadadr */ - return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ -#endif -} - - -/* -------------------------------- char<->integer -------------------------------- */ -static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args) -{ - #define H_char_to_integer "(char->integer c) converts the character c to an integer" - #define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol) - - if (!is_character(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->char_to_integer_symbol, args, sc->type_names[T_CHARACTER])); - return(small_int(character(car(args)))); -} - -static s7_int char_to_integer_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_character(p)) - return(integer(method_or_bust_p(sc, p, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER]))); - return(character(p)); -} - -static s7_pointer char_to_integer_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_character(p)) - return(method_or_bust_p(sc, p, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER])); - return(make_integer(sc, character(p))); -} - -static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x) -{ - s7_int ind; - if (!s7_is_integer(x)) - return(method_or_bust_p(sc, x, sc->integer_to_char_symbol, sc->type_names[T_INTEGER])); - ind = s7_integer_clamped_if_gmp(sc, x); - if ((ind < 0) || (ind >= NUM_CHARS)) - sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, x, wrap_string(sc, "it doen't fit in an unsigned byte", 33)); - return(chars[(uint8_t)ind]); -} - -static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args) -{ - #define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character" - #define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol) - return(integer_to_char_p_p(sc, car(args))); -} - -static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind) -{ - if ((ind < 0) || (ind >= NUM_CHARS)) - sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, wrap_integer(sc, ind), - wrap_string(sc, "it doen't fit in an unsigned byte", 33)); /* int2 s7_out... uses 1 */ - return(chars[(uint8_t)ind]); -} - - -static uint8_t uppers[256], lowers[256]; -static void init_uppers(void) -{ - for (int32_t i = 0; i < 256; i++) - { - uppers[i] = (uint8_t)toupper(i); - lowers[i] = (uint8_t)tolower(i); - } -} - -static void init_chars(void) -{ - s7_cell *cells = (s7_cell *)Calloc(NUM_CHARS + 1, sizeof(s7_cell)); - - chars = (s7_pointer *)Malloc((NUM_CHARS + 1) * sizeof(s7_pointer)); /* chars is declared far above */ - chars[0] = &cells[0]; - eof_object = chars[0]; - set_full_type(eof_object, T_EOF | T_IMMUTABLE | T_UNHEAP); - eof_name_length(eof_object) = 6; - eof_name(eof_object) = "#"; - chars++; /* now chars[EOF] == chars[-1] == # */ - cells++; - - for (int32_t i = 0; i < NUM_CHARS; i++) - { - s7_pointer cp = &cells[i]; - uint8_t c = (uint8_t)i; - - set_type_bit(cp, T_IMMUTABLE | T_CHARACTER | T_UNHEAP); - set_optimize_op(cp, OP_CONSTANT); - character(cp) = c; - upper_character(cp) = (uint8_t)toupper(i); - is_char_alphabetic(cp) = (bool)isalpha(i); - is_char_numeric(cp) = (bool)isdigit(i); - is_char_whitespace(cp) = white_space[i]; - is_char_uppercase(cp) = (((bool)isupper(i)) || ((i >= 192) && (i < 208))); - is_char_lowercase(cp) = (bool)islower(i); - chars[i] = cp; - - #define make_character_name(S) memcpy((void *)(&(character_name(cp))), (const void *)(S), character_name_length(cp) = strlen(S)) - switch (c) - { - case ' ': make_character_name("#\\space"); break; - case '\n': make_character_name("#\\newline"); break; - case '\r': make_character_name("#\\return"); break; - case '\t': make_character_name("#\\tab"); break; - case '\0': make_character_name("#\\null"); break; - case (char)0x1b: make_character_name("#\\escape"); break; - case (char)0x7f: make_character_name("#\\delete"); break; - case (char)7: make_character_name("#\\alarm"); break; - case (char)8: make_character_name("#\\backspace"); break; - default: - #define P_SIZE 12 - character_name_length(cp) = snprintf((char *)(&(character_name(cp))), P_SIZE, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c); - break; - }} -} - - -/* -------------------------------- char-upcase, char-downcase ----------------------- */ -static s7_pointer char_upcase_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(method_or_bust_p(sc, c, sc->char_upcase_symbol, sc->type_names[T_CHARACTER])); - return(chars[upper_character(c)]); -} - -static s7_pointer char_upcase_p_p_unchecked(s7_scheme *unused_sc, s7_pointer c) {return(chars[upper_character(c)]);} - -static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args) -{ - #define H_char_upcase "(char-upcase c) converts the character c to upper case" - #define Q_char_upcase sc->pcl_c - return(char_upcase_p_p(sc, car(args))); -} - -static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args) -{ - #define H_char_downcase "(char-downcase c) converts the character c to lower case" - #define Q_char_downcase sc->pcl_c - if (!is_character(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->char_downcase_symbol, args, sc->type_names[T_CHARACTER])); - return(chars[lowers[character(car(args))]]); -} - - -/* -------------------------------- char-alphabetic? char-numeric? char-whitespace? -------------------------------- */ -static s7_pointer g_is_char_alphabetic(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic" - #define Q_is_char_alphabetic sc->pl_bc - if (!is_character(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->is_char_alphabetic_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_alphabetic(car(args)))); - /* isalpha returns #t for (integer->char 226) and others in that range */ -} - -static bool is_char_alphabetic_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_alphabetic_symbol, c, sc->type_names[T_CHARACTER]); - /* return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* slower? see tmisc */ - return(is_char_alphabetic(c)); -} - -static s7_pointer is_char_alphabetic_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_alphabetic(c))); -} - -static s7_pointer g_is_char_numeric(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit" - #define Q_is_char_numeric sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_numeric_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_numeric(arg))); -} - -static bool is_char_numeric_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_numeric_symbol, c, sc->type_names[T_CHARACTER]); - /* return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* as above */ - return(is_char_numeric(c)); -} - -static s7_pointer is_char_numeric_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_numeric(c))); -} - - -static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character" - #define Q_is_char_whitespace sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_whitespace_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_whitespace(arg))); -} - -static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_whitespace_symbol, c, sc->type_names[T_CHARACTER]); - return(is_char_whitespace(c)); -} - -static s7_pointer is_char_whitespace_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_whitespace(c))); -} - -static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(make_boolean(sc, is_char_whitespace(c)));} - - -/* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */ -static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case" - #define Q_is_char_upper_case sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_upper_case_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_uppercase(arg))); -} - -static bool is_char_upper_case_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); - return(is_char_uppercase(c)); -} - -static s7_pointer g_is_char_lower_case(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case" - #define Q_is_char_lower_case sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_lower_case_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_lowercase(arg))); -} - -static bool is_char_lower_case_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); - return(is_char_lowercase(c)); -} - - -/* -------------------------------- char? -------------------------------- */ -static s7_pointer g_is_char(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char "(char? obj) returns #t if obj is a character" - #define Q_is_char sc->pl_bt - check_boolean_method(sc, is_character, sc->is_char_symbol, args); -} - -static s7_pointer is_char_p_p(s7_scheme *sc, s7_pointer p) {return((is_character(p)) ? sc->T : sc->F);} - -s7_pointer s7_make_character(s7_scheme *sc, uint8_t c) {return(chars[c]);} - -bool s7_is_character(s7_pointer p) {return(is_character(p));} - -uint8_t s7_character(s7_pointer p) {return(character(p));} - - -/* -------------------------------- char? char>=? char=? -------------------------------- */ -static int32_t charcmp(uint8_t c1, uint8_t c2) -{ - return((c1 == c2) ? 0 : (c1 < c2) ? -1 : 1); - /* not tolower here -- the single case is apparently supposed to be upper case - * this matters in a case like (char-ciis_char_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -static s7_pointer char_with_error_check(s7_scheme *sc, s7_pointer x, s7_pointer args, s7_pointer caller) -{ - for (s7_pointer y = cdr(x); is_pair(y); y = cdr(y)) /* before returning #f, check for bad trailing arguments */ - if (!is_character_via_method(sc, car(y))) - wrong_type_error_nr(sc, caller, position_of(y, args), car(y), sc->type_names[T_CHARACTER]); - return(sc->F); -} - -static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(character(y), character(car(x))) != val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(character(y), character(car(x))) == val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_equal "(char=? char ...) returns #t if all the character arguments are equal" - #define Q_chars_are_equal sc->pcl_bc - - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (car(x) != y) - return(char_with_error_check(sc, x, args, sc->char_eq_symbol)); - } - return(sc->T); -} - - -static s7_pointer g_chars_are_less(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_less "(charpcl_bc - return(g_char_cmp(sc, args, -1, sc->char_lt_symbol)); -} - -static s7_pointer g_chars_are_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing" - #define Q_chars_are_greater sc->pcl_bc - return(g_char_cmp(sc, args, 1, sc->char_gt_symbol)); -} - -static s7_pointer g_chars_are_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing" - #define Q_chars_are_geq sc->pcl_bc - return(g_char_cmp_not(sc, args, -1, sc->char_geq_symbol)); -} - -static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing" - #define Q_chars_are_leq sc->pcl_bc - return(g_char_cmp_not(sc, args, 1, sc->char_leq_symbol)); -} - -static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, car(args) == cadr(args)));} /* chooser checks types */ - -#define check_char2_args(Sc, Caller, P1, P2) \ - do { \ - if (!is_character(P1)) return(method_or_bust(Sc, P1, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_CHARACTER], 1) != sc->F); \ - if (!is_character(P2)) return(method_or_bust(Sc, P2, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_CHARACTER], 2) != sc->F); \ - } while (0) - -static bool char_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 < p2);} -static bool char_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_lt_symbol, p1, p2); - return(p1 < p2); -} - -static bool char_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 <= p2);} -static bool char_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_leq_symbol, p1, p2); - return(p1 <= p2); -} - -static bool char_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 > p2);} -static bool char_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_gt_symbol, p1, p2); - return(p1 > p2); -} - -static bool char_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 >= p2);} -static bool char_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_geq_symbol, p1, p2); - return(p1 >= p2); -} - -static bool char_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 == p2);} - -static bool char_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 1) != sc->F); - if (p1 == p2) return(true); - if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 2) != sc->F); - return(false); -} - -static s7_pointer char_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 1)); - if (p1 == p2) return(sc->T); - if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 2)); - return(sc->F); -} - -static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1)); - if (car(args) == cadr(args)) - return(sc->T); - if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 2)); - return(sc->F); -} - -static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 1)); - if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 2)); - return(make_boolean(sc, character(car(args)) < character(cadr(args)))); -} - -static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 1)); - if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 2)); - return(make_boolean(sc, character(car(args)) > character(cadr(args)))); -} - -static bool returns_char(s7_scheme *sc, s7_pointer arg) {return(argument_type(sc, arg) == sc->is_char_symbol);} - -static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if ((returns_char(sc, arg1)) && (returns_char(sc, arg2))) - return(sc->simple_char_eq); - } - return(sc->char_equal_2); -} - -static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->char_less_2 : f); -} - -static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->char_greater_2 : f); -} - - -/* -------------------------------- char-ci? char-ci>=? char-ci=? -------------------------------- */ -#if (!WITH_PURE_S7) -static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(upper_character(y), upper_character(car(x))) != val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(upper_character(y), upper_character(car(x))) == val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_chars_are_ci_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case" - #define Q_chars_are_ci_equal sc->pcl_bc - return(g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol)); -} - -static s7_pointer g_chars_are_ci_less(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_less "(char-cipcl_bc - return(g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol)); -} - -static s7_pointer g_chars_are_ci_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case" - #define Q_chars_are_ci_greater sc->pcl_bc - return(g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol)); -} - -static s7_pointer g_chars_are_ci_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case" - #define Q_chars_are_ci_geq sc->pcl_bc - return(g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol)); -} - -static s7_pointer g_chars_are_ci_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case" - #define Q_chars_are_ci_leq sc->pcl_bc - return(g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol)); -} - - -static bool char_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) < upper_character(p2));} -static bool char_ci_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_lt_symbol, p1, p2); - return(upper_character(p1) < upper_character(p2)); -} - -static bool char_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) <= upper_character(p2));} -static bool char_ci_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_leq_symbol, p1, p2); - return(upper_character(p1) <= upper_character(p2)); -} - -static bool char_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) > upper_character(p2));} -static bool char_ci_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_gt_symbol, p1, p2); - return(upper_character(p1) > upper_character(p2)); -} - -static bool char_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) >= upper_character(p2));} -static bool char_ci_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_geq_symbol, p1, p2); - return(upper_character(p1) >= upper_character(p2)); -} - -static bool char_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) == upper_character(p2));} -static bool char_ci_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_eq_symbol, p1, p2); - return(upper_character(p1) == upper_character(p2)); -} - -#endif /* not pure s7 */ - - -/* -------------------------------- char-position -------------------------------- */ -static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args) -{ - #define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f" - #define Q_char_position s7_make_signature(sc, 4, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), \ - sc->is_string_symbol, sc->is_integer_symbol) - const char *porig, *pset; - s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */ - s7_pointer arg1 = car(args), arg2; - - if ((!is_character(arg1)) && - (!is_string(arg1))) - return(method_or_bust(sc, arg1, sc->char_position_symbol, args, sc->type_names[T_CHARACTER], 1)); - - arg2 = cadr(args); - if (!is_string(arg2)) - return(method_or_bust(sc, arg2, sc->char_position_symbol, args, sc->type_names[T_STRING], 2)); - - if (is_pair(cddr(args))) - { - s7_pointer arg3 = caddr(args); - if (!s7_is_integer(arg3)) - return(method_or_bust(sc, arg3, sc->char_position_symbol, args, sc->type_names[T_INTEGER], 3)); - start = s7_integer_clamped_if_gmp(sc, arg3); - if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); - } - else start = 0; - - porig = string_value(arg2); - len = string_length(arg2); - if (start >= len) return(sc->F); - - if (is_character(arg1)) - { - char c = character(arg1); - const char *p = strchr((const char *)(porig + start), (int)c); /* use strchrnul in Gnu C to catch embedded null case */ - return((p) ? make_integer(sc, p - porig) : sc->F); - } - if (string_length(arg1) == 0) - return(sc->F); - pset = string_value(arg1); - - pos = strcspn((const char *)(porig + start), (const char *)pset); - if ((pos + start) < len) - return(make_integer(sc, pos + start)); - - /* if the string has an embedded null, we can get erroneous results here -- - * perhaps check for null at pos+start? What about a searched-for string that also has embedded nulls? - */ - return(sc->F); -} - -static s7_pointer char_position_p_ppi(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int start) -{ - /* p1 is char, p2 is string */ - const char *porig, *p; - s7_int len; - char c; - - if (!is_string(p2)) - wrong_type_error_nr(sc, sc->char_position_symbol, 2, p2, sc->type_names[T_STRING]); - if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, wrap_integer(sc, start), a_non_negative_integer_string); - - c = character(p1); - len = string_length(p2); - porig = string_value(p2); - if (start >= len) return(sc->F); - p = strchr((const char *)(porig + start), (int)c); - if (p) return(make_integer(sc, p - porig)); - return(sc->F); -} - -static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args) -{ - /* assume char arg1, no end */ - const char *porig, *p; - char c = character(car(args)); - s7_pointer arg2 = cadr(args); - s7_int start, len; - - if (!is_string(arg2)) - return(g_char_position(sc, args)); - - len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */ - porig = string_value(arg2); - - if (is_pair(cddr(args))) - { - s7_pointer arg3 = caddr(args); - if (!s7_is_integer(arg3)) - return(g_char_position(sc, args)); - start = s7_integer_clamped_if_gmp(sc, arg3); - if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); - if (start >= len) return(sc->F); - } - else start = 0; - - if (len == 0) return(sc->F); - p = strchr((const char *)(porig + start), (int)c); - return((p) ? make_integer(sc, p - porig) : sc->F); -} - -static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((is_character(cadr(expr))) && ((args == 2) || (args == 3))) - return(sc->char_position_csi); - return(f); -} - - -/* -------------------------------- string-position -------------------------------- */ -static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args) -{ - #define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f" - #define Q_string_position s7_make_signature(sc, 4, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \ - sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol) - const char *s1, *s2, *p2; - s7_int start = 0; - s7_pointer s1p = car(args), s2p = cadr(args); - - if (!is_string(s1p)) - return(method_or_bust(sc, s1p, sc->string_position_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(s2p)) - return(method_or_bust(sc, s2p, sc->string_position_symbol, args, sc->type_names[T_STRING], 2)); - - if (is_pair(cddr(args))) - { - s7_pointer arg3 = caddr(args); - if (!s7_is_integer(arg3)) - return(method_or_bust(sc, arg3, sc->string_position_symbol, args, sc->type_names[T_INTEGER], 3)); - start = s7_integer_clamped_if_gmp(sc, arg3); - if (start < 0) - wrong_type_error_nr(sc, sc->string_position_symbol, 3, caddr(args), a_non_negative_integer_string); - } - - if (string_length(s1p) == 0) - return(sc->F); - s1 = string_value(s1p); - s2 = string_value(s2p); - if (start >= string_length(s2p)) - return(sc->F); - - p2 = strstr((const char *)(s2 + start), s1); - return((p2) ? make_integer(sc, p2 - s2) : sc->F); -} - - -/* -------------------------------- strings -------------------------------- */ -bool s7_is_string(s7_pointer p) {return(is_string(p));} - -static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args) -{ - #define H_is_string "(string? obj) returns #t if obj is a string" - #define Q_is_string sc->pl_bt - check_boolean_method(sc, is_string, sc->is_string_symbol, args); -} - - -static s7_pointer nil_string; /* permanent "" */ - -s7_int s7_string_length(s7_pointer str) {return(string_length(str));} - - -#define NUM_STRING_WRAPPERS 8 - -static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) -{ - s7_pointer x = car(sc->string_wrappers); - sc->string_wrappers = cdr(sc->string_wrappers); - string_value(x) = (char *)str; - string_length(x) = len; - return(x); -} - -s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str) {return(wrap_string(sc, str, safe_strlen(str)));} -s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len) {return(wrap_string(sc, str, len));} - -static Inline s7_pointer inline_make_empty_string(s7_scheme *sc, s7_int len, char fill) -{ - s7_pointer x; - block_t *b; - if (len == 0) return(nil_string); - new_cell(sc, x, T_STRING); - b = inline_mallocate(sc, len + 1); - string_block(x) = b; - string_value(x) = (char *)block_data(b); - if (fill != '\0') - local_memset((void *)(string_value(x)), fill, len); - string_value(x)[len] = 0; - string_hash(x) = 0; - string_length(x) = len; - add_string(sc, x); - return(x); -} - -static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));} - -s7_pointer s7_make_string(s7_scheme *sc, const char *str) {return((str) ? make_string_with_length(sc, str, safe_strlen(str)) : nil_string);} - -static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */ -{ - s7_int len = safe_strlen(str); - char *x = (char *)permalloc(sc, len + 1); - memcpy((void *)x, (void *)str, len); - x[len] = 0; - return(x); -} - -s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str) /* for (s7) string permanent within one s7 instance (freed upon s7_free) */ -{ - s7_pointer x; - s7_int len; - if (!str) return(nil_string); - x = alloc_pointer(sc); - set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); - set_optimize_op(x, OP_CONSTANT); - len = safe_strlen(str); - string_length(x) = len; - string_block(x) = NULL; - string_value(x) = (char *)permalloc(sc, len + 1); - memcpy((void *)string_value(x), (void *)str, len); - string_value(x)[len] = 0; - string_hash(x) = 0; - return(x); -} - -static s7_pointer make_permanent_string(const char *str) /* for (s7) strings outside all s7 GC's */ -{ - s7_pointer x = (s7_pointer)Calloc(1, sizeof(s7_cell)); - s7_int len = safe_strlen(str); - set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); - set_optimize_op(x, OP_CONSTANT); - string_length(x) = len; - string_block(x) = NULL; - string_value(x) = (char *)str; - string_hash(x) = 0; - return(x); -} - -s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str) /* keep s7_scheme* arg for backwards compatibility */ -{ - return(make_permanent_string(str)); -} - -static void init_strings(void) -{ - nil_string = make_permanent_string(""); - nil_string->tf.flag = T_STRING | T_UNHEAP; - set_optimize_op(nil_string, OP_CONSTANT); - - car_a_list_string = make_permanent_string("a pair whose car is also a pair"); - cdr_a_list_string = make_permanent_string("a pair whose cdr is also a pair"); - - caar_a_list_string = make_permanent_string("a pair whose caar is also a pair"); - cadr_a_list_string = make_permanent_string("a pair whose cadr is also a pair"); - cdar_a_list_string = make_permanent_string("a pair whose cdar is also a pair"); - cddr_a_list_string = make_permanent_string("a pair whose cddr is also a pair"); - - caaar_a_list_string = make_permanent_string("a pair whose caaar is also a pair"); - caadr_a_list_string = make_permanent_string("a pair whose caadr is also a pair"); - cadar_a_list_string = make_permanent_string("a pair whose cadar is also a pair"); - caddr_a_list_string = make_permanent_string("a pair whose caddr is also a pair"); - cdaar_a_list_string = make_permanent_string("a pair whose cdaar is also a pair"); - cdadr_a_list_string = make_permanent_string("a pair whose cdadr is also a pair"); - cddar_a_list_string = make_permanent_string("a pair whose cddar is also a pair"); - cdddr_a_list_string = make_permanent_string("a pair whose cdddr is also a pair"); - - a_list_string = make_permanent_string("a list"); - an_eq_func_string = make_permanent_string("a procedure that can take two arguments"); - an_association_list_string = make_permanent_string("an association list"); - a_normal_real_string = make_permanent_string("a normal real"); - a_rational_string = make_permanent_string("an integer or a ratio"); - a_number_string = make_permanent_string("a number"); - a_procedure_string = make_permanent_string("a procedure"); - a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro"); - a_normal_procedure_string = make_permanent_string("a normal procedure"); - a_let_string = make_permanent_string("a let (environment)"); - a_proper_list_string = make_permanent_string("a proper list"); - a_boolean_string = make_permanent_string("a boolean"); - a_byte_vector_string = make_permanent_string("a byte-vector"); - an_input_port_string = make_permanent_string("an input port"); - an_open_input_port_string = make_permanent_string("an open input port"); - an_open_output_port_string = make_permanent_string("an open output port"); - an_output_port_string = make_permanent_string("an output port"); - an_output_port_or_f_string = make_permanent_string("an output port or #f"); - an_input_string_port_string = make_permanent_string("an input string port"); - an_input_file_port_string = make_permanent_string("an input file port"); - an_output_string_port_string = make_permanent_string("an output string port"); - an_output_file_port_string = make_permanent_string("an output file port"); - a_thunk_string = make_permanent_string("a thunk"); - a_symbol_string = make_permanent_string("a symbol"); - a_non_negative_integer_string = make_permanent_string("a non-negative integer"); - an_unsigned_byte_string = make_permanent_string("an unsigned byte"); - something_applicable_string = make_permanent_string("a procedure or something applicable"); - a_random_state_object_string = make_permanent_string("a random-state object"); - a_format_port_string = make_permanent_string("#f, #t, (), or an open output port"); - a_non_constant_symbol_string = make_permanent_string("a non-constant symbol"); - a_sequence_string = make_permanent_string("a sequence"); - a_valid_radix_string = make_permanent_string("it should be between 2 and 16"); - result_is_too_large_string = make_permanent_string("result is too large"); - it_is_too_large_string = make_permanent_string("it is too large"); - it_is_too_small_string = make_permanent_string("it is less than the start position"); - it_is_negative_string = make_permanent_string("it is negative"); - it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error"); - it_is_infinite_string = make_permanent_string("it is infinite"); - too_many_indices_string = make_permanent_string("too many indices"); - parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S"); - immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)"); - cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S"); - intermediate_too_large_string = make_permanent_string("intermediate result is too large"); -#if (!HAVE_COMPLEX_NUMBERS) - no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers"); -#endif - keyword_value_missing_string = make_permanent_string("~A: keyword argument's value is missing: ~S in ~S"); - - format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A"); - format_string_2 = make_permanent_string("format: ~S: ~A"); - format_string_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A"); - format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A"); - - too_many_arguments_string = make_permanent_string("~S: too many arguments: ~A"); - not_enough_arguments_string = make_permanent_string("~S: not enough arguments: ~A"); -} - - -/* -------------------------------- make-string -------------------------------- */ -s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) {return(make_string_with_length(sc, str, len));} - -static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args) -{ - #define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)" - #define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol) - - s7_pointer n = car(args); - s7_int len; - char fill; - if (!s7_is_integer(n)) - { - check_method(sc, n, sc->make_string_symbol, args); - wrong_type_error_nr(sc, sc->make_string_symbol, 1, n, sc->type_names[T_INTEGER]); - } - if ((is_pair(cdr(args))) && - (!is_character(cadr(args)))) - return(method_or_bust(sc, cadr(args), sc->make_string_symbol, args, sc->type_names[T_CHARACTER], 2)); - - len = s7_integer_clamped_if_gmp(sc, n); - if (len == 0) return(nil_string); - if ((len < 0) || (len > sc->max_string_length)) - out_of_range_error_nr(sc, sc->make_string_symbol, int_one, n, (len < 0) ? it_is_negative_string : it_is_too_large_string); - if (is_null(cdr(args))) - return(make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */ - fill = s7_character(cadr(args)); - n = make_empty_string(sc, len, fill); - if (fill == '\0') - memclr((void *)string_value(n), (size_t)len); - return(n); -} - -static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len) -{ - if (len == 0) return(nil_string); - if ((len < 0) || (len > sc->max_string_length)) - out_of_range_error_nr(sc, sc->make_string_symbol, int_one, wrap_integer(sc, len), (len < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_empty_string(sc, len, '\0')); -} - - -#if (!WITH_PURE_S7) -/* -------------------------------- string-length -------------------------------- */ -static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args) -{ - #define H_string_length "(string-length str) returns the length of the string str" - #define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) - s7_pointer p = car(args); - if (!is_string(p)) - return(sole_arg_method_or_bust(sc, p, sc->string_length_symbol, args, sc->type_names[T_STRING])); - return(make_integer(sc, string_length(p))); -} - -static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_string(p)) - return(integer(method_or_bust_p(sc, p, sc->string_length_symbol, sc->type_names[T_STRING]))); - return(string_length(p)); -} -#endif - - -/* -------------------------------- string-up|downcase -------------------------------- */ -static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args) -{ - #define H_string_downcase "(string-downcase str) returns the lower case version of str." - #define Q_string_downcase sc->pcl_s - - s7_pointer p = car(args), newstr; - s7_int i, len; - uint8_t *nstr; - const uint8_t *ostr; - - if (!is_string(p)) - return(method_or_bust_p(sc, p, sc->string_downcase_symbol, sc->type_names[T_STRING])); - len = string_length(p); - newstr = make_empty_string(sc, len, 0); - - ostr = (const uint8_t *)string_value(p); - nstr = (uint8_t *)string_value(newstr); - if (len >= 128) - { - i = len - 1; - while (i >= 8) - LOOP_8(nstr[i] = lowers[(uint8_t)ostr[i]]; i--); - while (i >= 0) {nstr[i] = lowers[(uint8_t)ostr[i]]; i--;} - } - else - for (i = 0; i < len; i++) nstr[i] = lowers[(uint8_t)ostr[i]]; - return(newstr); -} - -static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args) -{ - #define H_string_upcase "(string-upcase str) returns the upper case version of str." - #define Q_string_upcase sc->pcl_s - - s7_pointer p = car(args), newstr; - s7_int i, len; - uint8_t *nstr; - const uint8_t *ostr; - - if (!is_string(p)) - return(method_or_bust_p(sc, p, sc->string_upcase_symbol, sc->type_names[T_STRING])); - len = string_length(p); - newstr = make_empty_string(sc, len, 0); - - ostr = (const uint8_t *)string_value(p); - nstr = (uint8_t *)string_value(newstr); - if (len >= 128) - { - i = len - 1; - while (i >= 8) - LOOP_8(nstr[i] = uppers[(uint8_t)ostr[i]]; i--); - while (i >= 0) {nstr[i] = uppers[(uint8_t)ostr[i]]; i--;} - } - else - for (i = 0; i < len; i++) nstr[i] = uppers[(uint8_t)ostr[i]]; - return(newstr); -} - - -/* -------------------------------- string-ref -------------------------------- */ -static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index) -{ - char *str; - s7_int ind; - - if (!s7_is_integer(index)) - return(method_or_bust_pp(sc, index, sc->string_ref_symbol, strng, index, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if (ind < 0) - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, index, it_is_negative_string); - if (ind >= string_length(strng)) - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, index, it_is_too_large_string); - - str = string_value(strng); - return(chars[((uint8_t *)str)[ind]]); -} - -static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str" - #define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol) - - s7_pointer strng = car(args); - if (!is_string(strng)) - return(method_or_bust(sc, strng, sc->string_ref_symbol, args, sc->type_names[T_STRING], 1)); - return(string_ref_1(sc, strng, cadr(args))); -} - -static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, make_integer(sc, i1)), sc->type_names[T_STRING], 1)); - if ((i1 >= 0) && (i1 < string_length(p1))) - return(chars[((uint8_t *)string_value(p1))[i1]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p1); -} - -static s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer i1) -{ - if (!is_string(p1)) - return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, i1, sc->type_names[T_STRING], 1)); - return(string_ref_1(sc, p1, i1)); -} - -static s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer p1, s7_pointer unused_i1) -{ - if (!is_string(p1)) - return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, int_zero, sc->type_names[T_STRING], 1)); - if (string_length(p1) > 0) - return(chars[((uint8_t *)string_value(p1))[0]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, int_zero, it_is_too_large_string); - return(p1); -} - -static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer p1) -{ - s7_pointer len = method_or_bust_p(sc, p1, sc->length_symbol, sc->type_names[T_STRING]); - return(method_or_bust_with_type_pi(sc, p1, sc->string_ref_symbol, p1, integer(len) - 1, sc->type_names[T_STRING], 1)); -} - -static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer p1, s7_pointer unused_i1) -{ - if (!is_string(p1)) - return(string_plast_via_method(sc, p1)); - if (string_length(p1) > 0) - return(chars[((uint8_t *)string_value(p1))[string_length(p1) - 1]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, string_length(p1) - 1), it_is_too_large_string); - return(p1); -} - -static inline s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if ((i1 >= 0) && (i1 < string_length(p1))) - return(chars[((uint8_t *)string_value(p1))[i1]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p1); -} - -static s7_pointer string_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(chars[((uint8_t *)string_value(p1))[i1]]);} - - -/* -------------------------------- string-set! -------------------------------- */ -static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args) -{ - #define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr" - #define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol) - - s7_pointer strng = car(args), c, index = cadr(args); - char *str; - s7_int ind; - - if (!is_mutable_string(strng)) - return(mutable_method_or_bust(sc, strng, sc->string_set_symbol, args, sc->type_names[T_STRING], 1)); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->string_set_symbol, args, sc->type_names[T_INTEGER], 2)); - - ind = s7_integer_clamped_if_gmp(sc, index); - if (ind < 0) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, a_non_negative_integer_string); - if (ind >= string_length(strng)) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, it_is_too_large_string); - - str = string_value(strng); - c = caddr(args); - if (!is_character(c)) - return(method_or_bust(sc, c, sc->string_set_symbol, args, sc->type_names[T_CHARACTER], 3)); - - str[ind] = (char)s7_character(c); - return(c); -} - -static s7_pointer string_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - if (!is_string(p1)) - wrong_type_error_nr(sc, sc->string_set_symbol, 1, p1, sc->type_names[T_STRING]); - if (!is_character(p2)) - wrong_type_error_nr(sc, sc->string_set_symbol, 2, p2, sc->type_names[T_CHARACTER]); - if ((i1 >= 0) && (i1 < string_length(p1))) - string_value(p1)[i1] = s7_character(p2); - else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p2); -} - -static s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - if ((i1 >= 0) && (i1 < string_length(p1))) - string_value(p1)[i1] = s7_character(p2); - else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p2); -} - -static s7_pointer string_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_pointer p2) {string_value(p1)[i1] = s7_character(p2); return(p2);} - - -/* -------------------------------- string-append -------------------------------- */ -static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj); - -static bool sequence_is_empty(s7_scheme *sc, s7_pointer obj) /* "is_empty" is some C++ struct?? */ -{ - switch (type(obj)) - { - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: return(vector_length(obj) == 0); - case T_NIL: return(true); - case T_PAIR: return(false); - case T_STRING: return(string_length(obj) == 0); - case T_HASH_TABLE: return(hash_table_entries(obj) == 0); - case T_C_OBJECT: return(s7_is_eqv(sc, c_object_length(sc, obj), int_zero)); - case T_LET: if (obj != sc->rootlet) return(!tis_slot(let_slots(obj))); /* (append (rootlet) #f) */ - default: return(false); - } -} - -static s7_int sequence_length(s7_scheme *sc, s7_pointer lst) -{ - switch (type(lst)) - { - case T_PAIR: - { - s7_int len = s7_list_length(sc, lst); - return((len == 0) ? -1 : len); - } - case T_NIL: return(0); - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: return(vector_length(lst)); - case T_STRING: return(string_length(lst)); - case T_HASH_TABLE: return(hash_table_entries(lst)); - case T_LET: return(let_length(sc, lst)); - case T_C_OBJECT: - { - s7_pointer x = c_object_length(sc, lst); - if (s7_is_integer(x)) - return(s7_integer_clamped_if_gmp(sc, x)); - }} - return(-1); -} - -static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args); - -static void string_append_2(s7_scheme *sc, s7_pointer newstr, s7_pointer args, s7_pointer stop_arg, s7_pointer caller) -{ - s7_int len; - char *pos; - s7_pointer x; - for (pos = string_value(newstr), x = args; x != stop_arg; x = cdr(x)) - if (is_string(car(x))) - { - len = string_length(car(x)); - if (len > 0) - { - memcpy(pos, string_value(car(x)), len); - pos += len; - }} - else - if (!sequence_is_empty(sc, car(x))) - { - char *old_str = string_value(newstr); - string_value(newstr) = pos; - len = sequence_length(sc, car(x)); - s7_copy_1(sc, caller, set_plist_2(sc, car(x), newstr)); - string_value(newstr) = old_str; - pos += len; - } -} - -static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - #define H_string_append "(string-append str1 ...) appends all its string arguments into one string" - #define Q_string_append sc->pcl_s - - s7_int len = 0; - s7_pointer x, newstr; - bool just_strings = true; - - if (is_null(args)) - return(nil_string); - - s7_gc_protect_via_stack(sc, args); - /* get length for new string */ - for (x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer p = car(x); - if (is_string(p)) - len += string_length(p); - else - { - s7_int newlen; - if (!is_sequence(p)) - { - unstack(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - if (has_active_methods(sc, p)) /* look for string-append and if found, cobble up a plausible intermediate call */ - { - s7_pointer func = find_method_with_let(sc, p, caller); - if (func != sc->undefined) - { - if (len == 0) - { - unstack(sc); - return(s7_apply_function(sc, func, x)); /* not args (string-append "" "" ...) */ - } - newstr = make_empty_string(sc, len, 0); - string_append_2(sc, newstr, args, x, caller); - unstack(sc); - return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, x))); - }} - if ((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)) - { - unstack(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - newlen = sequence_length(sc, p); - if (newlen < 0) - { - unstack(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - just_strings = false; - len += newlen; - }} - if (len == 0) - { - unstack(sc); - return(nil_string); - } - if (len > sc->max_string_length) - { - unstack(sc); - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), - caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); - } - newstr = inline_make_empty_string(sc, len, 0); - if (just_strings) - { - x = args; - for (char *pos = string_value(newstr); is_not_null(x); x = cdr(x)) - { - len = string_length(car(x)); - if (len > 0) - { - memcpy(pos, string_value(car(x)), len); - pos += len; - }}} - else string_append_2(sc, newstr, args, sc->nil, caller); - unstack(sc); - return(newstr); -} - -static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args) {return(g_string_append_1(sc, args, sc->string_append_symbol));} - -static inline s7_pointer string_append_1(s7_scheme *sc, s7_pointer s1, s7_pointer s2) -{ - if ((is_string(s1)) && (is_string(s2))) - { - s7_int len, pos = string_length(s1); - s7_pointer newstr; - if (pos == 0) return(make_string_with_length(sc, string_value(s2), string_length(s2))); - len = pos + string_length(s2); - if (len == pos) return(make_string_with_length(sc, string_value(s1), string_length(s1))); - if (len > sc->max_string_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), - sc->string_append_symbol, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); - newstr = make_empty_string(sc, len, 0); /* len+1 0-terminated */ - memcpy(string_value(newstr), string_value(s1), pos); - memcpy((char *)(string_value(newstr) + pos), string_value(s2), string_length(s2)); - return(newstr); - } - return(g_string_append_1(sc, list_2(sc, s1, s2), sc->string_append_symbol)); -} - -static s7_pointer string_append_p_pp(s7_scheme *sc, s7_pointer s1, s7_pointer s2) {return(string_append_1(sc, s1, s2));} - -static s7_pointer g_string_append_2(s7_scheme *sc, s7_pointer args) {return(string_append_1(sc, car(args), cadr(args)));} - -static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr); - -static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? sc->string_append_2 : f); -} - - -/* -------------------------------- substring -------------------------------- */ -static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer args, int32_t position, s7_pointer index_args, s7_int *start, s7_int *end) -{ - /* we assume that *start=0 and *end=length, that end is "exclusive", return true if the start/end points are not changed */ - s7_pointer pstart = car(index_args); - s7_int index; - - if (!s7_is_integer(pstart)) - return(method_or_bust(sc, pstart, caller, args, sc->type_names[T_INTEGER], position)); - index = s7_integer_clamped_if_gmp(sc, pstart); - if ((index < 0) || - (index > *end)) /* *end == length here */ - out_of_range_error_nr(sc, caller, small_int(position), pstart, (index < 0) ? it_is_negative_string : it_is_too_large_string); - *start = index; - - if (is_pair(cdr(index_args))) - { - s7_pointer pend = cadr(index_args); - if (!s7_is_integer(pend)) - return(method_or_bust(sc, pend, caller, args, sc->type_names[T_INTEGER], position + 1)); - index = s7_integer_clamped_if_gmp(sc, pend); - if ((index < *start) || - (index > *end)) - out_of_range_error_nr(sc, caller, small_int(position + 1), pend, (index < *start) ? it_is_too_small_string : it_is_too_large_string); - *end = index; - } - return(sc->unused); -} - -static s7_pointer g_substring(s7_scheme *sc, s7_pointer args) -{ - #define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \ -end: (substring \"01234\" 1 2) -> \"1\"" - #define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol) - - s7_pointer x, str = car(args); - s7_int start = 0, end, len; - char *s; - - if (!is_string(str)) - return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1)); - end = string_length(str); - if (!is_null(cdr(args))) - { - x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); - if (x != sc->unused) return(x); - } - s = string_value(str); - len = end - start; - if (len == 0) return(nil_string); - x = inline_make_string_with_length(sc, (char *)(s + start), len); - string_value(x)[len] = 0; - return(x); -} - -static s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args) -{ - s7_pointer str = car(args); - s7_int start = 0, end; - - if (!is_string(str)) - return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1)); - end = string_length(str); - if (!is_null(cdr(args))) - { - s7_pointer x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); - if (x != sc->unused) return(x); - } - return(wrap_string(sc, (char *)(string_value(str) + start), end - start)); -} - -static s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end) -{ - /* is_string arg1 checked in opt */ - if ((end < start) || (end > string_length(str))) - out_of_range_error_nr(sc, sc->substring_symbol, int_three, wrap_integer(sc, end), (end < start) ? it_is_too_small_string : it_is_too_large_string); - if (start < 0) - out_of_range_error_nr(sc, sc->substring_symbol, int_two, wrap_integer(sc, start), it_is_negative_string); - return(wrap_string(sc, (char *)(string_value(str) + start), end - start)); -} - -static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args); - -static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr) -{ - int32_t substrs = 0; - /* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_pair(arg)) && - (is_symbol(car(arg))) && - (is_safely_optimized(arg)) && - (has_fn(arg))) - { - if (fn_proc(arg) == g_substring) - { - if (substrs < NUM_STRING_WRAPPERS) - set_c_function(arg, sc->substring_uncopied); - substrs++; - } - else - if (fn_proc(arg) == g_symbol_to_string) - set_c_function(arg, sc->symbol_to_string_uncopied); - else - if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg)))) - set_c_function(arg, sc->get_output_string_uncopied); - }} -} - -static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - /* used by several string functions */ - check_for_substring_temp(sc, expr); - return(f); -} - - -/* -------------------------------- string-copy -------------------------------- */ -static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args) -{ - #define H_string_copy "(string-copy str dest-str (dest-start 0) dest-end) returns a copy of its string argument. If dest-str is given, \ - string-copy copies its first argument into the second, starting at dest-start in the second string and returns dest-str" - #define Q_string_copy s7_make_signature(sc, 5, sc->is_string_symbol, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) - - s7_pointer source = car(args), p, dest; - s7_int start, end; - - if (!is_string(source)) - return(method_or_bust(sc, source, sc->string_copy_symbol, args, sc->type_names[T_STRING], 1)); - if (is_null(cdr(args))) - return(make_string_with_length(sc, string_value(source), string_length(source))); - - dest = cadr(args); - if (!is_string(dest)) - wrong_type_error_nr(sc, sc->string_copy_symbol, 2, dest, sc->type_names[T_STRING]); - if (is_immutable(dest)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't string-copy to ~S; it is immutable", 40), dest)); - - end = string_length(dest); - p = cddr(args); - if (is_null(p)) - start = 0; - else - { - if (!s7_is_integer(car(p))) - wrong_type_error_nr(sc, sc->string_copy_symbol, 3, car(p), sc->type_names[T_INTEGER]); - start = s7_integer_clamped_if_gmp(sc, car(p)); - if (start < 0) start = 0; - p = cdr(p); - if (is_null(p)) - end = start + string_length(source); - else - { - if (!s7_is_integer(car(p))) - wrong_type_error_nr(sc, sc->string_copy_symbol, 4, car(p), sc->type_names[T_INTEGER]); - end = s7_integer_clamped_if_gmp(sc, car(p)); - if (end < 0) end = start; - }} - if (end > string_length(dest)) end = string_length(dest); - if (end <= start) return(dest); - if ((end - start) > string_length(source)) end = start + string_length(source); - memmove((void *)(string_value(dest) + start), (void *)(string_value(source)), end - start); - /* although I haven't tracked down a case, libasan+auto-tester reported sourcechar #xf0)) (string (integer->char #x70))) - * and null or lack thereof does not say anything about the string end - */ - size_t len1 = (size_t)string_length(s1); - size_t len2 = (size_t)string_length(s2); - size_t len = (len1 > len2) ? len2 : len1; - char *str1 = string_value(s1); - char *str2 = string_value(s2); - - if (len < sizeof(size_t)) - for (size_t i = 0; i < len; i++) - { - if ((uint8_t)(str1[i]) < (uint8_t )(str2[i])) - return(-1); - if ((uint8_t)(str1[i]) > (uint8_t)(str2[i])) - return(1); - } - else - { - /* this algorithm from stackoverflow(?), with various changes (original did not work for large strings, etc) */ - size_t i = 0, last = len / sizeof(size_t); - for (size_t *ptr1 = (size_t *)str1, *ptr2 = (size_t *)str2; i < last; i++) - if (ptr1[i] != ptr2[i]) - break; - for (size_t pos = i * sizeof(size_t); pos < len; pos++) - { - if ((uint8_t)str1[pos] < (uint8_t)str2[pos]) - return(-1); - if ((uint8_t)str1[pos] > (uint8_t)str2[pos]) - return(1); - }} - if (len1 < len2) - return(-1); - return((len1 > len2) ? 1 : 0); -} - -static bool is_string_via_method(s7_scheme *sc, s7_pointer p) -{ - if (s7_is_string(p)) - return(true); - if (has_active_methods(sc, p)) - { - s7_pointer f = find_method_with_let(sc, p, sc->is_string_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (scheme_strcmp(y, car(x)) != val) - { - for (y = cdr(x); is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); - }} - return(sc->T); -} - -static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (scheme_strcmp(y, car(x)) == val) - { - for (y = cdr(x); is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); - }} - return(sc->T); -} - -static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y) -{ - return((string_length(x) == string_length(y)) && - (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x)))); -} - -static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal" - #define Q_strings_are_equal sc->pcl_bs - - /* C-based check stops at null, but we can have embedded nulls. - * (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2)) - */ - s7_pointer y = car(args); - bool happy = true; - - if (!is_string(y)) - return(method_or_bust(sc, y, sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x); - if (y != p) - { - if (!is_string(p)) - return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (happy) - happy = scheme_strings_are_equal(p, y); - }} - return((happy) ? sc->T : sc->F); -} - -static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_less "(stringpcl_bs - return(g_string_cmp(sc, args, -1, sc->string_lt_symbol)); -} - -static s7_pointer g_strings_are_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing" - #define Q_strings_are_greater sc->pcl_bs - return(g_string_cmp(sc, args, 1, sc->string_gt_symbol)); -} - -static s7_pointer g_strings_are_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing" - #define Q_strings_are_geq sc->pcl_bs - return(g_string_cmp_not(sc, args, -1, sc->string_geq_symbol)); -} - -static s7_pointer g_strings_are_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing" - #define Q_strings_are_leq sc->pcl_bs - return(g_string_cmp_not(sc, args, 1, sc->string_leq_symbol)); -} - -static s7_pointer g_string_equal_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args)))); -} - -static s7_pointer g_string_equal_2c(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); - return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args)))); -} - -static s7_pointer string_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1)); - if (!is_string(p2)) - return(method_or_bust(sc, p2, sc->string_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strings_are_equal(p1, p2))); -} - -static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1)); -} - -static s7_pointer string_lt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_lt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1)); - if (!is_string(p2)) - return(method_or_bust(sc, p2, sc->string_lt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(p1, p2) == -1)); -} - -static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1)); -} - -static s7_pointer string_gt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_gt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1)); - if (!is_string(p2)) - return(method_or_bust(sc, p2, sc->string_gt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(p1, p2) == 1)); -} - -#define check_string2_args(Sc, Caller, P1, P2) \ - do { \ - if (!is_string(p1)) return(method_or_bust(sc, P1, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_STRING], 1) != Sc->F); \ - if (!is_string(p2)) return(method_or_bust(sc, P2, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_STRING], 2) != Sc->F); \ - } while (0) - -static bool string_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == -1);} -static bool string_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_lt_symbol, p1, p2); - return(scheme_strcmp(p1, p2) == -1); -} - -static bool string_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) != 1);} -static bool string_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_leq_symbol, p1, p2); - return(scheme_strcmp(p1, p2) != 1); -} - -static bool string_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == 1);} -static bool string_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_gt_symbol, p1, p2); - return(scheme_strcmp(p1, p2) == 1); -} - -static bool string_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) != -1);} -static bool string_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_geq_symbol, p1, p2); - return(scheme_strcmp(p1, p2) != -1); -} - -static bool string_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strings_are_equal(p1, p2));} -static bool string_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_eq_symbol, p1, p2); - return(scheme_strings_are_equal(p1, p2)); -} - -static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? ((is_string(caddr(expr))) ? sc->string_equal_2c : sc->string_equal_2) : f); -} - -static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? sc->string_less_2 : f); -} - -static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? sc->string_greater_2 : f); -} - - -#if (!WITH_PURE_S7) -static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2) -{ - /* same as scheme_strcmp -- watch out for unwanted sign! and lack of trailing null (length sets string end). - */ - s7_int len1 = string_length(s1); - s7_int len2 = string_length(s2); - s7_int len = (len1 > len2) ? len2 : len1; - const uint8_t *str1 = (const uint8_t *)string_value(s1); - const uint8_t *str2 = (const uint8_t *)string_value(s2); - - for (s7_int i = 0; i < len; i++) - { - if (uppers[(int32_t)str1[i]] < uppers[(int32_t)str2[i]]) - return(-1); - if (uppers[(int32_t)str1[i]] > uppers[(int32_t)str2[i]]) - return(1); - } - if (len1 < len2) - return(-1); - return((len1 > len2) ? 1 : 0); -} - -static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2) -{ - /* same as scheme_strcmp -- watch out for unwanted sign! */ - s7_int len = string_length(s1); - s7_int len2 = string_length(s2); - const uint8_t *str1, *str2; - - if (len != len2) return(false); - str1 = (const uint8_t *)string_value(s1); - str2 = (const uint8_t *)string_value(s2); - for (s7_int i = 0; i < len; i++) - if (uppers[(int32_t)str1[i]] != uppers[(int32_t)str2[i]]) - return(false); - return(true); -} - -static s7_pointer check_rest_are_strings(s7_scheme *sc, s7_pointer sym, s7_pointer x, s7_pointer args) -{ - for (s7_pointer y = x; is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); -} - -static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (val == 0) - { - if (!scheme_strequal_ci(y, car(x))) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } - else - if (scheme_strcasecmp(y, car(x)) != val) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } - return(sc->T); -} - -static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (scheme_strcasecmp(y, car(x)) == val) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } - return(sc->T); -} - -static s7_pointer g_strings_are_ci_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case" - #define Q_strings_are_ci_equal sc->pcl_bs - return(g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol)); -} - -static s7_pointer g_strings_are_ci_less(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_less "(string-cipcl_bs - return(g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol)); -} - -static s7_pointer g_strings_are_ci_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case" - #define Q_strings_are_ci_greater sc->pcl_bs - return(g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol)); -} - -static s7_pointer g_strings_are_ci_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case" - #define Q_strings_are_ci_geq sc->pcl_bs - return(g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol)); -} - -static s7_pointer g_strings_are_ci_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case" - #define Q_strings_are_ci_leq sc->pcl_bs - return(g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol)); -} - -static bool string_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == -1);} -static bool string_ci_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_lt_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) == -1); -} - -static bool string_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) != 1);} -static bool string_ci_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_leq_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) != 1); -} - -static bool string_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == 1);} -static bool string_ci_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_gt_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) == 1); -} - -static bool string_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) != -1);} -static bool string_ci_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_geq_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) != -1); -} - -static bool string_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == 0);} -static bool string_ci_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_eq_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) == 0); -} -#endif /* pure s7 */ - -static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - s7_pointer x = car(args), chr; - s7_int start = 0, end; - - if (!is_string(x)) - return(method_or_bust(sc, x, caller, args, sc->type_names[T_STRING], 1)); /* not two methods here */ - if (is_immutable_string(x)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, x)); - - chr = cadr(args); - if (!is_character(chr)) - return(method_or_bust(sc, chr, caller, args, sc->type_names[T_CHARACTER], 2)); - - end = string_length(x); - if (!is_null(cddr(args))) - { - s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); - if (p != sc->unused) - return(p); - if (start == end) return(chr); - } - if (end == 0) return(chr); - local_memset((void *)(string_value(x) + start), (int32_t)character(chr), end - start); /* not memclr even if chr=#\null! */ - return(chr); -} - -#if (!WITH_PURE_S7) -/* -------------------------------- string-fill! -------------------------------- */ -static s7_pointer g_string_fill(s7_scheme *sc, s7_pointer args) -{ - #define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr" - #define Q_string_fill s7_make_signature(sc, 5, \ - s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), \ - sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol, sc->is_integer_symbol) - return(g_string_fill_1(sc, sc->string_fill_symbol, args)); -} -#endif - - -/* -------------------------------- string -------------------------------- */ -const char *s7_string(s7_pointer p) {return(string_value(p));} - -static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) -{ - int32_t i, len; - s7_pointer x, newstr; - char *str; - if (is_null(args)) return(nil_string); - - /* get length for new string and check arg types */ - for (len = 0, x = args; is_not_null(x); len++, x = cdr(x)) - { - s7_pointer p = car(x); - if (!is_character(p)) - { - if (has_active_methods(sc, p)) - { - s7_pointer func = find_method_with_let(sc, p, sym); - if (func != sc->undefined) - { - s7_pointer y; - if (len == 0) - return(s7_apply_function(sc, func, args)); - newstr = make_empty_string(sc, len, 0); - str = string_value(newstr); - for (i = 0, y = args; y != x; i++, y = cdr(y)) - str[i] = character(car(y)); - return(g_string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, x)), sym)); - }} - wrong_type_error_nr(sc, sym, len + 1, car(x), sc->type_names[T_CHARACTER]); - }} - newstr = inline_make_empty_string(sc, len, 0); - str = string_value(newstr); - for (i = 0, x = args; is_not_null(x); i++, x = cdr(x)) - str[i] = character(car(x)); - return(newstr); -} - -static s7_pointer g_string(s7_scheme *sc, s7_pointer args) -{ - #define H_string "(string chr...) appends all its character arguments into one string" - #define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol) - return((is_null(args)) ? nil_string : g_string_1(sc, args, sc->string_symbol)); -} - -static s7_pointer g_string_c1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer c = car(args), str; - /* no multiple values here because no pairs below */ - if (!is_character(c)) - return(method_or_bust(sc, c, sc->string_symbol, args, sc->type_names[T_CHARACTER], 1)); - str = inline_make_empty_string(sc, 1, 0); /* can't put character(c) here because null is handled specially */ - string_value(str)[0] = character(c); - return(str); -} - -static s7_pointer string_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : f); -} - -static s7_pointer string_p_p(s7_scheme *sc, s7_pointer p) -{ - s7_pointer str; - if (!is_character(p)) return(g_string_1(sc, set_plist_1(sc, p), sc->string_symbol)); - str = inline_make_empty_string(sc, 1, 0); - string_value(str)[0] = character(p); - return(str); -} - - -/* -------------------------------- list->string -------------------------------- */ -#if (!WITH_PURE_S7) -static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)" - #define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol) - - if (is_null(car(args))) - return(nil_string); - if (!s7_is_proper_list(sc, car(args))) - return(sole_arg_method_or_bust_p(sc, car(args), sc->list_to_string_symbol, - wrap_string(sc, "a (proper, non-circular) list of characters", 43))); - return(g_string_1(sc, car(args), sc->list_to_string_symbol)); -} -#endif - - -/* -------------------------------- string->list -------------------------------- */ -static s7_pointer string_to_list(s7_scheme *sc, const char *str, s7_int len) -{ - s7_pointer result; - if (len == 0) - return(sc->nil); - check_free_heap_size(sc, len); - init_temp(sc->y, sc->nil); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, chars[((uint8_t)str[i])], sc->y); - result = sc->y; - sc->y = sc->unused; - return(result); -} - -#if (!WITH_PURE_S7) -static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)" - #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol) - - s7_int start = 0, end; - s7_pointer p, str = car(args); - - if (!is_string(str)) - return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, args, sc->type_names[T_STRING])); - end = string_length(str); - if (!is_null(cdr(args))) - { - p = start_and_end(sc, sc->string_to_list_symbol, args, 2, cdr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(sc->nil); - } - else - if (end == 0) return(sc->nil); - if ((end - start) > sc->max_list_length) - out_of_range_error_nr(sc, sc->string_to_list_symbol, int_one, car(args), it_is_too_large_string); - - sc->w = sc->nil; - check_free_heap_size(sc, end - start); - for (s7_int i = end - 1; i >= start; i--) - sc->w = cons_unchecked(sc, chars[((uint8_t)string_value(str)[i])], sc->w); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str) -{ - s7_int i, len; - s7_pointer p; - const uint8_t *val; - if (!is_string(str)) return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, set_plist_1(sc, str), sc->type_names[T_STRING])); - len = string_length(str); - if (len == 0) return(sc->nil); - check_free_heap_size(sc, len); - val = (const uint8_t *)string_value(str); - for (p = sc->nil, i = len - 1; i >= 0; i--) p = cons_unchecked(sc, chars[val[i]], p); - return(p); -} -#endif - - -/* -------------------------------- port-closed? -------------------------------- */ -static s7_pointer g_is_port_closed(s7_scheme *sc, s7_pointer args) -{ - #define H_is_port_closed "(port-closed? p) returns #t if the port p is closed." - #define Q_is_port_closed s7_make_signature(sc, 2, sc->is_boolean_symbol, \ - s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_output_port_symbol, sc->not_symbol)) - s7_pointer x = car(args); - if ((is_input_port(x)) || (is_output_port(x))) - return(make_boolean(sc, port_is_closed(x))); - if ((x == current_output_port(sc)) && (x == sc->F)) - return(sc->F); - return(sole_arg_method_or_bust_p(sc, x, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6))); -} - -static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer x) -{ - if ((is_input_port(x)) || (is_output_port(x))) - return(port_is_closed(x)); - if ((x == current_output_port(sc)) && (x == sc->F)) - return(false); - return(sole_arg_method_or_bust_p(sc, x, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6)) != sc->F); -} - - -/* -------------------------------- port-position -------------------------------- */ -static s7_pointer g_port_position(s7_scheme *sc, s7_pointer args) -{ - #define H_port_position "(port-position input-port) returns the current location (in bytes) \ -in the port's data where the next read will take place." - #define Q_port_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) - - s7_pointer port = car(args); - if (!(is_input_port(port))) - sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, sc->type_names[T_INPUT_PORT]); - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, an_open_input_port_string); - if (is_string_port(port)) - return(make_integer(sc, port_position(port))); -#if (!MS_WINDOWS) - if (is_file_port(port)) - return(make_integer(sc, ftell(port_file(port)))); -#endif - return(int_zero); -} - -static s7_pointer g_set_port_position(s7_scheme *sc, s7_pointer args) -{ - s7_pointer port = car(args), pos; - s7_int position; - - if (!(is_input_port(port))) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_input_port_string); - if (port_is_closed(port)) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_open_input_port_string); - - pos = cadr(args); - if (!is_t_integer(pos)) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 2, pos, sc->type_names[T_INTEGER]); - position = s7_integer_clamped_if_gmp(sc, pos); - if (position < 0) - out_of_range_error_nr(sc, sc->port_position_symbol, int_two, pos, it_is_negative_string); - if (is_string_port(port)) - port_position(port) = (position > port_data_size(port)) ? port_data_size(port) : position; -#if (!MS_WINDOWS) - else - if (is_file_port(port)) - { - rewind(port_file(port)); - fseek(port_file(port), (long)position, SEEK_SET); - } -#endif - return(pos); -} - - -/* -------------------------------- port-file -------------------------------- */ -static s7_pointer g_port_file(s7_scheme *sc, s7_pointer args) -{ - #define H_port_file "(port-file port) returns the FILE* pointer associated with the port, wrapped in a c-pointer object" - #define Q_port_file s7_make_signature(sc, 2, sc->is_c_pointer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) - - s7_pointer port = car(args); - if ((!is_input_port(port)) && - (!is_output_port(port))) - sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "a port", 6)); - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "an open port", 12)); -#if (!MS_WINDOWS) - if (is_file_port(port)) - return(s7_make_c_pointer_with_type(sc, (void *)(port_file(port)), sc->file__symbol, sc->F)); -#endif - return(s7_make_c_pointer(sc, NULL)); -} - - -/* -------------------------------- port-line-number -------------------------------- */ -static s7_pointer port_line_number_p_p(s7_scheme *sc, s7_pointer x) -{ - if ((!(is_input_port(x))) || - (port_is_closed(x))) - return(sole_arg_method_or_bust_p(sc, x, sc->port_line_number_symbol, an_input_port_string)); - return(make_integer(sc, port_line_number(x))); -} - -static s7_pointer g_port_line_number(s7_scheme *sc, s7_pointer args) -{ - #define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port" - #define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) - return(port_line_number_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args))); -} - -s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p) -{ - if (!(is_input_port(p))) - sole_arg_wrong_type_error_nr(sc, sc->port_line_number_symbol, p, sc->type_names[T_INPUT_PORT]); - return(port_line_number(p)); -} - -static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p, line; - if ((is_null(car(args))) || - ((is_null(cdr(args))) && (is_t_integer(car(args))))) - p = current_input_port(sc); - else - { - p = car(args); - if (!(is_input_port(p))) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, p, an_input_port_string); - } - line = (is_null(cdr(args)) ? car(args) : cadr(args)); - if (!is_t_integer(line)) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 2, line, sc->type_names[T_INTEGER]); - port_line_number(p) = integer(line); - return(line); -} - - -/* -------------------------------- port-filename -------------------------------- */ -const char *s7_port_filename(s7_scheme *sc, s7_pointer x) -{ - if (((is_input_port(x)) || - (is_output_port(x))) && - (!port_is_closed(x))) - return(port_filename(x)); - return(NULL); -} - -static s7_pointer port_filename_p_p(s7_scheme *sc, s7_pointer x) -{ - if (((is_input_port(x)) || (is_output_port(x))) && - (!port_is_closed(x))) - { - if (port_filename(x)) - return(make_string_with_length(sc, port_filename(x), port_filename_length(x))); /* not wrapper here! */ - return(nil_string); - /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ - } - return(sole_arg_method_or_bust_p(sc, x, sc->port_filename_symbol, wrap_string(sc, "an open port", 12))); -} - -static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args) -{ - #define H_port_filename "(port-filename file-port) returns the filename associated with port" - #define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) - return(port_filename_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args))); -} - - -/* -------------------------------- pair-line-number -------------------------------- */ -static s7_pointer pair_line_number_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_pair(p)) - return(method_or_bust_p(sc, p, sc->pair_line_number_symbol, sc->type_names[T_PAIR])); - return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F); -} - -static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args) -{ - #define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair', or #f if no such number is available" - #define Q_pair_line_number s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_pair_symbol) - return(pair_line_number_p_p(sc, car(args))); -} - - -/* -------------------------------- pair-filename -------------------------------- */ -static s7_pointer g_pair_filename(s7_scheme *sc, s7_pointer args) -{ - #define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'" - #define Q_pair_filename s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_pair_symbol) - - s7_pointer p = car(args); - if (is_pair(p)) - return((has_location(p)) ? sc->file_names[pair_file_number(p)] : sc->F); /* maybe also pair_file_number(p) > 0 */ - check_method(sc, p, sc->pair_filename_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->pair_filename_symbol, p, sc->type_names[T_PAIR]); - return(NULL); -} - - -/* -------------------------------- input-port? -------------------------------- */ -bool s7_is_input_port(s7_scheme *sc, s7_pointer p) {return(is_input_port(p));} -static bool is_input_port_b(s7_pointer p) {return(is_input_port(p));} - -static s7_pointer g_is_input_port(s7_scheme *sc, s7_pointer args) -{ - #define H_is_input_port "(input-port? p) returns #t if p is an input port" - #define Q_is_input_port sc->pl_bt - check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, args); -} - - -/* -------------------------------- output-port? -------------------------------- */ -bool s7_is_output_port(s7_scheme *sc, s7_pointer p) {return(is_output_port(p));} -static bool is_output_port_b(s7_pointer p) {return(is_output_port(p));} - -static s7_pointer g_is_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_is_output_port "(output-port? p) returns #t if p is an output port" - #define Q_is_output_port sc->pl_bt - check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, args); -} - - -/* -------------------------------- current-input-port -------------------------------- */ -s7_pointer s7_current_input_port(s7_scheme *sc) {return(current_input_port(sc));} - -static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_current_input_port "(current-input-port) returns the current input port" - #define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol) - return(current_input_port(sc)); -} - -static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args) -{ - #define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port" - #define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol) - - s7_pointer port = car(args), old_port = current_input_port(sc); - if ((is_input_port(port)) && - (!port_is_closed(port))) - set_current_input_port(sc, port); - else - { - check_method(sc, port, sc->set_current_input_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->set_current_input_port_symbol, port, an_open_input_port_string); - } - return(old_port); -} - -s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port) -{ - s7_pointer old_port = current_input_port(sc); - set_current_input_port(sc, port); - return(old_port); -} - - -/* -------------------------------- current-output-port -------------------------------- */ -s7_pointer s7_current_output_port(s7_scheme *sc) {return(current_output_port(sc));} - -s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer port) -{ - s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, port); - return(old_port); -} - -static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_current_output_port "(current-output-port) returns the current output port" - #define Q_current_output_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(current_output_port(sc)); -} - -static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port" - #define Q_set_current_output_port s7_make_signature(sc, 2, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - s7_pointer port = car(args); - s7_pointer old_port = current_output_port(sc); - if (((is_output_port(port)) && - (!port_is_closed(port))) || (port == sc->F)) - set_current_output_port(sc, port); - else - { - check_method(sc, port, sc->set_current_output_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->set_current_output_port_symbol, port, an_output_port_or_f_string); - } - return(old_port); -} - - -/* -------------------------------- current-error-port -------------------------------- */ -s7_pointer s7_current_error_port(s7_scheme *sc) {return(sc->error_port);} - -s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port) -{ - s7_pointer old_port = sc->error_port; - sc->error_port = port; - return(old_port); -} - -static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_current_error_port "(current-error-port) returns the current error port" - #define Q_current_error_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(sc->error_port); -} - -static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args) -{ - #define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port" - #define Q_set_current_error_port s7_make_signature(sc, 2, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - s7_pointer port = car(args); - s7_pointer old_port = sc->error_port; - if (((is_output_port(port)) && - (!port_is_closed(port))) || (port == sc->F)) - sc->error_port = port; - else - { - check_method(sc, port, sc->set_current_error_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->set_current_error_port_symbol, port, an_output_port_or_f_string); - } - return(old_port); -} - - -/* -------------------------------- char-ready? -------------------------------- */ -#if (!WITH_PURE_S7) -static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port" - #define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol) - s7_pointer pt, res; - - if (is_null(args)) - return(make_boolean(sc, (is_input_port(current_input_port(sc))) && (is_string_port(current_input_port(sc))))); - - pt = car(args); - if (!is_input_port(pt)) - return(sole_arg_method_or_bust_p(sc, pt, sc->is_char_ready_symbol, an_input_port_string)); - if (port_is_closed(pt)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_ready_symbol, pt, an_open_input_port_string); - if (!is_function_port(pt)) - return(make_boolean(sc, is_string_port(pt))); - - res = (*(port_input_function(pt)))(sc, S7_IS_CHAR_READY, pt); - if (is_multiple_value(res)) /* can only happen if more than one value in res */ - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port char-ready? returned: ~S", 44), res)); - } - return(make_boolean(sc, (res != sc->F))); /* char-ready? returns a boolean */ -} -#endif - -/* -------- ports -------- */ -static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port); -static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); -static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port); -static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); -static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port); - -static void close_closed_port(s7_scheme *sc, s7_pointer port) {return;} - -static port_functions_t closed_port_functions = - {closed_port_read_char, closed_port_write_char, closed_port_write_string, NULL, NULL, NULL, NULL, - closed_port_read_line, closed_port_display, close_closed_port}; - - -static void close_input_file(s7_scheme *sc, s7_pointer p) -{ - if (port_filename(p)) /* for string ports, this is the original input file name */ - { - liberate(sc, port_filename_block(p)); - port_filename(p) = NULL; - } - if (port_file(p)) - { - fclose(port_file(p)); - port_file(p) = NULL; - } - if (port_needs_free(p)) - free_port_data(sc, p); - - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_input_string(s7_scheme *sc, s7_pointer p) -{ - if (port_filename(p)) /* for string ports, this is the original input file name */ - { - liberate(sc, port_filename_block(p)); - port_filename(p) = NULL; - } - if (port_needs_free(p)) - free_port_data(sc, p); - - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_simple_input_string(s7_scheme *sc, s7_pointer p) -{ -#if S7_DEBUGGING - if (port_filename(p)) fprintf(stderr, "%s: port has a filename\n", __func__); - if (port_needs_free(p)) fprintf(stderr, "%s: port needs free\n", __func__); -#endif - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -void s7_close_input_port(s7_scheme *sc, s7_pointer p) {port_close(p)(sc, p);} - - -/* -------------------------------- close-input-port -------------------------------- */ -static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args) -{ - #define H_close_input_port "(close-input-port port) closes the port" - #define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol) - - s7_pointer pt = car(args); - if (!is_input_port(pt)) - return(sole_arg_method_or_bust_p(sc, pt, sc->close_input_port_symbol, an_input_port_string)); - if ((!is_immutable_port(pt)) && /* (close-input-port *stdin*) */ - (!is_loader_port(pt))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */ - s7_close_input_port(sc, pt); - return(sc->unspecified); -} - - -/* -------------------------------- flush-output-port -------------------------------- */ -static noreturn void file_error_nr(s7_scheme *sc, const char *caller, const char *descr, const char *name) -{ - error_nr(sc, sc->io_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: ~A ~S", 9), - s7_make_string_wrapper(sc, caller), - s7_make_string_wrapper(sc, descr), - s7_make_string_wrapper(sc, name))); -} - -bool s7_flush_output_port(s7_scheme *sc, s7_pointer p) -{ - bool result = true; - if ((is_output_port(p)) && /* type=T_OUTPUT_PORT, so this excludes #f */ - (is_file_port(p)) && - (!port_is_closed(p)) && - (port_file(p))) - { - if (port_position(p) > 0) - { - result = (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) == (size_t)port_position(p)); - port_position(p) = 0; - } - if (fflush(port_file(p)) == -1) - file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(p)); - } - return(result); -} - -static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_flush_output_port "(flush-output-port port) flushes the file port (that is, it writes any accumulated output to the output file)" - #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer pt = (is_null(args)) ? current_output_port(sc) : car(args); - if (!is_output_port(pt)) - { - if (pt == sc->F) return(pt); - check_method(sc, pt, sc->flush_output_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->flush_output_port_symbol, pt, an_output_port_or_f_string); - } - if (!s7_flush_output_port(sc, pt)) - error_nr(sc, sc->io_error_symbol, set_elist_2(sc, wrap_string(sc, "flush-output-port ~S failed", 27), pt)); - return(pt); -} - - -/* -------------------------------- close-output-port -------------------------------- */ -static void close_output_file(s7_scheme *sc, s7_pointer p) -{ - if (port_filename(p)) /* only a file output port has a filename(?) */ - { - liberate(sc, port_filename_block(p)); - port_filename(p) = NULL; - port_filename_length(p) = 0; - } - if (port_file(p)) - { -#if (WITH_WARNINGS) - if ((port_position(p) > 0) && - (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p))) - s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); -#else - if (port_position(p) > 0) - fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)); -#endif - if (fflush(port_file(p)) == -1) - s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno)); - fclose(port_file(p)); - port_file(p) = NULL; - } - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_output_string(s7_scheme *sc, s7_pointer p) -{ - if (port_data(p)) - { - port_data(p) = NULL; - port_data_size(p) = 0; - } - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_output_port(s7_scheme *sc, s7_pointer p) {port_close(p)(sc, p);} - -void s7_close_output_port(s7_scheme *sc, s7_pointer p) -{ - if ((p == sc->F) || (is_immutable_port(p))) return; /* can these happen? */ - close_output_port(sc, p); -} - -static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_close_output_port "(close-output-port port) closes the port" - #define Q_close_output_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer pt = car(args); - if (!is_output_port(pt)) - { - if (pt == sc->F) return(sc->unspecified); - check_method(sc, pt, sc->close_output_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->close_output_port_symbol, pt, an_output_port_or_f_string); - } - s7_close_output_port(sc, pt); - return(sc->unspecified); -} - - -/* -------- read character functions -------- */ - -static int32_t file_read_char(s7_scheme *sc, s7_pointer port) {return(fgetc(port_file(port)));} - -static int32_t function_read_char(s7_scheme *sc, s7_pointer port) -{ - s7_pointer res = (*(port_input_function(port)))(sc, S7_READ_CHAR, port); - if (is_eof(res)) return(EOF); - if (!is_character(res)) /* port_input_function might return some non-character */ - { - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); - } - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); - } - return((int32_t)character(res)); /* kinda nutty -- we return chars[this] in g_read_char! */ -} - -static int32_t string_read_char(s7_scheme *sc, s7_pointer port) -{ - return((port_data_size(port) <= port_position(port)) ? EOF : (uint8_t)port_data(port)[port_position(port)++]); /* port_string_length is 0 if no port string */ -} - -static int32_t output_read_char(s7_scheme *sc, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, an_input_port_string); - return(0); -} - -static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, an_open_input_port_string); - return(0); -} - - -/* -------- read line functions -------- */ - -static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, an_input_port_string); - return(NULL); -} - -static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, an_open_input_port_string); - return(NULL); -} - -static s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - s7_pointer res = (*(port_input_function(port)))(sc, S7_READ_LINE, port); - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-line returned: ~S", 42), res)); - } - return(res); -} - -static s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - if (!sc->read_line_buf) - { - sc->read_line_buf_size = 1024; - sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size); - } - if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin)) - return(s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */ - return(nil_string); /* make_string_with_length(sc, NULL, 0)); */ -} - -static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - /* read into read_line_buf concatenating reads until newline found. string is read_line_buf to pos-of-newline. - * reset file position to reflect newline pos. - */ - int32_t reads = 0; - char *str; - s7_int read_size; - if (!sc->read_line_buf) - { - sc->read_line_buf_size = 1024; - sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size); - } - read_size = sc->read_line_buf_size; - str = fgets(sc->read_line_buf, read_size, port_file(port)); /* reads size-1 at most, EOF and newline also terminate read */ - if (!str) return(eof_object); /* EOF or error with no char read */ - - while (true) - { - s7_int cur_size; - char *buf, *snew = strchr(sc->read_line_buf, (int)'\n'); /* or maybe just strlen + end-of-string=newline */ - if (snew) - { - s7_int pos = (s7_int)(snew - sc->read_line_buf); - port_line_number(port)++; - return(inline_make_string_with_length(sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos)); - } - reads++; - cur_size = strlen(sc->read_line_buf); - if ((cur_size + reads) < read_size) /* end of data, no newline */ - return(make_string_with_length(sc, sc->read_line_buf, cur_size)); - - /* need more data */ - sc->read_line_buf_size *= 2; - sc->read_line_buf = (char *)Realloc(sc->read_line_buf, sc->read_line_buf_size); - buf = (char *)(sc->read_line_buf + cur_size); - str = fgets(buf, read_size, port_file(port)); - if (!str) return(eof_object); - read_size = sc->read_line_buf_size; - } - return(eof_object); -} - -static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - s7_int i; - const char *port_str = (const char *)port_data(port); - s7_int port_start = port_position(port); - const char *start = port_str + port_start; - const char *cur = (const char *)strchr(start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */ - if (cur) - { - port_line_number(port)++; - i = cur - port_str; - port_position(port) = i + 1; - return(inline_make_string_with_length(sc, start, ((with_eol) ? i + 1 : i) - port_start)); - } - i = port_data_size(port); - port_position(port) = i; - if (i <= port_start) /* the < part can happen -- if not caught we try to create a string of length - 1 -> segfault */ - return(eof_object); - return(make_string_with_length(sc, start, i - port_start)); -} - - -/* -------- write character functions -------- */ - -static void resize_port_data(s7_scheme *sc, s7_pointer pt, s7_int new_size) -{ - s7_int loc = port_data_size(pt); - block_t *nb; - - if (new_size < loc) return; - if (new_size > sc->max_port_data_size) - error_nr(sc, make_symbol(sc, "port-too-big", 12), - set_elist_1(sc, wrap_string(sc, "port data size has grown past (*s7* 'max-port-data-size)", 56))); - - nb = reallocate(sc, port_data_block(pt), new_size); - port_data_block(pt) = nb; - port_data(pt) = (uint8_t *)(block_data(nb)); - port_data_size(pt) = new_size; -} - -static void string_write_char_resized(s7_scheme *sc, uint8_t c, s7_pointer pt) -{ - /* this division looks repetitive, but it is much faster */ - resize_port_data(sc, pt, port_data_size(pt) * 2); - port_data(pt)[port_position(pt)++] = c; -} - -static void string_write_char(s7_scheme *sc, uint8_t c, s7_pointer pt) -{ - if (port_position(pt) < port_data_size(pt)) - port_data(pt)[port_position(pt)++] = c; - else string_write_char_resized(sc, c, pt); -} - -static void stdout_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {fputc(c, stdout);} -static void stderr_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {fputc(c, stderr);} - -static void function_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - push_stack_direct(sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ - (*(port_output_function(port)))(sc, c, port); - unstack_with(sc, OP_NO_VALUES); -#if 1 - memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ -#else - sc->code = sc->stack_end[0]; - sc->args = sc->stack_end[2]; -#endif -} - -static Inline void inline_file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - if (port_position(port) == sc->output_port_data_size) - { - fwrite((void *)(port_data(port)), 1, sc->output_port_data_size, port_file(port)); - port_position(port) = 0; - } - port_data(port)[port_position(port)++] = c; -} - -static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {inline_file_write_char(sc, c, port);} - -static void input_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_output_port_string); -} - -static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_open_output_port_string); -} - - -/* -------- write string functions -------- */ - -static void input_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_output_port_string); -} - -static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_open_output_port_string); -} - -static void input_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_output_port_string); -} - -static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_open_output_port_string); -} - -static void stdout_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - if (str[len] == '\0') - fputs(str, stdout); - else - for (s7_int i = 0; i < len; i++) - fputc(str[i], stdout); -} - -static void stderr_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - if (str[len] == '\0') - fputs(str, stderr); - else - for (s7_int i = 0; i < len; i++) - fputc(str[i], stderr); -} - -static void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - s7_int new_len = port_position(pt) + len; /* len is known to be non-zero, str might not be 0-terminated */ - resize_port_data(sc, pt, new_len * 2); - memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); - port_position(pt) = new_len; -} - -static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - if ((S7_DEBUGGING) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();} - if (port_position(pt) + len < port_data_size(pt)) - { - memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); - /* memcpy is much faster than the equivalent while loop, and faster than using the 4-bytes-at-a-time shuffle */ - port_position(pt) += len; - } - else string_write_string_resized(sc, str, len, pt); -} - -static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - s7_int new_len = port_position(pt) + len; - if (new_len >= sc->output_port_data_size) - { - if (port_position(pt) > 0) - { -#if (WITH_WARNINGS) - if (fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)) != (size_t)port_position(pt)) - s7_warn(sc, 64, "fwrite trouble in write-string\n"); -#else - fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)); -#endif - port_position(pt) = 0; - } - fwrite((void *)str, 1, len, port_file(pt)); - } - else - { - memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); - port_position(pt) = new_len; - } -} - -static void string_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - if (s) string_write_string(sc, s, safe_strlen(s), port); -} - -static void file_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - if (s) - { - if (port_position(port) > 0) - { -#if (WITH_WARNINGS) - if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port)) - s7_warn(sc, 64, "fwrite trouble in display\n"); -#else - fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); -#endif - port_position(port) = 0; - } -#if (WITH_WARNINGS) - if (fputs(s, port_file(port)) == EOF) - s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); -#else - fputs(s, port_file(port)); -#endif - } -} - -static void function_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - if (!s) return; - push_stack_direct(sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ /* is this needed? */ - for (; *s; s++) - (*(port_output_function(port)))(sc, *s, port); - unstack_with(sc, OP_NO_VALUES); -#if 1 - memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ -#else - sc->code = sc->stack_end[0]; /* sc->curlet = sc->stack_end[1] */ - sc->args = sc->stack_end[2]; -#endif -} - -static void function_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - push_stack_direct(sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ /* is this needed? */ - for (s7_int i = 0; i < len; i++) - (*(port_output_function(pt)))(sc, str[i], pt); - unstack_with(sc, OP_NO_VALUES); -#if 1 - memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ -#else - sc->code = sc->stack_end[0]; - sc->args = sc->stack_end[2]; -#endif -} - -static void stdout_display(s7_scheme *sc, const char *s, s7_pointer port) {if (s) fputs(s, stdout);} -static void stderr_display(s7_scheme *sc, const char *s, s7_pointer port) {if (s) fputs(s, stderr);} - - -/* -------------------------------- write-string -------------------------------- */ -static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args) -{ - #define H_write_string "(write-string str port start end) writes str to port." - #define Q_write_string s7_make_circular_signature(sc, 3, 4, \ - sc->is_string_symbol, sc->is_string_symbol, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol),\ - sc->is_integer_symbol) - s7_pointer str = car(args), port; - s7_int start = 0, end; - if (!is_string(str)) - return(method_or_bust(sc, str, sc->write_string_symbol, args, sc->type_names[T_STRING], 1)); - - end = string_length(str); - if (!is_null(cdr(args))) - { - s7_pointer inds = cddr(args); - port = cadr(args); - if (!is_null(inds)) - { - s7_pointer p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, &start, &end); - if (p != sc->unused) return(p); - }} - else port = current_output_port(sc); - if (!is_output_port(port)) - { - if (port == sc->F) - { - s7_int len; - if ((start == 0) && (end == string_length(str))) - return(str); - len = (s7_int)(end - start); - return(make_string_with_length(sc, (char *)(string_value(str) + start), len)); - } - check_method(sc, port, sc->write_string_symbol, args); - wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, an_open_output_port_string); - if (start == end) return(str); - port_write_string(port)(sc, (char *)(string_value(str) + start), (end - start), port); - return(str); -} - -static s7_pointer write_string_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer port) -{ - if (!is_string(str)) - return(method_or_bust_pp(sc, str, sc->write_string_symbol, str, port, sc->type_names[T_STRING], 1)); - if (!is_output_port(port)) - { - if (port == sc->F) return(str); - return(method_or_bust_pp(sc, port, sc->write_string_symbol, str, port, an_output_port_string, 2)); - } - if (string_length(str) > 0) - port_write_string(port)(sc, string_value(str), string_length(str), port); - return(str); -} - - -/* -------- skip to newline readers -------- */ -static token_t token(s7_scheme *sc); - -static token_t file_read_semicolon(s7_scheme *sc, s7_pointer pt) -{ - int32_t c; - do (c = fgetc(port_file(pt))); while ((c != '\n') && (c != EOF)); - port_line_number(pt)++; - return((c == EOF) ? TOKEN_EOF : token(sc)); -} - -static token_t string_read_semicolon(s7_scheme *sc, s7_pointer pt) -{ - const char *str = (const char *)(port_data(pt) + port_position(pt)); - const char *orig_str = strchr(str, (int)'\n'); - if (!orig_str) - { - port_position(pt) = port_data_size(pt); - return(TOKEN_EOF); - } - port_position(pt) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */ - port_line_number(pt)++; - return(token(sc)); -} - - -/* -------- white space readers -------- */ - -static int32_t file_read_white_space(s7_scheme *sc, s7_pointer port) -{ - int32_t c; - while (is_white_space(c = fgetc(port_file(port)))) - if (c == '\n') - port_line_number(port)++; - return(c); -} - -static int32_t terminated_string_read_white_space(s7_scheme *sc, s7_pointer pt) -{ - const uint8_t *str = (const uint8_t *)(port_data(pt) + port_position(pt)); - uint8_t c; - /* here we know we have null termination and white_space[#\null] is false */ - while (white_space[c = *str++]) /* 255 is not -1 = EOF */ - if (c == '\n') - port_line_number(pt)++; - port_position(pt) = (c) ? str - port_data(pt) : port_data_size(pt); - return((int32_t)c); -} - - -/* -------- name readers -------- */ -#define BASE_10 10 - -static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer pt, bool atom_case) -{ - int32_t c; - s7_int i = 1; /* sc->strbuf[0] has the first char of the string we're reading */ - do { - c = fgetc(port_file(pt)); /* might return EOF */ - if (c == '\n') - port_line_number(pt)++; - - sc->strbuf[i++] = (unsigned char)c; - if (i >= sc->strbuf_size) - resize_strbuf(sc, i); - } while ((c != EOF) && (char_ok_in_a_name[c])); - - if ((i == 2) && - (sc->strbuf[0] == '\\')) - sc->strbuf[2] = '\0'; - else - { - if (c != EOF) - { - if (c == '\n') - port_line_number(pt)--; - ungetc(c, port_file(pt)); - } - sc->strbuf[i - 1] = '\0'; - } - if (atom_case) - return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); - return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); -} - -static s7_pointer file_read_name(s7_scheme *sc, s7_pointer pt) {return(file_read_name_or_sharp(sc, pt, true));} -static s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer pt) {return(file_read_name_or_sharp(sc, pt, false));} - -static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt) -{ - /* sc->strbuf[0] has the first char of the string we're reading */ - s7_pointer result; - uint8_t *str = (uint8_t *)(port_data(pt) + port_position(pt)); - - if (char_ok_in_a_name[*str]) - { - s7_int k; - uint8_t *orig_str = str - 1; - str++; - while (char_ok_in_a_name[*str]) str++; - k = str - orig_str; - if (*str != 0) - port_position(pt) += (k - 1); - else port_position(pt) = port_data_size(pt); - /* this is equivalent to: - * str = strpbrk(str, "(); \"\t\r\n"); - * if (!str) {k = strlen(orig_str); str = (char *)(orig_str + k);} else k = str - orig_str; - * but slightly faster. - */ - if (!number_table[*orig_str]) - return(inline_make_symbol(sc, (const char *)orig_str, k)); - - /* eval_c_string string is a constant so we can't set and unset the token's end char */ - if ((k + 1) >= sc->strbuf_size) - resize_strbuf(sc, k + 1); - - memcpy((void *)(sc->strbuf), (void *)orig_str, k); - sc->strbuf[k] = '\0'; - return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); - } - result = sc->singletons[(uint8_t)(sc->strbuf[0])]; - if (!result) - { - sc->strbuf[1] = '\0'; - result = make_symbol(sc, sc->strbuf, 1); - sc->singletons[(uint8_t)(sc->strbuf[0])] = result; - } - return(result); -} - -static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer pt) -{ - /* sc->strbuf[0] has the first char of the string we're reading. - * since a *#readers* function might want to get further input, we can't mess with the input even when it is otherwise safe - */ - char *str = (char *)(port_data(pt) + port_position(pt)); - if (char_ok_in_a_name[(uint8_t)*str]) - { - s7_int k; - char *orig_str = (char *)(str - 1); - str++; - while (char_ok_in_a_name[(uint8_t)(*str)]) {str++;} - k = str - orig_str; - port_position(pt) += (k - 1); - if ((k + 1) >= sc->strbuf_size) - resize_strbuf(sc, k + 1); - memcpy((void *)(sc->strbuf), (void *)orig_str, k); - sc->strbuf[k] = '\0'; - return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); - } - if (sc->strbuf[0] == 'f') - return(sc->F); - if (sc->strbuf[0] == 't') - return(sc->T); - if (sc->strbuf[0] == '\\') - { - /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */ - sc->strbuf[1] = str[0]; - sc->strbuf[2] = '\0'; - port_position(pt)++; - } - else sc->strbuf[1] = '\0'; - return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); -} - -static s7_pointer string_read_name(s7_scheme *sc, s7_pointer pt) -{ - /* port_string was allocated (and read from a file) so we can mess with it directly */ - s7_pointer result; - uint8_t *str = (uint8_t *)(port_data(pt) + port_position(pt)); - if (char_ok_in_a_name[*str]) - { - s7_int k; - uint8_t endc; - uint8_t *orig_str = str - 1; - str++; - while (char_ok_in_a_name[*str]) str++; - k = str - orig_str; - port_position(pt) += (k - 1); - if (!number_table[*orig_str]) - return(inline_make_symbol(sc, (const char *)orig_str, k)); - endc = *str; - *str = 0; - result = make_atom(sc, (char *)orig_str, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR); - *str = endc; - return(result); - } - result = sc->singletons[(uint8_t)(sc->strbuf[0])]; - if (!result) - { - sc->strbuf[1] = '\0'; - result = make_symbol(sc, sc->strbuf, 1); - sc->singletons[(uint8_t)(sc->strbuf[0])] = result; - } - return(result); -} - -static void port_set_filename(s7_scheme *sc, s7_pointer p, const char *name, size_t len) -{ - block_t *b = inline_mallocate(sc, len + 1); - port_filename_block(p) = b; - port_filename(p) = (char *)block_data(b); - memcpy((void *)block_data(b), (void *)name, len); - port_filename(p)[len] = '\0'; -} - -static block_t *mallocate_port(s7_scheme *sc) -{ - #define PORT_LIST 8 /* sizeof(port_t): 160 */ - block_t *p = sc->block_lists[PORT_LIST]; - if (p) - sc->block_lists[PORT_LIST] = (block_t *)block_next(p); - else - { /* this is mallocate without the index calc */ - p = mallocate_block(sc); - block_data(p) = (void *)permalloc(sc, (size_t)(1 << PORT_LIST)); - block_set_index(p, PORT_LIST); - } - block_set_size(p, sizeof(port_t)); - return(p); -} - -static port_functions_t input_file_functions = - {file_read_char, input_write_char, input_write_string, file_read_semicolon, file_read_white_space, - file_read_name, file_read_sharp, file_read_line, input_display, close_input_file}; - -static port_functions_t input_string_functions_1 = - {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space, - string_read_name, string_read_sharp, string_read_line, input_display, close_input_string}; - -static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int max_size, const char *caller) -{ - s7_pointer port; -#if (!MS_WINDOWS) - s7_int size; -#endif - s7_int port_loc; - block_t *b = mallocate_port(sc); - - new_cell(sc, port, T_INPUT_PORT); - port_loc = gc_protect_1(sc, port); - port_block(port) = b; - port_port(port) = (port_t *)block_data(b); - port_set_closed(port, false); - port_set_string_or_function(port, sc->nil); - /* if we're constantly opening files, and each open saves the file name in permanent memory, we gradually core-up */ - port_filename_length(port) = safe_strlen(name); - port_set_filename(sc, port, name, port_filename_length(port)); - port_line_number(port) = 1; /* first line is numbered 1 */ - port_file_number(port) = 0; - add_input_port(sc, port); - -#if (!MS_WINDOWS) - /* this doesn't work in MS C */ - fseek(fp, 0, SEEK_END); - size = ftell(fp); - rewind(fp); - - /* pseudo files (under /proc for example) have size=0, but we can read them, so don't assume a 0 length file is empty */ - - if ((size > 0) && /* if (size != 0) we get (open-input-file "/dev/tty") -> (open "/dev/tty") read 0 bytes of an expected -1? */ - ((max_size < 0) || (size < max_size))) /* load uses max_size = -1 */ - { - block_t *block = mallocate(sc, size + 2); - uint8_t *content = (uint8_t *)(block_data(block)); - size_t bytes = fread(content, sizeof(uint8_t), size, fp); - if (bytes != (size_t)size) - { - if (current_output_port(sc) != sc->F) - { - char tmp[256]; - int32_t len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size); - port_write_string(current_output_port(sc))(sc, tmp, clamp_length(len, 256), current_output_port(sc)); - } - size = bytes; - } - content[size] = '\0'; - content[size + 1] = '\0'; - fclose(fp); - - port_file(port) = NULL; /* make valgrind happy */ - port_type(port) = STRING_PORT; - port_data(port) = content; - port_data_block(port) = block; - port_data_size(port) = size; - port_position(port) = 0; - port_needs_free(port) = true; - port_port(port)->pf = &input_string_functions_1; - } - else - { - port_file(port) = fp; - port_type(port) = FILE_PORT; - port_data(port) = NULL; - port_data_block(port) = NULL; - port_data_size(port) = 0; - port_position(port) = 0; - port_needs_free(port) = false; - port_port(port)->pf = &input_file_functions; - } -#else - /* _stat64 is no better than the fseek/ftell route, and - * GetFileSizeEx and friends requires Windows.h which makes hash of everything else. - * fread until done takes too long on big files, so use a file port - */ - port_file(port) = fp; - port_type(port) = FILE_PORT; - port_needs_free(port) = false; - port_data(port) = NULL; - port_data_block(port) = NULL; - port_data_size(port) = 0; - port_position(port) = 0; - port_port(port)->pf = &input_file_functions; -#endif - s7_gc_unprotect_at(sc, port_loc); - return(port); -} - - -/* -------------------------------- open-input-file -------------------------------- */ -static int32_t remember_file_name(s7_scheme *sc, const char *file) -{ - for (int32_t i = 0; i <= sc->file_names_top; i++) - if (safe_strcmp(file, string_value(sc->file_names[i]))) - return(i); - - sc->file_names_top++; - if (sc->file_names_top >= sc->file_names_size) - { - int32_t old_size = 0; - /* what if file_names_size is greater than file_bits in pair|profile_file? */ - if (sc->file_names_size == 0) - { - sc->file_names_size = INITIAL_FILE_NAMES_SIZE; - sc->file_names = (s7_pointer *)Malloc(sc->file_names_size * sizeof(s7_pointer)); - } - else - { - old_size = sc->file_names_size; - sc->file_names_size *= 2; - sc->file_names = (s7_pointer *)Realloc(sc->file_names, sc->file_names_size * sizeof(s7_pointer)); - } - for (int32_t i = old_size; i < sc->file_names_size; i++) - sc->file_names[i] = sc->F; - } - sc->file_names[sc->file_names_top] = s7_make_semipermanent_string(sc, file); - return(sc->file_names_top); -} - - -#ifndef MAX_SIZE_FOR_STRING_PORT - #define MAX_SIZE_FOR_STRING_PORT 10000000 -#endif - -static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp) -{ - return(read_file(sc, fp, name, MAX_SIZE_FOR_STRING_PORT, "open")); -} - - -#if (!MS_WINDOWS) -#include -#endif - -static bool is_directory(const char *filename) -{ -#if (!MS_WINDOWS) - #ifdef S_ISDIR - struct stat statbuf; - return((stat(filename, &statbuf) >= 0) && - (S_ISDIR(statbuf.st_mode))); - #endif -#endif - return(false); -} - -static s7_pointer open_input_file_1(s7_scheme *sc, const char *name, const char *mode, const char *caller) -{ - FILE *fp; - /* see if we can open this file before allocating a port */ - if (is_directory(name)) - file_error_nr(sc, caller, "file is a directory:", name); - errno = 0; - fp = fopen(name, mode); - if (fp) - return(make_input_file(sc, name, fp)); - -#if (!MS_WINDOWS) - if (errno == EINVAL) - file_error_nr(sc, caller, "invalid mode", mode); -#if WITH_GCC - if ((!name) || (!*name)) - file_error_nr(sc, caller, strerror(errno), name); - if ((name[0] == '~') && (name[1] == '/')) /* catch one special case, "~/..." */ - { - char *home = getenv("HOME"); - if (home) - { - s7_int len = safe_strlen(name) + safe_strlen(home) + 1; - block_t *b = mallocate(sc, len); - char *filename = (char *)block_data(b); - filename[0] = '\0'; - catstrs(filename, len, home, (char *)(name + 1), (char *)NULL); - fp = fopen(filename, "r"); - liberate(sc, b); - if (fp) - return(make_input_file(sc, name, fp)); - }} -#endif -#endif - file_error_nr(sc, caller, strerror(errno), name); - return(sc->io_error_symbol); -} - -s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode) -{ - return(open_input_file_1(sc, name, mode, "open-input-file")); -} - -static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args) -{ - #define H_open_input_file "(open-input-file filename (mode \"r\")) opens filename for reading" - #define Q_open_input_file s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_string_symbol, sc->is_string_symbol) - - s7_pointer mode, name = car(args); - /* open-input-file can create a new output file if the file to be opened does not exist, and the "a" mode is given */ - - if (!is_string(name)) - return(method_or_bust(sc, name, sc->open_input_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_pair(cdr(args))) - return(open_input_file_1(sc, string_value(name), "r", "open-input-file")); - - mode = cadr(args); - if (!is_string(mode)) - return(method_or_bust(sc, mode, sc->open_input_file_symbol, args, wrap_string(sc, "a string (a mode such as \"r\")", 29), 2)); - /* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */ - return(open_input_file_1(sc, string_value(name), string_value(mode), "open-input-file")); -} - -static void close_stdin(s7_scheme *sc, s7_pointer port) {return;} -static void close_stdout(s7_scheme *sc, s7_pointer port) {return;} -static void close_stderr(s7_scheme *sc, s7_pointer port) {return;} - -static const port_functions_t stdin_functions = - {file_read_char, input_write_char, input_write_string, file_read_semicolon, file_read_white_space, - file_read_name, file_read_sharp, stdin_read_line, input_display, close_stdin}; - -static const port_functions_t stdout_functions = - {output_read_char, stdout_write_char, stdout_write_string, NULL, NULL, NULL, NULL, output_read_line, stdout_display, close_stdout}; - -static const port_functions_t stderr_functions = - {output_read_char, stderr_write_char, stderr_write_string, NULL, NULL, NULL, NULL, output_read_line, stderr_display, close_stderr}; - -static void init_standard_ports(s7_scheme *sc) -{ - s7_pointer x; - - /* standard output */ - x = alloc_pointer(sc); - set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port(x) = (port_t *)Calloc(1, sizeof(port_t)); - port_type(x) = FILE_PORT; - port_data(x) = NULL; - port_data_block(x) = NULL; - port_set_closed(x, false); - port_filename_length(x) = 8; - port_set_filename(sc, x, "*stdout*", 8); - port_file_number(x) = remember_file_name(sc, port_filename(x)); /* these numbers need to be correct for the evaluator (*function* data) */ - port_line_number(x) = 0; - port_file(x) = stdout; - port_needs_free(x) = false; - port_port(x)->pf = &stdout_functions; - sc->standard_output = x; - - /* standard error */ - x = alloc_pointer(sc); - set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port(x) = (port_t *)Calloc(1, sizeof(port_t)); - port_type(x) = FILE_PORT; - port_data(x) = NULL; - port_data_block(x) = NULL; - port_set_closed(x, false); - port_filename_length(x) = 8; - port_set_filename(sc, x, "*stderr*", 8); - port_file_number(x) = remember_file_name(sc, port_filename(x)); - port_line_number(x) = 0; - port_file(x) = stderr; - port_needs_free(x) = false; - port_port(x)->pf = &stderr_functions; - sc->standard_error = x; - - /* standard input */ - x = alloc_pointer(sc); - set_full_type(x, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port(x) = (port_t *)Calloc(1, sizeof(port_t)); - port_type(x) = FILE_PORT; - port_set_closed(x, false); - port_set_string_or_function(x, sc->nil); - port_filename_length(x) = 7; - port_set_filename(sc, x, "*stdin*", 7); - port_file_number(x) = remember_file_name(sc, port_filename(x)); - port_line_number(x) = 0; - port_file(x) = stdin; - port_data_block(x) = NULL; - port_needs_free(x) = false; - port_port(x)->pf = &stdin_functions; - sc->standard_input = x; - - s7_define_variable_with_documentation(sc, "*stdin*", sc->standard_input, "*stdin* is the built-in input port, C's stdin"); - s7_define_variable_with_documentation(sc, "*stdout*", sc->standard_output, "*stdout* is the built-in buffered output port, C's stdout"); - s7_define_variable_with_documentation(sc, "*stderr*", sc->standard_error, "*stderr* is the built-in unbuffered output port, C's stderr"); - - set_current_input_port(sc, sc->standard_input); - set_current_output_port(sc, sc->standard_output); - sc->error_port = sc->standard_error; - sc->current_file = NULL; - sc->current_line = -1; -} - - -/* -------------------------------- open-output-file -------------------------------- */ -static const port_functions_t output_file_functions = - {output_read_char, file_write_char, file_write_string, NULL, NULL, NULL, NULL, output_read_line, file_display, close_output_file}; - -s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode) -{ - FILE *fp; - s7_pointer x; - block_t *block, *b; - /* see if we can open this file before allocating a port */ - - errno = 0; - fp = fopen(name, mode); - if (!fp) - { -#if (!MS_WINDOWS) - if (errno == EINVAL) - file_error_nr(sc, "open-output-file", "invalid mode", mode); -#endif - file_error_nr(sc, "open-output-file", strerror(errno), name); - } - new_cell(sc, x, T_OUTPUT_PORT); - b = mallocate_port(sc); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = FILE_PORT; - port_set_closed(x, false); - port_filename_length(x) = safe_strlen(name); - port_set_filename(sc, x, name, port_filename_length(x)); - port_line_number(x) = 1; - port_file_number(x) = 0; - port_file(x) = fp; - port_needs_free(x) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */ - port_position(x) = 0; - port_data_size(x) = sc->output_port_data_size; - block = mallocate(sc, sc->output_port_data_size); - port_data_block(x) = block; - port_data(x) = (uint8_t *)(block_data(block)); - port_port(x)->pf = &output_file_functions; - add_output_port(sc, x); - return(x); -} - -static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args) -{ - #define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing" - #define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(method_or_bust(sc, name, sc->open_output_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_pair(cdr(args))) - return(s7_open_output_file(sc, string_value(name), "w")); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->open_output_file_symbol, args, wrap_string(sc, "a string (a mode such as \"w\")", 29), 2)); - return(s7_open_output_file(sc, string_value(name), string_value(cadr(args)))); -} - - -/* -------------------------------- open-input-string -------------------------------- */ - /* a version of string ports using a pointer to the current location and a pointer to the end - * (rather than an integer for both, indexing from the base string) was not faster. - */ - -static const port_functions_t input_string_functions = - {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space, - string_read_name_no_free, string_read_sharp, string_read_line, input_display, close_simple_input_string}; - -static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_int len) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - new_cell(sc, x, T_INPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = STRING_PORT; - port_set_closed(x, false); - port_set_string_or_function(x, sc->nil); - port_data(x) = (uint8_t *)input_string; - port_data_block(x) = NULL; - port_data_size(x) = len; - port_position(x) = 0; - port_filename_block(x) = NULL; - port_filename_length(x) = 0; - port_filename(x) = NULL; - port_file_number(x) = 0; - port_line_number(x) = 0; - port_file(x) = NULL; - port_needs_free(x) = false; -#if S7_DEBUGGING - if ((len > 0) && (input_string[len] != '\0')) - { - fprintf(stderr, "%s[%d]: read_white_space string is not terminated: len: %" ld64 ", at end: %c%c, str: %s", - __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string); - abort(); - } -#endif - port_port(x)->pf = &input_string_functions; - add_input_string_port(sc, x); - return(x); -} - -static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str) /* why inline here? */ -{ - s7_pointer p = open_input_string(sc, string_value(str), string_length(str)); - port_set_string_or_function(p, str); - return(p); -} - -s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string) -{ - return(open_input_string(sc, input_string, safe_strlen(input_string))); -} - -static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args) -{ - #define H_open_input_string "(open-input-string str) opens an input port reading str" - #define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol) - - s7_pointer input_string = car(args), port; - if (!is_string(input_string)) - return(sole_arg_method_or_bust(sc, input_string, sc->open_input_string_symbol, args, sc->type_names[T_STRING])); - port = open_and_protect_input_string(sc, input_string); - return(port); -} - - -/* -------------------------------- open-output-string -------------------------------- */ -#define FORMAT_PORT_LENGTH 128 -/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed - * 256 is slightly slower (the calloc time below dominates the realloc time in string_write_string) - * 64 is much slower (realloc dominates) - */ - -static const port_functions_t output_string_functions = - {output_read_char, string_write_char, string_write_string, NULL, NULL, NULL, NULL, output_read_line, string_display, close_output_string}; - -s7_pointer s7_open_output_string(s7_scheme *sc) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - block_t *block = inline_mallocate(sc, sc->initial_string_port_length); - new_cell(sc, x, T_OUTPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = STRING_PORT; - port_set_closed(x, false); - port_data_size(x) = sc->initial_string_port_length; - port_data_block(x) = block; - port_data(x) = (uint8_t *)(block_data(block)); - port_data(x)[0] = '\0'; /* in case s7_get_output_string before any output */ - port_position(x) = 0; - port_needs_free(x) = true; - port_filename_block(x) = NULL; - port_filename_length(x) = 0; /* protect against (port-filename (open-output-string)) */ - port_filename(x) = NULL; - port_port(x)->pf = &output_string_functions; - add_output_port(sc, x); - return(x); -} - -static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_open_output_string "(open-output-string) opens an output string port" - #define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol) - return(s7_open_output_string(sc)); -} - - -/* -------------------------------- get-output-string -------------------------------- */ -const char *s7_get_output_string(s7_scheme *sc, s7_pointer p) -{ - port_data(p)[port_position(p)] = '\0'; - return((const char *)port_data(p)); -} - -s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p) -{ - port_data(p)[port_position(p)] = '\0'; - return(make_string_with_length(sc, (const char *)port_data(p), port_position(p))); -} - -static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer p) -{ - if (port_is_closed(p)) - wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, p, wrap_string(sc, "an active (open) string port", 28)); - if (port_position(p) > sc->max_string_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "get-output-string port-position ~D is greater than (*s7* 'max-string-length)", 76), - wrap_integer(sc, port_position(p)))); -} -/* if pos>max and clear, where should the clear be? Not here because we might want to see output in error handler. - * similarly below if pos>size how can we call make_string (out-of-bounds) and ignore error? - * if pos>size shouldn't we raise an error somewhere? - */ - -static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args) -{ - #define H_get_output_string "(get-output-string port clear-port) returns the output accumulated in port. \ -If the optional 'clear-port' is #t, the current string is flushed." - #define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol) - s7_pointer p; - bool clear_port = false; - - if (is_pair(cdr(args))) - { - p = cadr(args); - if (!is_boolean(p)) - wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, p, sc->type_names[T_BOOLEAN]); - clear_port = (p == sc->T); - } - p = car(args); - if ((!is_output_port(p)) || (!is_string_port(p))) - { - if (p == sc->F) return(nil_string); - check_method(sc, p, sc->get_output_string_symbol, args); - wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, p, wrap_string(sc, "an open string output port or #f", 32)); - } - check_get_output_string_port(sc, p); - - if ((clear_port) && - (port_position(p) < port_data_size(p))) - { - block_t *block; - s7_pointer result = block_to_string(sc, port_data_block(p), port_position(p)); - /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(p)), port_position(p)): we're trading a mallocate for a memcpy */ - port_data_size(p) = sc->initial_string_port_length; - block = inline_mallocate(sc, port_data_size(p)); - port_data_block(p) = block; - port_data(p) = (uint8_t *)(block_data(block)); - port_position(p) = 0; - port_data(p)[0] = '\0'; - return(result); - } - return(make_string_with_length(sc, (const char *)port_data(p), port_position(p))); -} - -static void op_get_output_string(s7_scheme *sc) -{ - s7_pointer port = sc->code; - if (!is_output_port(port)) - wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, port, wrap_string(sc, "an open string output port", 26)); - check_get_output_string_port(sc, port); - - if (port_position(port) >= port_data_size(port)) /* can the > part happen? */ - sc->value = block_to_string(sc, reallocate(sc, port_data_block(port), port_position(port) + 1), port_position(port)); - else sc->value = block_to_string(sc, port_data_block(port), port_position(port)); - - port_data(port) = NULL; - port_data_size(port) = 0; - port_data_block(port) = NULL; - port_needs_free(port) = false; -} - -static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = car(args); - if ((!is_output_port(p)) || (!is_string_port(p))) - { - if (p == sc->F) return(nil_string); - return(sole_arg_method_or_bust_p(sc, p, sc->get_output_string_symbol, wrap_string(sc, "an output string port", 21))); - } - check_get_output_string_port(sc, p); - return(wrap_string(sc, (const char *)port_data(p), port_position(p))); -} - - -/* -------------------------------- open-input-function -------------------------------- */ -static s7_pointer g_closed_input_function_port(s7_scheme *sc, s7_pointer unused_args) -{ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_1(sc, wrap_string(sc, "attempt to read from a closed input-function port", 49))); - return(NULL); -} - -static void close_input_function(s7_scheme *sc, s7_pointer p) -{ - port_port(p)->pf = &closed_port_functions; - port_set_string_or_function(p, sc->closed_input_function); /* from s7_make_function so it is GC-protected */ - port_set_closed(p, true); -} - -static const port_functions_t input_function_functions = - {function_read_char, input_write_char, input_write_string, NULL, NULL, NULL, NULL, function_read_line, input_display, close_input_function}; - -static void function_port_set_defaults(s7_pointer x) -{ - port_type(x) = FUNCTION_PORT; - port_data(x) = NULL; - port_data_block(x) = NULL; - port_set_closed(x, false); - port_needs_free(x) = false; - port_filename_block(x) = NULL; /* next three protect against port-filename misunderstandings */ - port_filename(x) = NULL; - port_filename_length(x) = 0; - port_file_number(x) = 0; - port_line_number(x) = 0; - port_file(x) = NULL; -} - -s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - new_cell(sc, x, T_INPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - function_port_set_defaults(x); - port_set_string_or_function(x, sc->nil); - port_input_function(x) = function; - port_port(x)->pf = &input_function_functions; - add_input_port(sc, x); - return(x); -} - -static void init_open_input_function_choices(s7_scheme *sc) -{ - sc->open_input_function_choices[S7_READ] = sc->read_symbol; - sc->open_input_function_choices[S7_READ_CHAR] = sc->read_char_symbol; - sc->open_input_function_choices[S7_READ_LINE] = sc->read_line_symbol; - sc->open_input_function_choices[S7_PEEK_CHAR] = sc->peek_char_symbol; -#if (!WITH_PURE_S7) - sc->open_input_function_choices[S7_IS_CHAR_READY] = sc->is_char_ready_symbol; -#endif -} - -static s7_pointer input_scheme_function_wrapper(s7_scheme *sc, s7_read_t read_choice, s7_pointer port) -{ - return(s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, sc->open_input_function_choices[(int)read_choice]))); -} - -static s7_pointer g_open_input_function(s7_scheme *sc, s7_pointer args) -{ - #define H_open_input_function "(open-input-function func) opens an input function port" - #define Q_open_input_function s7_make_signature(sc, 2, sc->is_input_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer port, func = car(args); - - if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */ - sole_arg_wrong_type_error_nr(sc, sc->open_input_function_symbol, func, a_procedure_string); - if (!s7_is_aritable(sc, func, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port function, ~A, should take one argument", 58), func)); - - port = s7_open_input_function(sc, input_scheme_function_wrapper); - port_set_string_or_function(port, func); - return(port); -} - - -/* -------------------------------- open-output-function -------------------------------- */ -static s7_pointer g_closed_output_function_port(s7_scheme *sc, s7_pointer unused_args) -{ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_1(sc, wrap_string(sc, "attempt to write to a closed output-function port", 49))); - return(NULL); -} - -static void close_output_function(s7_scheme *sc, s7_pointer p) -{ - port_port(p)->pf = &closed_port_functions; - port_set_string_or_function(p, sc->closed_output_function); - port_set_closed(p, true); -} - -static const port_functions_t output_function_functions = - {output_read_char, function_write_char, function_write_string, NULL, NULL, NULL, NULL, output_read_line, function_display, close_output_function}; - -s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - new_cell(sc, x, T_OUTPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - function_port_set_defaults(x); - port_output_function(x) = function; - port_set_string_or_function(x, sc->nil); - port_port(x)->pf = &output_function_functions; - add_output_port(sc, x); - return(x); -} - -static void output_scheme_function_wrapper(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, make_integer(sc, c))); -} - -static s7_pointer g_open_output_function(s7_scheme *sc, s7_pointer args) -{ - #define H_open_output_function "(open-output-function func) opens an output function port" - #define Q_open_output_function s7_make_signature(sc, 2, sc->is_output_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer port, func = car(args); - - if (!is_any_procedure(func)) - sole_arg_wrong_type_error_nr(sc, sc->open_output_function_symbol, func, a_procedure_string); - if (!s7_is_aritable(sc, func, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "output-function-port function, ~A, should take one argument", 59), func)); - - port = s7_open_output_function(sc, output_scheme_function_wrapper); - port_set_string_or_function(port, func); - mark_function[T_OUTPUT_PORT] = mark_output_port; - return(port); -} - - -/* -------- current-input-port stack -------- */ -#define INPUT_PORT_STACK_INITIAL_SIZE 4 - -static inline void push_input_port(s7_scheme *sc, s7_pointer new_port) -{ - if (sc->input_port_stack_loc >= sc->input_port_stack_size) - { - sc->input_port_stack_size *= 2; - sc->input_port_stack = (s7_pointer *)Realloc(sc->input_port_stack, sc->input_port_stack_size * sizeof(s7_pointer)); - } - sc->input_port_stack[sc->input_port_stack_loc++] = current_input_port(sc); - set_current_input_port(sc, new_port); -} - -static void pop_input_port(s7_scheme *sc) -{ - set_current_input_port(sc, (sc->input_port_stack_loc > 0) ? sc->input_port_stack[--(sc->input_port_stack_loc)] : sc->standard_input); -} - -static s7_pointer input_port_if_not_loading(s7_scheme *sc) -{ - s7_pointer port = current_input_port(sc); - int32_t c; - if (!is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */ - return(port); - c = port_read_white_space(port)(sc, port); - if (c > 0) /* we can get either EOF or NULL at the end */ - { - backchar(c, port); - return(NULL); - } - return(sc->standard_input); -} - - -/* -------------------------------- read-char -------------------------------- */ -s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port) -{ - int32_t c = port_read_character(port)(sc, port); - return((c == EOF) ? eof_object : chars[c]); -} - -static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args) -{ - #define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port" - #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) - - s7_pointer port; - if (is_not_null(args)) - port = car(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); - return(chars[port_read_character(port)(sc, port)]); -} - -static s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port) -{ - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); - return(chars[port_read_character(port)(sc, port)]); -} - -static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer port = car(args); - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); - return(chars[port_read_character(port)(sc, port)]); -} - -static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 1) ? sc->read_char_1 : f); -} - - -/* -------------------------------- write-char -------------------------------- */ -s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer pt) -{ - if (pt != sc->F) - port_write_character(pt)(sc, s7_character(c), pt); - return(c); -} - -static s7_pointer write_char_p_pp(s7_scheme *sc, s7_pointer c, s7_pointer port) -{ - if (!is_character(c)) - return(method_or_bust_pp(sc, c, sc->write_char_symbol, c, port, sc->type_names[T_CHARACTER], 1)); - if (!is_output_port(port)) - { - if (port == sc->F) return(c); - check_method(sc, port, sc->write_char_symbol, set_mlist_2(sc, c, port)); - wrong_type_error_nr(sc, sc->write_char_symbol, 2, port, an_output_port_or_f_string); - } - port_write_character(port)(sc, s7_character(c), port); - return(c); -} - -static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args) -{ - #define H_write_char "(write-char char (port (current-output-port))) writes char to the output port" - #define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(write_char_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); -} - -static s7_pointer write_char_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(method_or_bust_p(sc, c, sc->write_char_symbol, sc->type_names[T_CHARACTER])); - if (current_output_port(sc) == sc->F) return(c); - port_write_character(current_output_port(sc))(sc, s7_character(c), current_output_port(sc)); - return(c); -} - -/* (with-output-to-string (lambda () (write-char #\space))) -> " " - * (with-output-to-string (lambda () (write #\space))) -> "#\\space" - * (with-output-to-string (lambda () (display #\space))) -> " " - * is this correct? It's what Guile does. write-char is actually display-char. - */ - - -/* -------------------------------- peek-char -------------------------------- */ -s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port) -{ - int32_t c; /* needs to be an int32_t so EOF=-1, but not 255 */ - if (is_string_port(port)) - return((port_data_size(port) <= port_position(port)) ? chars[EOF] : chars[(uint8_t)port_data(port)[port_position(port)]]); - c = port_read_character(port)(sc, port); - if (c == EOF) return(eof_object); - backchar(c, port); - return(chars[c]); -} - -static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args) -{ - #define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream" - #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) - - s7_pointer res, port = (is_not_null(args)) ? car(args) : current_input_port(sc); - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->peek_char_symbol, an_input_port_string)); - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->peek_char_symbol, port, an_open_input_port_string); - if (!is_function_port(port)) - return(s7_peek_char(sc, port)); - - res = (*(port_input_function(port)))(sc, S7_PEEK_CHAR, port); - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), res)); - } - if (!is_character(res)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned: ~S", 42), res)); - return(res); -} - - -/* -------------------------------- read-byte -------------------------------- */ -static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args) -{ - #define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port" - #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) - - s7_pointer port; - int32_t c; - - if (is_not_null(args)) - port = car(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_byte_symbol, an_input_port_string)); - if (port_is_closed(port)) /* avoid reporting caller here as read-char */ - sole_arg_wrong_type_error_nr(sc, sc->read_byte_symbol, port, an_open_input_port_string); - c = port_read_character(port)(sc, port); - return((c == EOF) ? eof_object : small_int(c)); -} - - -/* -------------------------------- write-byte -------------------------------- */ -static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args) -{ - #define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port" - #define Q_write_byte s7_make_signature(sc, 3, sc->is_byte_symbol, sc->is_byte_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer port, b = car(args); - s7_int val; - if (!s7_is_integer(b)) - return(method_or_bust(sc, car(args), sc->write_byte_symbol, args, sc->type_names[T_INTEGER], 1)); - - val = s7_integer_clamped_if_gmp(sc, b); - if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */ - wrong_type_error_nr(sc, sc->write_byte_symbol, 1, b, an_unsigned_byte_string); - - port = (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc); - if (!is_output_port(port)) - { - if (port == sc->F) return(car(args)); - check_method(sc, port, sc->write_byte_symbol, args); - wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) /* avoid reporting caller here as write-char */ - wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, an_open_output_port_string); - - port_write_character(port)(sc, (uint8_t)val, port); - return(b); -} - - -/* -------------------------------- read-line -------------------------------- */ -static s7_pointer g_read_line(s7_scheme *sc, s7_pointer args) -{ - #define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #. \ -If 'with-eol' is not #f, read-line includes the trailing end-of-line character." - #define Q_read_line s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \ - sc->is_input_port_symbol, sc->is_boolean_symbol) - s7_pointer port; - bool with_eol = false; - if (is_not_null(args)) - { - port = car(args); - if (!is_input_port(port)) - return(method_or_bust(sc, port, sc->read_line_symbol, args, an_input_port_string, 1)); - - if (is_not_null(cdr(args))) - with_eol = (cadr(args) != sc->F); /* perhaps this should insist on #t: (read-line port (c-pointer 0)) */ - } - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - return(port_read_line(port)(sc, port, with_eol)); -} - -static s7_pointer read_line_p_pp(s7_scheme *sc, s7_pointer port, s7_pointer with_eol) -{ - if (!is_input_port(port)) - return(method_or_bust_pp(sc, port, sc->read_line_symbol, port, with_eol, an_input_port_string, 1)); - return(port_read_line(port)(sc, port, with_eol != sc->F)); -} - -static s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port) -{ - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_line_symbol, an_input_port_string)); - return(port_read_line(port)(sc, port, false)); /* with_eol default is #f */ -} - - -/* -------------------------------- read-string -------------------------------- */ -static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) -{ - /* read-chars would be a better name -- read-string could mean CL-style read-from-string (like eval-string) - * similarly read-bytes could return a byte-vector (rather than r7rs's read-bytevector) - * and write-string -> write-chars, write-bytevector -> write-bytes - */ - #define H_read_string "(read-string k port) reads k characters from port into a new string and returns it." - #define Q_read_string s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \ - sc->is_integer_symbol, sc->is_input_port_symbol) - s7_pointer k = car(args), port, s; - s7_int nchars; - uint8_t *str; - - if (!s7_is_integer(k)) - return(method_or_bust(sc, k, sc->read_string_symbol, args, sc->type_names[T_INTEGER], 1)); - nchars = s7_integer_clamped_if_gmp(sc, k); - if ((nchars < 0) || (nchars > sc->max_string_length)) - out_of_range_error_nr(sc, sc->read_string_symbol, int_one, k, (nchars < 0) ? it_is_negative_string : it_is_too_large_string); - - if (!is_null(cdr(args))) - port = cadr(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(method_or_bust_pp(sc, port, sc->read_string_symbol, k, port, an_input_port_string, 2)); - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->read_string_symbol, 2, port, an_open_input_port_string); - - s = make_empty_string(sc, nchars, 0); - if (nchars == 0) return(s); - str = (uint8_t *)string_value(s); - if (is_string_port(port)) - { - s7_int pos = port_position(port); - s7_int end = port_data_size(port); - s7_int len = end - pos; - if (len > nchars) len = nchars; - if (len <= 0) return(eof_object); - memcpy((void *)str, (void *)(port_data(port) + pos), len); - string_length(s) = len; - str[len] = '\0'; - port_position(port) += len; - return(s); - } - if (is_file_port(port)) - { - size_t len = fread((void *)str, 1, nchars, port_file(port)); - str[len] = '\0'; - string_length(s) = len; - return(s); - } - for (s7_int i = 0; i < nchars; i++) - { - int32_t c = port_read_character(port)(sc, port); - if (c == EOF) - { - if (i == 0) - return(eof_object); - string_length(s) = i; - return(s); - } - str[i] = (uint8_t)c; - } - return(s); -} - - -/* -------------------------------- read -------------------------------- */ -#define declare_jump_info() bool old_longjmp; int32_t old_jump_loc, jump_loc; Jmp_Buf *old_goto_start; Jmp_Buf new_goto_start - -#define store_jump_info(Sc) \ - do { \ - old_longjmp = Sc->longjmp_ok; \ - old_jump_loc = Sc->setjmp_loc; \ - old_goto_start = Sc->goto_start; \ - } while (0) - -#define restore_jump_info(Sc) \ - do { \ - Sc->longjmp_ok = old_longjmp; \ - Sc->setjmp_loc = old_jump_loc; \ - Sc->goto_start = old_goto_start; \ - if ((jump_loc == ERROR_JUMP) && \ - (Sc->longjmp_ok)) \ - LongJmp(*(Sc->goto_start), ERROR_JUMP); \ - } while (0) - -#define set_jump_info(Sc, Tag) \ - do { \ - Sc->longjmp_ok = true; \ - Sc->setjmp_loc = Tag; \ - jump_loc = SetJmp(new_goto_start, 1); \ - Sc->goto_start = &new_goto_start; \ - } while (0) - -s7_pointer s7_read(s7_scheme *sc, s7_pointer port) -{ - if (is_input_port(port)) - { - s7_pointer old_let = sc->curlet; - declare_jump_info(); - sc->curlet = sc->nil; - push_input_port(sc, port); - store_jump_info(sc); - set_jump_info(sc, READ_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } - else - { - push_stack_no_let_no_code(sc, OP_BARRIER, port); - push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_READ_INTERNAL); - if (sc->tok == TOKEN_EOF) - sc->value = eof_object; - if ((sc->cur_op == OP_EVAL_DONE) && /* pushed above */ - (stack_op(sc->stack, current_stack_top(sc) - 1) == OP_BARRIER)) - pop_stack(sc); - } - pop_input_port(sc); - set_curlet(sc, old_let); - restore_jump_info(sc); - return(sc->value); - } - sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_input_port_string); - return(NULL); -} - -static s7_pointer g_read(s7_scheme *sc, s7_pointer args) -{ - #define H_read "(read (port (current-input-port))) returns the next object in the input port, or # at the end" - #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol) - - s7_pointer port; - if (is_not_null(args)) - port = car(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_symbol, an_input_port_string)); - - if (is_function_port(port)) - { - s7_pointer res = (*(port_input_function(port)))(sc, S7_READ, port); - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), res)); - } - return(res); - } - if ((is_string_port(port)) && - (port_data_size(port) <= port_position(port))) - return(eof_object); - - push_input_port(sc, port); - push_stack_op_let(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ - push_stack_op_let(sc, OP_READ_INTERNAL); - return(port); -} - - -/* -------------------------------- load -------------------------------- */ -#if WITH_MULTITHREAD_CHECKS -typedef struct { - s7_scheme* sc; - const int32_t lock_count; /* Remember lock count in case we have skipped calls to leave_track_scope by longjmp-ing */ -} lock_scope_t; - -static lock_scope_t enter_lock_scope(s7_scheme *sc) -{ - int32_t result = pthread_mutex_trylock(&sc->lock); - if (result != 0) - { - fprintf(stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)", result, EBUSY); - abort(); - } - sc->lock_count++; - { - lock_scope_t st = {.sc = sc, .lock_count = sc->lock_count}; - return(st); - } -} - -static void leave_lock_scope(lock_scope_t *st) -{ - while (st->sc->lock_count > st->lock_count) - { - st->sc->lock_count--; - pthread_mutex_unlock(&st->sc->lock); - } -} - -#define TRACK(Sc) lock_scope_t lock_scope __attribute__ ((__cleanup__(leave_lock_scope))) = enter_lock_scope(Sc) -#else -#define TRACK(Sc) -#endif - -/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */ - -static block_t *search_load_path(s7_scheme *sc, const char *name) -{ - s7_pointer lst = s7_load_path(sc); - if (is_pair(lst)) - { -#if MS_WINDOWS || defined(__linux__) - #define S7_FILENAME_MAX 4096 /* so we can handle 4095 chars (need trailing null) -- this limit could be added to *s7* */ -#else - #define S7_FILENAME_MAX 1024 -#endif - /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */ - block_t *b = mallocate(sc, S7_FILENAME_MAX); - char *filename = (char *)block_data(b); - s7_int name_len = safe_strlen(name); - for (s7_pointer dir_names = lst; is_pair(dir_names); dir_names = cdr(dir_names)) - { - const char *new_dir = string_value(car(dir_names)); - if (new_dir) - { - if ((WITH_WARNINGS) && (string_length(car(dir_names)) + name_len >= S7_FILENAME_MAX)) - s7_warn(sc, 256, "load: file + directory name too long: %" ld64 " + %" ld64 " > %d\n", - name_len, string_length(car(dir_names)), S7_FILENAME_MAX); - filename[0] = '\0'; - if (new_dir[strlen(new_dir) - 1] == '/') - catstrs(filename, S7_FILENAME_MAX, new_dir, name, (char *)NULL); - else catstrs(filename, S7_FILENAME_MAX, new_dir, "/", name, (char *)NULL); -#ifdef _MSC_VER - if (_access(filename, 0) != -1) - return(b); -#else - if (access(filename, F_OK) == 0) - return(b); -#endif - }} - liberate(sc, b); - } - return(NULL); -} - -#if WITH_C_LOADER -#include - -static block_t *full_filename(s7_scheme *sc, const char *filename) -{ - char *rtn; - block_t *block; - if ((S7_DEBUGGING) && ((!filename) || (!*filename))) fprintf(stderr, "%s[%d]: filename is %s\n", __func__, __LINE__, filename); - if (filename[0] == '/') - { - s7_int len = safe_strlen(filename); - block = mallocate(sc, len + 1); - rtn = (char *)block_data(block); - memcpy((void *)rtn, (void *)filename, len); - rtn[len] = '\0'; - } - else - { - char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ - size_t pwd_len = safe_strlen(pwd); - size_t filename_len = safe_strlen(filename); - s7_int len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */ - block = mallocate(sc, len); - rtn = (char *)block_data(block); - if (pwd) - { - memcpy((void *)rtn, (void *)pwd, pwd_len); - rtn[pwd_len] = '/'; - memcpy((void *)(rtn + pwd_len + 1), (void *)filename, filename_len); - rtn[pwd_len + filename_len + 1] = '\0'; - free(pwd); - } - else /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ - { - memcpy((void *)rtn, (void *)filename, filename_len); - rtn[filename_len] = '\0'; - }} - return(block); -} - -static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointer let) -{ - /* if fname ends in .so|.dylib, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */ - s7_int fname_len = safe_strlen(fname); - if (((fname_len > 3) && - (local_strcmp((const char *)(fname + (fname_len - 3)), ".so"))) || /* linux */ - ((fname_len > 6) && - (local_strcmp((const char *)(fname + (fname_len - 3)), ".dylib")))) /* mac */ - { - void *library; - char *pwd_name = NULL; - block_t *pname = NULL; - - if ((access(fname, F_OK) == 0) || (fname[0] == '/')) - { - pname = full_filename(sc, fname); - pwd_name = (char *)block_data(pname); - } - else - { - block_t *searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */ - if (searched) - { - if (((const char *)block_data(searched))[0] == '/') - pname = searched; - else - { /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */ - pname = full_filename(sc, (const char *)block_data(searched)); - liberate(sc, searched); - } - pwd_name = (char *)block_data(pname); - } - else /* perhaps no *load-path* entries */ - { - pname = full_filename(sc, fname); - pwd_name = (char *)block_data(pname); - }} - if ((S7_DEBUGGING) && (!pname)) fprintf(stderr, "pname is null\n"); - library = dlopen((pname) ? pwd_name : fname, RTLD_NOW); - if (!library) - s7_warn(sc, 512, "load %s failed: %s\n", (pname) ? pwd_name : fname, dlerror()); - else - if (let) /* look for 'init_func in let */ - { - s7_pointer init = let_ref(sc, let, make_symbol(sc, "init_func", 9)); - /* init is a symbol (surely not a gensym?), so it should not need to be protected */ - if (!is_symbol(init)) - s7_warn(sc, 512, "can't load %s: no init function\n", fname); - else - { - const char *init_name; - void *init_func; - - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (pname) ? (const char *)pwd_name : fname))); - - init_name = symbol_name(init); - init_func = dlsym(library, init_name); - if (init_func) - { - typedef void (*dl_func)(s7_scheme *sc); - typedef s7_pointer (*dl_func_with_args)(s7_scheme *sc, s7_pointer args); - s7_pointer init_args = let_ref(sc, let, make_symbol(sc, "init_args", 9)); - s7_pointer p; - gc_protect_via_stack(sc, init_args); - if (is_pair(init_args)) - { - p = ((dl_func_with_args)init_func)(sc, init_args); - set_stack_protected2(sc, p); - } - /* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok, - * but the returned value is whatever was last computed in the init_func. - */ - else - { - /* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when - * init_func accesses the forgotten args. s7_is_valid can't catch this currently -- - * we need a better way to tell that a random value can't be a cell pointer (scan permallocs and use heap_location?) - */ - ((dl_func)init_func)(sc); - p = sc->F; - } - unstack(sc); - if (pname) liberate(sc, pname); - return(p); - } - s7_warn(sc, 512, "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n", - fname, init_name, dlerror(), display(let)); - dlclose(library); - } - if (S7_DEBUGGING) fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init)); - if (pname) liberate(sc, pname); - return(sc->undefined); - } - if (pname) liberate(sc, pname); - } - return(NULL); -} -#endif - -static s7_pointer load_file_1(s7_scheme *sc, const char *filename) -{ - char *local_file_name = (char *)filename; - FILE* fp = fopen(filename, "r"); -#if WITH_GCC - if ((!fp) && /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */ - (filename[0] == '~') && (filename[1] == '/')) - { - char *home = getenv("HOME"); - if (home) - { - s7_int file_len = safe_strlen(filename); - s7_int home_len = safe_strlen(home); - s7_int len = file_len + home_len; - block_t *b = mallocate(sc, len); - char *fname = (char *)block_data(b); - memcpy((void *)fname, home, home_len); - memcpy((void *)(fname + home_len), (char *)(filename + 1), file_len - 1); - fname[len - 1] = '\0'; - fp = fopen(fname, "r"); - if (fp) local_file_name = copy_string_with_length(fname, len - 1); - liberate(sc, b); - }} -#endif - if (!fp) - { - const char *fname; - block_t *b = search_load_path(sc, filename); - if (!b) return(NULL); - fname = (const char *)block_data(b); - fp = fopen(fname, "r"); - if (fp) local_file_name = copy_string_with_length(fname, safe_strlen(fname)); - liberate(sc, b); - } - if (fp) - { - s7_pointer port; - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, local_file_name))); - port = read_file(sc, fp, local_file_name, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ - port_file_number(port) = remember_file_name(sc, local_file_name); - if (filename != local_file_name) free(local_file_name); - set_loader_port(port); - push_input_port(sc, port); - return(port); - } - return(NULL); -} - -s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e) -{ - /* returns either the value of the load or NULL if filename not found */ - s7_pointer port; - declare_jump_info(); - TRACK(sc); - if (e == sc->s7_starlet) return(NULL); - -#if WITH_C_LOADER - port = load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e); - if (port) return(port); -#endif - - if (is_directory(filename)) return(NULL); - port = load_file_1(sc, filename); - if (!port) return(NULL); - - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); - - store_jump_info(sc); - set_jump_info(sc, LOAD_SET_JUMP); - if (jump_loc == NO_JUMP) - eval(sc, OP_READ_INTERNAL); - else - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - pop_input_port(sc); - if (is_input_port(port)) - s7_close_input_port(sc, port); - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->nil));} - -s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e) -{ - s7_pointer port; - s7_int port_loc; - declare_jump_info(); - TRACK(sc); - - if (content[bytes] != 0) - error_nr(sc, make_symbol(sc, "bad-data", 8), set_elist_1(sc, wrap_string(sc, "s7_load_c_string content is not terminated", 42))); - port = open_input_string(sc, content, bytes); - port_loc = gc_protect_1(sc, port); - set_loader_port(port); - push_input_port(sc, port); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); - s7_gc_unprotect_at(sc, port_loc); - - store_jump_info(sc); - set_jump_info(sc, LOAD_SET_JUMP); - if (jump_loc == NO_JUMP) - eval(sc, OP_READ_INTERNAL); - else - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - pop_input_port(sc); - if (is_input_port(port)) - s7_close_input_port(sc, port); - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes) -{ - return(s7_load_c_string_with_environment(sc, content, bytes, sc->nil)); -} - -static s7_pointer g_load(s7_scheme *sc, s7_pointer args) -{ - #define H_load "(load file (let (rootlet))) loads the scheme file 'file'. The 'let' argument \ -defaults to the rootlet. To load into the current environment instead, pass (curlet)." - #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) - - s7_pointer name = car(args); - const char *fname; - - if (!is_string(name)) - return(method_or_bust(sc, name, sc->load_symbol, args, sc->type_names[T_STRING], 1)); - - if (is_pair(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->load_symbol, 2, e, a_let_string); - if (e == sc->s7_starlet) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name)); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - } - else sc->curlet = sc->nil; - - fname = string_value(name); - if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */ - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "load's first argument, ~S, should be a filename", 47), name)); - - if (is_directory(fname)) - error_nr(sc, sc->io_error_symbol, - set_elist_2(sc, wrap_string(sc, "load: ~S is a directory", 23), wrap_string(sc, fname, safe_strlen(fname)))); -#if WITH_C_LOADER - { - s7_pointer p = load_shared_object(sc, fname, (is_null(sc->curlet)) ? sc->rootlet : sc->curlet); - if (p) return(p); - } -#endif - errno = 0; - if (!load_file_1(sc, fname)) - file_error_nr(sc, "load", strerror(errno), fname); - - push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was pushing args and code, but I don't think they're used later */ - push_stack_op_let(sc, OP_READ_INTERNAL); - return(sc->unspecified); -} - - -/* -------- *load-path* -------- */ -s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_value(sc, sc->load_path_symbol));} - -s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir) -{ - s7_symbol_set_value(sc, sc->load_path_symbol, cons(sc, s7_make_string(sc, dir), s7_symbol_value(sc, sc->load_path_symbol))); - return(s7_symbol_value(sc, sc->load_path_symbol)); -} - -static s7_pointer g_load_path_set(s7_scheme *sc, s7_pointer args) -{ - /* new value must be either () or a proper list of strings */ - s7_pointer x; - if (is_null(cadr(args))) return(cadr(args)); - if (!is_pair(cadr(args))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); - for (x = cadr(args); is_pair(x); x = cdr(x)) - if (!is_string(car(x))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); - if (!is_null(x)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); - return(cadr(args)); -} - -/* -------- *cload-directory* -------- */ -static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args) -{ - /* this sets the directory for cload.scm's output */ - s7_pointer cl_dir = cadr(args); - if (!is_string(cl_dir)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *cload-directory* to ~S", 33), cadr(args))); - s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir); - if (string_length(cl_dir) > 0) /* was strlen(string_value)? */ - s7_add_to_load_path(sc, (const char *)(string_value(cl_dir))); - /* should this remove the previous *cload-directory* name first? or not affect *load-path* at all? */ - return(cl_dir); -} - - -/* ---------------- autoload ---------------- */ -#define INITIAL_AUTOLOAD_NAMES_SIZE 4 - -void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size) -{ - /* names should be sorted alphabetically by the symbol name (the even indexes in the names array) - * size is the number of symbol names (half the size of the names array( - * the idea here is that by sticking to string constants we can handle 90% of the work at compile-time, - * with less start-up memory. Then eventually we'll add C libraries and every name in those libraries - * will come as an import once dlopen has picked up the library. - */ - if (sc->safety > 1) - for (int32_t i = 0, k = 2; k < (size * 2); i += 2, k += 2) - if ((names[i]) && (names[k]) && (strcmp(names[i], names[k]) > 0)) - { - s7_warn(sc, 256, "%s: names[%d]: %s is out of order\n", __func__, k, names[k]); - break; - } - if (!sc->autoload_names) - { - sc->autoload_names = (const char ***)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(const char **)); - sc->autoload_names_sizes = (s7_int *)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(s7_int)); - sc->autoloaded_already = (bool **)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(bool *)); - sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE; - sc->autoload_names_loc = 0; - } - else - if (sc->autoload_names_loc >= sc->autoload_names_top) - { - sc->autoload_names_top *= 2; - sc->autoload_names = (const char ***)Realloc(sc->autoload_names, sc->autoload_names_top * sizeof(const char **)); - sc->autoload_names_sizes = (s7_int *)Realloc(sc->autoload_names_sizes, sc->autoload_names_top * sizeof(s7_int)); - sc->autoloaded_already = (bool **)Realloc(sc->autoloaded_already, sc->autoload_names_top * sizeof(bool *)); - for (s7_int i = sc->autoload_names_loc; i < sc->autoload_names_top; i++) - { - sc->autoload_names[i] = NULL; - sc->autoload_names_sizes[i] = 0; - sc->autoloaded_already[i] = NULL; - }} - sc->autoload_names[sc->autoload_names_loc] = names; - sc->autoload_names_sizes[sc->autoload_names_loc] = size; - sc->autoloaded_already[sc->autoload_names_loc] = (bool *)Calloc(size, sizeof(bool)); - sc->autoload_names_loc++; -} - -static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading) -{ - s7_int l = 0, libs = sc->autoload_names_loc; - const char *name = symbol_name(symbol); - for (s7_int lib = 0; lib < libs; lib++) - { - s7_int u = sc->autoload_names_sizes[lib] - 1; - const char **names = sc->autoload_names[lib]; - while (true) - { - s7_int comp, pos; - const char *this_name; - if (u < l) break; - pos = (l + u) / 2; - this_name = names[pos * 2]; - comp = strcmp(this_name, name); - if (comp == 0) - { - *already_loaded = sc->autoloaded_already[lib][pos]; - if (loading) sc->autoloaded_already[lib][pos] = true; - return(names[pos * 2 + 1]); /* file name given func name */ - } - if (comp < 0) - l = pos + 1; - else u = pos - 1; - }} - return(NULL); -} - -s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function) -{ - /* add '(symbol . file) to s7's autoload table */ - if (is_null(sc->autoload_table)) - sc->autoload_table = s7_make_hash_table(sc, sc->default_hash_table_length); /* add_hash_table here, perhaps sc->hash_tables->loc-- */ - if (sc->safety >= MORE_SAFETY_WARNINGS) - { - s7_pointer p = s7_hash_table_ref(sc, sc->autoload_table, symbol); - if ((p != sc->F) && (p != file_or_function)) - s7_warn(sc, 256, "'%s autoload value changed\n", symbol_name(symbol)); - } - s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function); - return(file_or_function); -} - -static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args) -{ - #define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \ -If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \ -the function. The function takes one argument, the calling environment. Presumably the symbol is defined \ -in the file, or by the function." - #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T) - - s7_pointer sym = car(args), value; - if (is_string(sym)) - { - if (string_length(sym) == 0) /* (autoload "" ...) */ - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a symbol-name or a symbol", 25)); - sym = make_symbol(sc, string_value(sym), string_length(sym)); - } - if (!is_symbol(sym)) - { - check_method(sc, sym, sc->autoload_symbol, args); - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a string (symbol-name) or a symbol", 34)); - } - if (is_keyword(sym)) - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a normal symbol (a keyword is never unbound)", 44)); - - value = cadr(args); - if (is_string(value)) - return(s7_autoload(sc, sym, s7_immutable(make_string_with_length(sc, string_value(value), string_length(value))))); - if (((is_closure(value)) || (is_closure_star(value))) && - (s7_is_aritable(sc, value, 1))) - return(s7_autoload(sc, sym, value)); - - check_method(sc, value, sc->autoload_symbol, args); - wrong_type_error_nr(sc, sc->autoload_symbol, 2, value, wrap_string(sc, "a string (file-name) or a thunk", 31)); - return(NULL); /* make tcc happy */ -} - - -/* -------------------------------- *autoload* -------------------------------- */ -static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* function */ -{ - #define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f." - #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) - - s7_pointer sym = car(args); - if (!is_symbol(sym)) - { - check_method(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym)); - wrong_type_error_nr(sc, wrap_string(sc, "*autoload*", 10), 1, sym, sc->type_names[T_SYMBOL]); - } - if (sc->autoload_names) - { - bool loaded = false; - const char *file = find_autoload_name(sc, sym, &loaded, false); - if (file) - return(s7_make_string(sc, file)); - } - if (is_hash_table(sc->autoload_table)) - return(s7_hash_table_ref(sc, sc->autoload_table, sym)); - return(sc->F); -} - - -/* ---------------- require ---------------- */ -static bool is_memq(const s7_pointer sym, s7_pointer lst) -{ - for (s7_pointer x = lst; is_pair(x); x = cdr(x)) - if (sym == car(x)) - return(true); - return(false); -} - -static s7_pointer g_require(s7_scheme *sc, s7_pointer args) -{ - #define H_require "(require symbol . symbols) loads each file associated with each symbol if it has not been loaded already.\ -The symbols refer to the argument to \"provide\". (require lint.scm)" - /* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */ - - s7_gc_protect_via_stack(sc, args); - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer sym; - if (is_symbol(car(p))) - sym = car(p); - else - if ((is_proper_quote(sc, car(p))) && - (is_symbol(cadar(p)))) - sym = cadar(p); - else - { - unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "require: ~S is not a symbol", 27), car(p))); - } - if ((!is_memq(sym, s7_symbol_value(sc, sc->features_symbol))) && - (sc->is_autoloading)) - { - s7_pointer f = g_autoloader(sc, set_plist_1(sc, sym)); - if (is_false(sc, f)) - { - unstack(sc); - error_nr(sc, sc->autoload_error_symbol, - set_elist_2(sc, wrap_string(sc, "require: no autoload info for ~S", 32), sym)); - } - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, f)); - if (is_string(f)) - s7_load_with_environment(sc, string_value(f), sc->curlet); - else - if (is_closure(f)) /* f should be a function of one argument, the current (calling) environment */ - s7_call(sc, f, set_ulist_1(sc, sc->curlet, sc->nil)); - }} - if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) /* op_error_quit if load failed in scheme in Snd */ - unstack(sc); - return(sc->T); -} - - -/* ---------------- provided? ---------------- */ -static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args) -{ - #define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list" - #define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol) - - s7_pointer sym = car(args), topf, x; - if (!is_symbol(sym)) - return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL])); - - /* here the *features* list is spread out (or can be anyway) along the curlet chain, - * so we need to travel back all the way to the top level checking each *features* list in turn. - * Since *features* grows via cons (newest first), we can stop the scan if we hit the shared - * top-level at least. - */ - topf = global_value(sc->features_symbol); - if (is_memq(sym, topf)) - return(sc->T); - - if (is_global(sc->features_symbol)) - return(sc->F); - for (x = sc->curlet; symbol_id(sc->features_symbol) < let_id(x); x = let_outlet(x)); - for (; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if ((slot_symbol(y) == sc->features_symbol) && - (slot_value(y) != topf) && - (is_memq(sym, slot_value(y)))) - return(sc->T); - return(sc->F); -} - -bool s7_is_provided(s7_scheme *sc, const char *feature) -{ - return(is_memq(make_symbol_with_strlen(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */ -} - -static bool is_provided_b_7p(s7_scheme *sc, s7_pointer sym) -{ - if (!is_symbol(sym)) - return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL]) != sc->F); - return(is_memq(sym, s7_symbol_value(sc, sc->features_symbol))); -} - - -/* ---------------- provide ---------------- */ -static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) -{ - /* this has to be relative to the curlet: (load file env) - * the things loaded are only present in env, and go away with it, so should not be in the global *features* list - */ - s7_pointer p; - if (!is_symbol(sym)) - return(method_or_bust_p(sc, sym, sc->provide_symbol, sc->type_names[T_SYMBOL])); - - if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet)) fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); - if ((sc->curlet == sc->nil) || (sc->curlet == sc->shadow_rootlet)) - p = global_slot(sc->features_symbol); - else p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */ - if ((is_slot(p)) && (is_immutable(p))) - s7_warn(sc, 256, "provide: *features* is immutable!\n"); - else - { - s7_pointer lst = slot_value(lookup_slot_from(sc->features_symbol, sc->curlet)); /* in either case, we want the current *features* list */ - if (p == sc->undefined) - add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); - else - if ((!is_memq(sym, lst)) && (!is_memq(sym, slot_value(p)))) - slot_set_value(p, cons(sc, sym, slot_value(p))); - } - return(sym); -} - -static s7_pointer g_provide(s7_scheme *sc, s7_pointer args) -{ - #define H_provide "(provide symbol) adds symbol to the *features* list" - #define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol) - - if ((is_immutable(sc->curlet)) && - (sc->curlet != sc->nil)) - error_nr(sc, sc->immutable_error_symbol, - set_elist_2(sc, wrap_string(sc, "can't provide '~S (current environment is immutable)", 52), car(args))); - return(c_provide(sc, car(args))); -} - -void s7_provide(s7_scheme *sc, const char *feature) {c_provide(sc, make_symbol_with_strlen(sc, feature));} - - -static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args) /* *features* setter */ -{ - s7_pointer nf = cadr(args); - if (is_null(nf)) - return(sc->nil); - if ((!is_pair(nf)) || - (s7_list_length(sc, nf) <= 0)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *features* to ~S", 26), nf)); - for (s7_pointer p = nf; is_pair(p); p = cdr(p)) - if (!is_symbol(car(p))) - sole_arg_wrong_type_error_nr(sc, sc->features_symbol, car(p), sc->type_names[T_SYMBOL]); - return(nf); -} - -static s7_pointer g_libraries_set(s7_scheme *sc, s7_pointer args) /* *libraries* setter */ -{ - s7_pointer nf = cadr(args); - if (is_null(nf)) - return(sc->nil); - if ((!is_pair(nf)) || - (s7_list_length(sc, nf) <= 0)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *libraries* to ~S", 27), nf)); - for (s7_pointer p = nf; is_pair(p); p = cdr(p)) - if ((!is_pair(car(p))) || - (!is_string(caar(p))) || - (!is_let(cdar(p)))) - sole_arg_wrong_type_error_nr(sc, sc->libraries_symbol, car(p), wrap_string(sc, "a list of conses of the form (string . let)", 43)); - return(nf); -} - - -/* -------------------------------- eval-string -------------------------------- */ -s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e) -{ - s7_pointer code, port, result; - TRACK(sc); - push_stack_direct(sc, OP_GC_PROTECT); /* not gc protection here, but restoration of original context */ - port = s7_open_input_string(sc, str); - code = s7_read(sc, port); - s7_close_input_port(sc, port); - result = s7_eval(sc, T_Ext(code), e); - if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) - unstack(sc); /* pop_stack(sc); */ - return(result); -} - -s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str) {return(s7_eval_c_string_with_environment(sc, str, sc->nil));} - -static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args) -{ - #define H_eval_string "(eval-string str (let (curlet))) returns the result of evaluating the string str as Scheme code" - #define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) - - s7_pointer port, str = car(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->eval_string_symbol, args, sc->type_names[T_STRING], 1)); - if (string_length(str) == 0) - return(sc->F); /* (eval-string "") -> #f */ - - if (is_not_null(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->eval_string_symbol, 2, e, a_let_string); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - } - sc->temp3 = sc->args; /* see t101-aux-17.scm */ - push_stack(sc, OP_EVAL_STRING, args, sc->code); - port = open_and_protect_input_string(sc, str); - push_input_port(sc, port); - push_stack_op_let(sc, OP_READ_INTERNAL); - return(sc->F); /* I think this means that sc->value defaults to #f in op_eval_string below, so (eval-string "") mimics (eval) -> #f */ -} - -static s7_pointer eval_string_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return(f); -} - -static s7_pointer op_eval_string(s7_scheme *sc) -{ - while (s7_peek_char(sc, current_input_port(sc)) != eof_object) /* (eval-string "(+ 1 2) this is a mistake") */ - { - int32_t tk = token(sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */ - if (tk != TOKEN_EOF) - { - s7_pointer trail_data; - s7_int trail_len = port_data_size(current_input_port(sc)) - port_position(current_input_port(sc)) + 1; - if (trail_len > 32) trail_len = 32; - trail_data = make_string_with_length(sc, (const char *)(port_data(current_input_port(sc)) + port_position(current_input_port(sc)) - 1), trail_len); - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "eval-string trailing junk: ~S", 29), trail_data)); - }} - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - sc->code = sc->value; - set_current_code(sc, sc->code); - return(NULL); -} - - -/* -------------------------------- call-with-input-string -------------------------------- */ -static s7_pointer call_with_input(s7_scheme *sc, s7_pointer port, s7_pointer args) -{ - s7_pointer p = cadr(args); - port_set_string_or_function(port, car(args)); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); /* # here is a marker (needed) */ - push_stack(sc, OP_APPLY, list_1(sc, port), p); - return(sc->F); -} - -static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it" - #define Q_call_with_input_string sc->pl_sf - /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */ - - s7_pointer str = car(args), proc = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->call_with_input_string_symbol, args, sc->type_names[T_STRING], 1)); - - if (is_let(proc)) - check_method(sc, proc, sc->call_with_input_string_symbol, args); - - if (!s7_is_aritable(sc, proc, 1)) - wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, - wrap_string(sc, "a procedure of one argument (the port)", 38)); - if ((is_continuation(proc)) || (is_goto(proc))) - wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, a_normal_procedure_string); - return(call_with_input(sc, open_and_protect_input_string(sc, str), args)); -} - - -/* -------------------------------- call-with-input-file -------------------------------- */ -static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument" - #define Q_call_with_input_file sc->pl_sf - - s7_pointer str = car(args), proc = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->call_with_input_file_symbol, args, sc->type_names[T_STRING], 1)); - - if (!s7_is_aritable(sc, proc, 1)) - wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, - wrap_string(sc, "a procedure of one argument (the port)", 38)); - if ((is_continuation(proc)) || (is_goto(proc))) - wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, a_normal_procedure_string); - return(call_with_input(sc, open_input_file_1(sc, string_value(str), "r", "call-with-input-file"), args)); -} - - -/* -------------------------------- with-input-from-string -------------------------------- */ -static s7_pointer with_input(s7_scheme *sc, s7_pointer port, s7_pointer args) -{ - s7_pointer old_input_port = current_input_port(sc); - set_current_input_port(sc, port); - port_set_string_or_function(port, car(args)); - push_stack(sc, OP_UNWIND_INPUT, old_input_port, port); - push_stack(sc, OP_APPLY, sc->nil, cadr(args)); - return(sc->F); -} - -static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args) -{ - #define H_with_input_from_string "(with-input-from-string str thunk) opens str as the temporary current-input-port and calls thunk" - #define Q_with_input_from_string sc->pl_sf - - s7_pointer str = car(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, sc->type_names[T_STRING], 1)); - if (cadr(args) == global_value(sc->read_symbol)) - { - if (string_length(str) == 0) - return(eof_object); - push_input_port(sc, current_input_port(sc)); - set_current_input_port(sc, open_and_protect_input_string(sc, str)); - port_set_string_or_function(current_input_port(sc), str); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, current_input_port(sc)); - push_stack_op_let(sc, OP_READ_DONE); - push_stack_op_let(sc, OP_READ_INTERNAL); - return(current_input_port(sc)); - } - if (!is_thunk(sc, cadr(args))) - return(method_or_bust(sc, cadr(args), sc->with_input_from_string_symbol, args, a_thunk_string, 2)); - /* since the arguments are evaluated before we get here, we can get some confusing situations: - * (with-input-from-string "#x2.1" (read)) - * (read) -> whatever it can get from the current input port! - * ";with-input-from-string argument 2, #, is untyped but should be a thunk" - * (with-input-from-string "" (read-line)) -> hangs awaiting stdin input - * also this can't be split into wifs and wifs_read because we need the runtime value of 'read - */ - return(with_input(sc, open_and_protect_input_string(sc, str), args)); -} - - -/* -------------------------------- with-input-from-file -------------------------------- */ -static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args) -{ - #define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk" - #define Q_with_input_from_file sc->pl_sf - - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->with_input_from_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_thunk(sc, cadr(args))) - return(method_or_bust(sc, cadr(args), sc->with_input_from_file_symbol, args, a_thunk_string, 2)); - return(with_input(sc, open_input_file_1(sc, string_value(car(args)), "r", "with-input-from-file"), args)); -} - -static s7_pointer with_string_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer old_port = current_input_port(sc); - set_current_input_port(sc, open_and_protect_input_string(sc, sc->value)); - push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc)); - sc->curlet = inline_make_let(sc, sc->curlet); - return(opt2_pair(sc->code)); -} - -static s7_pointer with_file_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer old_port = current_input_port(sc); - set_current_input_port(sc, open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file")); - push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc)); - sc->curlet = inline_make_let(sc, sc->curlet); - return(opt2_pair(sc->code)); -} - -static s7_pointer with_file_out(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_file(sc, string_value(sc->value), "w")); - push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); - sc->curlet = make_let(sc, sc->curlet); - return(opt2_pair(sc->code)); -} - -static s7_pointer call_string_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer port = open_and_protect_input_string(sc, sc->value); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - return(opt2_pair(sc->code)); -} - -static s7_pointer call_file_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer port = open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file"); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - return(opt2_pair(sc->code)); -} - -static s7_pointer call_file_out(s7_scheme *sc, s7_pointer args) -{ - s7_pointer port = s7_open_output_file(sc, string_value(sc->value), "w"); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); - sc->curlet = make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - return(opt2_pair(sc->code)); -} - -static s7_pointer c_function_name_to_symbol(s7_scheme *sc, s7_pointer f) -{ - if (!is_c_function(f)) /* c_function* uses c_sym slot for arg_names */ - return(make_symbol(sc, c_function_name(f), c_function_name_length(f))); - if (!c_function_symbol(f)) - c_function_symbol(f) = make_symbol(sc, c_function_name(f), c_function_name_length(f)); - return(c_function_symbol(f)); -} - -#define op_with_io_1(Sc) (((s7_function)((Sc->code)->object.cons.opt1))(Sc, Sc->nil)) -static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code); - -static void op_with_io_1_method(s7_scheme *sc) -{ - s7_pointer lt = sc->value; - if (has_active_methods(sc, lt)) - { - s7_pointer method = car(sc->code); - if (is_c_function(method)) /* #_call-with-input-string et al */ - method = c_function_name_to_symbol(sc, method); - push_stack(sc, OP_GC_PROTECT, lt, sc->code); - sc->code = caddr(sc->code); - sc->value = op_lambda(sc, sc->code); /* don't unstack */ - sc->value = find_and_apply_method(sc, lt, method, list_2(sc, lt, sc->value)); - } - else - if (is_symbol(car(sc->code))) /* might be e.g. #_call-with-input-string so use c_function_name */ - wrong_type_error_nr(sc, car(sc->code), 1, lt, sc->type_names[T_STRING]); - else wrong_type_error_nr(sc, wrap_string(sc, c_function_name(car(sc->code)), c_function_name_length(car(sc->code))), 1, lt, sc->type_names[T_STRING]); -} - -static bool op_with_io_op(s7_scheme *sc) -{ - sc->value = cadr(sc->code); - if (is_string(sc->value)) - { - sc->code = op_with_io_1(sc); - return(false); - } - push_stack_no_args_direct(sc, OP_WITH_IO_1); - sc->code = sc->value; - return(true); -} - -static void op_with_output_to_string(s7_scheme *sc) -{ - s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_string(sc)); - push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); - sc->curlet = inline_make_let(sc, sc->curlet); - push_stack(sc, OP_GET_OUTPUT_STRING, old_port, current_output_port(sc)); - sc->code = opt2_pair(sc->code); -} - -static void op_call_with_output_string(s7_scheme *sc) -{ - s7_pointer port = s7_open_output_string(sc); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); - sc->code = opt2_pair(sc->code); -} - - -/* -------------------------------- iterators -------------------------------- */ -#if S7_DEBUGGING -static s7_pointer titr_let(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (!is_let(iterator_sequence(p))) - { - fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_pair(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (!is_pair(iterator_sequence(p))) - { - fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_hash(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (!is_hash_table(iterator_sequence(p))) - { - fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_len(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((is_hash_table(iterator_sequence(p))) || (is_pair(iterator_sequence(p)))) - { - fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_pos(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (((is_let(iterator_sequence(p))) && (iterator_sequence(p) != sc->rootlet) && (iterator_sequence(p) != sc->s7_starlet)) || - (is_pair(iterator_sequence(p)))) - { - fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} -#endif - - -/* -------------------------------- iterator? -------------------------------- */ -static s7_pointer g_is_iterator(s7_scheme *sc, s7_pointer args) -{ - #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." - #define Q_is_iterator sc->pl_bt - - s7_pointer x = car(args); - if (is_iterator(x)) return(sc->T); - /* closure itself is not an iterator: (let ((c1 (let ((+iterator+ #t) (a 0)) (lambda () (set! a (+ a 1)))))) (iterate c1)): error (a function not an iterator) */ - check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args); - return(sc->F); -} - -bool s7_is_iterator(s7_pointer obj) {return(is_iterator(obj));} - -static bool is_iterator_b_7p(s7_scheme *sc, s7_pointer obj) {return(g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F);} - - -static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer p) -{ - /* fields are obj cur [loc|lcur] [len|slow|hcur] next, but untangling them in debugging case is a pain */ - s7_pointer iter; - new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); - memcpy((void *)iter, (void *)p, sizeof(s7_cell)); /* picks up ITER_OK I hope */ - return(iter); -} - -static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator) {return(ITERATOR_END);} - -static s7_pointer iterator_quit(s7_pointer iterator) -{ - iterator_next(iterator) = iterator_finished; - clear_iter_ok(iterator); - return(ITERATOR_END); -} - -static s7_pointer let_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer p, slot = iterator_current_slot(iterator); - if (!tis_slot(slot)) - return(iterator_quit(iterator)); - iterator_set_current_slot(iterator, next_slot(slot)); - p = iterator_let_cons(iterator); - if (!p) - return(cons(sc, slot_symbol(slot), slot_value(slot))); - set_car(p, slot_symbol(slot)); - set_cdr(p, slot_value(slot)); - return(p); -} - -static s7_pointer rootlet_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer slot = iterator_current(iterator); - if (!is_slot(slot)) - return(iterator_quit(iterator)); - if (iterator_position(iterator) < sc->rootlet_entries) - { - iterator_position(iterator)++; - iterator_current(iterator) = rootlet_element(sc->rootlet, iterator_position(iterator)); - } - else iterator_current(iterator) = sc->nil; - return(cons(sc, slot_symbol(slot), slot_value(slot))); -} - -static s7_pointer hash_entry_to_cons(s7_scheme *sc, hash_entry_t *entry, s7_pointer p) -{ - if (!p) - return(cons(sc, hash_entry_key(entry), hash_entry_value(entry))); - set_car(p, hash_entry_key(entry)); - set_cdr(p, hash_entry_value(entry)); - return(p); -} - -static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer table; - s7_int len; - hash_entry_t **elements; - hash_entry_t *lst = iterator_hash_current(iterator); - - if (lst) - { - iterator_hash_current(iterator) = hash_entry_next(lst); - return(hash_entry_to_cons(sc, lst, iterator_current(iterator))); - } - table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */ - len = hash_table_mask(table) + 1; - elements = hash_table_elements(table); - - for (s7_int loc = iterator_position(iterator) + 1; loc < len; loc++) - { - hash_entry_t *x = elements[loc]; - if (x) - { - iterator_position(iterator) = loc; - iterator_hash_current(iterator) = hash_entry_next(x); - return(hash_entry_to_cons(sc, x, iterator_current(iterator))); - }} - if (is_weak_hash_table(table)) - { - clear_weak_hash_iterator(iterator); - weak_hash_iters(table)--; - } - return(iterator_quit(iterator)); -} - -static s7_pointer string_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(chars[(uint8_t)(string_value(iterator_sequence(obj))[iterator_position(obj)++])]); - return(iterator_quit(obj)); -} - -static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(small_int(byte_vector(iterator_sequence(obj), iterator_position(obj)++))); - return(iterator_quit(obj)); -} - -static s7_pointer float_vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(make_real(sc, float_vector(iterator_sequence(obj), iterator_position(obj)++))); - return(iterator_quit(obj)); -} - -static s7_pointer int_vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(make_integer(sc, int_vector(iterator_sequence(obj), iterator_position(obj)++))); - return(iterator_quit(obj)); -} - -static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(vector_element(iterator_sequence(obj), iterator_position(obj)++)); - return(iterator_quit(obj)); -} - -static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result = s7_call(sc, iterator_sequence(obj), sc->nil); - /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */ - if (result == ITERATOR_END) - { - iterator_next(obj) = iterator_finished; - clear_iter_ok(obj); - } - return(result); -} - -static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result, p, cur; - if (iterator_position(obj) >= iterator_length(obj)) - return(iterator_quit(obj)); - p = iterator_sequence(obj); - cur = iterator_current(obj); - set_car(cur, p); - set_car(cdr(cur), make_integer(sc, iterator_position(obj))); - result = (*(c_object_ref(sc, p)))(sc, cur); /* used to save/restore sc->x|z here */ - iterator_position(obj)++; - if (result == ITERATOR_END) - { - iterator_next(obj) = iterator_finished; - clear_iter_ok(obj); - } - return(result); -} - -static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj); -static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result; - if (!is_pair(iterator_current(obj))) - return(iterator_quit(obj)); - result = car(iterator_current(obj)); - iterator_current(obj) = cdr(iterator_current(obj)); - if (iterator_current(obj) == iterator_slow(obj)) - iterator_current(obj) = sc->nil; - iterator_next(obj) = pair_iterate_1; - return(result); -} - -static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result; - if (!is_pair(iterator_current(obj))) - return(iterator_quit(obj)); - result = car(iterator_current(obj)); - iterator_current(obj) = cdr(iterator_current(obj)); - if (iterator_current(obj) == iterator_slow(obj)) - iterator_current(obj) = sc->nil; - else iterator_set_slow(obj, cdr(iterator_slow(obj))); - iterator_next(obj) = pair_iterate; - return(result); -} - -static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer e, s7_pointer iter) -{ - s7_pointer func; - if ((has_active_methods(sc, e)) && - ((func = find_method_with_let(sc, e, sc->make_iterator_symbol)) != sc->undefined)) - { - s7_pointer it; - gc_protect_via_stack(sc, iter); - it = s7_apply_function(sc, func, set_plist_1(sc, e)); - unstack(sc); - if (!is_iterator(it)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "make-iterator method must return an iterator: ~S", 48), it)); - return(it); - } - return(NULL); -} - - -/* -------------------------------- make-iterator -------------------------------- */ -static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) -{ - if ((has_closure_let(x)) && (is_let(closure_let(x)))) - { - s7_pointer val = symbol_to_local_slot(sc, sym, closure_let(x)); - if ((!is_slot(val)) && (is_let(let_outlet(closure_let(x))))) - val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); - if (is_slot(val)) - return(slot_value(val)); - } - return(NULL); -} - -static bool is_iterable_closure(s7_scheme *sc, s7_pointer x) -{ - s7_pointer iter; - if (!is_thunk(sc, x)) - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, x, a_thunk_string); - iter = funclet_entry(sc, x, sc->local_iterator_symbol); - return((iter) && (iter != sc->F)); -} - -static s7_pointer s7_starlet_make_iterator(s7_scheme *sc, s7_pointer iter); -static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj); - -s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) -{ - s7_pointer iter, p; - new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); - iterator_sequence(iter) = e; - - if (is_pair(e)) /* by far the most common case */ - { - iterator_current(iter) = e; - iterator_next(iter) = pair_iterate; - iterator_set_slow(iter, e); - return(iter); - } - if (!is_let(e)) - iterator_position(iter) = 0; - - switch (type(e)) - { - case T_LET: - if (e == sc->rootlet) - { - iterator_current(iter) = rootlet_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */ - iterator_position(iter) = 0; - iterator_next(iter) = rootlet_iterate; - return(iter); - } - if (e == sc->s7_starlet) - return(s7_starlet_make_iterator(sc, iter)); - p = find_make_iterator_method(sc, e, iter); - if (p) {free_cell(sc, iter); return(p);} - iterator_set_current_slot(iter, let_slots(e)); - iterator_next(iter) = let_iterate; - iterator_let_cons(iter) = NULL; - break; - - case T_HASH_TABLE: - iterator_hash_current(iter) = NULL; - iterator_current(iter) = NULL; - iterator_position(iter) = -1; - iterator_next(iter) = hash_table_iterate; - if (is_weak_hash_table(e)) - { - set_weak_hash_iterator(iter); - weak_hash_iters(e)++; - add_weak_hash_iterator(sc, iter); - } - break; - - case T_STRING: - iterator_length(iter) = string_length(e); - iterator_next(iter) = string_iterate; - break; - - case T_BYTE_VECTOR: - iterator_length(iter) = byte_vector_length(e); - iterator_next(iter) = byte_vector_iterate; - break; - - case T_VECTOR: - iterator_length(iter) = vector_length(e); - iterator_next(iter) = vector_iterate; - break; - - case T_INT_VECTOR: - iterator_length(iter) = vector_length(e); - iterator_next(iter) = int_vector_iterate; - break; - - case T_FLOAT_VECTOR: - iterator_length(iter) = vector_length(e); - iterator_next(iter) = float_vector_iterate; - break; - - case T_NIL: /* (make-iterator #()) -> #, so I guess () should also work */ - iterator_length(iter) = 0; - iterator_next(iter) = iterator_finished; - clear_iter_ok(iter); - break; - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_iterable_closure(sc, e)) - { - p = list_1_unchecked(sc, int_zero); - iterator_current(iter) = p; - set_mark_seq(iter); - iterator_next(iter) = closure_iterate; - iterator_length(iter) = (has_active_methods(sc, e)) ? closure_length(sc, e) : S7_INT64_MAX; - } - else - { - free_cell(sc, iter); - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, - wrap_string(sc, "a function or macro with a '+iterator+ local that is not #f", 59)); - } - break; - - case T_C_OBJECT: - iterator_length(iter) = c_object_length_to_int(sc, e); - p = find_make_iterator_method(sc, e, iter); - if (p) {free_cell(sc, iter); return(p);} - iterator_current(iter) = list_2_unchecked(sc, e, int_zero); /* if not unchecked, gc protect iter */ - set_mark_seq(iter); - iterator_next(iter) = c_object_iterate; - break; - - default: - free_cell(sc, iter); /* 19-Mar-22 */ - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, a_sequence_string); - } - return(iter); -} - -static s7_pointer g_make_iterator(s7_scheme *sc, s7_pointer args) -{ - #define H_make_iterator "(make-iterator sequence carrier) returns an iterator object that returns the next value \ -in the sequence each time it is called. When it reaches the end, it returns " ITERATOR_END_NAME "." - #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, sc->is_pair_symbol) - - /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */ - s7_pointer seq = car(args); - s7_pointer carrier = (is_pair(cdr(args))) ? cadr(args) : NULL; - s7_pointer iter = s7_make_iterator(sc, seq); - - if (carrier) - { - if (!is_pair(carrier)) - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, carrier, sc->type_names[T_PAIR]); - if (is_immutable_pair(carrier)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->make_iterator_symbol, carrier)); - - if (is_hash_table(iterator_sequence(iter))) - { - iterator_current(iter) = carrier; - set_mark_seq(iter); - } - else - if ((is_let(iterator_sequence(iter))) && - (iterator_sequence(iter) != sc->rootlet)) - { - iterator_let_cons(iter) = carrier; - set_mark_seq(iter); - }} - return(iter); -} - - -/* -------------------------------- iterate -------------------------------- */ -static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args) -{ - #define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "." - #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol) - s7_pointer iter = car(args); - if (!is_iterator(iter)) - return(sole_arg_method_or_bust(sc, iter, sc->iterate_symbol, args, sc->type_names[T_ITERATOR])); - return((iterator_next(iter))(sc, iter)); -} - -static s7_pointer iterate_p_p(s7_scheme *sc, s7_pointer iter) -{ - if (!is_iterator(iter)) - return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); - return((iterator_next(iter))(sc, iter)); -} - -s7_pointer s7_iterate(s7_scheme *sc, s7_pointer obj) {return((iterator_next(obj))(sc, obj));} - -bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj) -{ - if (!is_iterator(obj)) - sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]); - return(!iter_ok(obj)); -} - -static bool op_implicit_iterate(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_iterator(s)) {sc->last_function = s; return(false);} - sc->value = (iterator_next(s))(sc, s); - return(true); -} - - -/* -------------------------------- iterator-at-end? -------------------------------- */ -static bool iterator_is_at_end_b_7p(s7_scheme *sc, s7_pointer obj) -{ - if (!is_iterator(obj)) - sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]); - return(!iter_ok(obj)); -} - -static s7_pointer g_iterator_is_at_end(s7_scheme *sc, s7_pointer args) -{ - #define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence." - #define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol) - s7_pointer iter = car(args); - if (!is_iterator(iter)) - return(sole_arg_method_or_bust(sc, iter, sc->iterator_is_at_end_symbol, args, sc->type_names[T_ITERATOR])); - return(make_boolean(sc, !iter_ok(iter))); -} - - -/* -------------------------------- iterator-sequence -------------------------------- */ -static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args) -{ - #define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing." - #define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol) - s7_pointer iter = car(args); - if (!is_iterator(iter)) - return(sole_arg_method_or_bust(sc, iter, sc->iterator_sequence_symbol, args, sc->type_names[T_ITERATOR])); - return(iterator_sequence(iter)); -} - - -/* -------- cycles -------- */ - -#define INITIAL_SHARED_INFO_SIZE 8 - -static int32_t shared_ref(shared_info_t *ci, s7_pointer p) -{ - /* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */ - s7_pointer *objs = ci->objs; - for (int32_t i = 0; i < ci->top; i++) - if (objs[i] == p) - { - int32_t val = ci->refs[i]; - if (val > 0) - ci->refs[i] = -ci->refs[i]; - return(val); - } - return(0); -} - -static void flip_ref(shared_info_t *ci, s7_pointer p) -{ - s7_pointer *objs = ci->objs; - for (int32_t i = 0; i < ci->top; i++) - if (objs[i] == p) - { - ci->refs[i] = -ci->refs[i]; - break; - } -} - -static int32_t peek_shared_ref_1(shared_info_t *ci, s7_pointer p) -{ - /* returns 0 if not found, otherwise the ref value for p */ - s7_pointer *objs = ci->objs; - for (int32_t i = 0; i < ci->top; i++) - if (objs[i] == p) - return(ci->refs[i]); - return(0); -} - -static int32_t peek_shared_ref(shared_info_t *ci, s7_pointer p) -{ - /* returns 0 if not found, otherwise the ref value for p */ - return((is_collected_unchecked(p)) ? peek_shared_ref_1(ci, p) : 0); -} - -static void enlarge_shared_info(shared_info_t *ci) -{ - ci->size *= 2; - ci->size2 = ci->size - 2; - ci->objs = (s7_pointer *)Realloc(ci->objs, ci->size * sizeof(s7_pointer)); - ci->refs = (int32_t *)Realloc(ci->refs, ci->size * sizeof(int32_t)); - ci->defined = (bool *)Realloc(ci->defined, ci->size * sizeof(bool)); - /* this clearing is needed, memclr is not faster */ - for (int32_t i = ci->top; i < ci->size; i++) - { - ci->refs[i] = 0; - ci->objs[i] = NULL; - } -} - -static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length); -static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash); - -static bool check_collected(s7_pointer top, shared_info_t *ci) -{ - s7_pointer *objs_end = (s7_pointer *)(ci->objs + ci->top); - for (s7_pointer *p = ci->objs; p < objs_end; p++) - if ((*p) == top) - { - int32_t i = (int32_t)(p - ci->objs); - if (ci->refs[i] == 0) - { - ci->has_hits = true; - ci->refs[i] = ++ci->ref; /* if found, set the ref number */ - } - break; - } - set_cyclic(top); - return(true); -} - -static bool collect_vector_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length) -{ - s7_int plen; - bool cyclic = false; - - if (stop_at_print_length) - { - plen = sc->print_length; - if (plen > vector_length(top)) - plen = vector_length(top); - } - else plen = vector_length(top); - - for (s7_int i = 0; i < plen; i++) - { - s7_pointer vel = unchecked_vector_element(top, i); /* "unchecked" because top might be rootlet, I think */ - if ((has_structure(vel)) && - (collect_shared_info(sc, ci, vel, stop_at_print_length))) - { - set_cyclic(vel); - cyclic = true; - if ((is_c_pointer(vel)) || - (is_iterator(vel)) || - (is_c_object(vel))) - check_collected(top, ci); - }} - if (cyclic) set_cyclic(top); - return(cyclic); -} - -static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length) -{ - /* look for top in current list. - * As we collect objects (guaranteed to have structure) we set the collected bit. If we ever - * encounter an object with that bit on, we've seen it before so we have a possible cycle. - * Once the collection pass is done, we run through our list, and clear all these bits. - */ - bool top_cyclic; - - if (is_collected_or_shared(top)) - return((!is_shared(top)) && (check_collected(top, ci))); - - /* top not seen before -- add it to the list */ - set_collected(top); - - if (ci->top == ci->size) - enlarge_shared_info(ci); - ci->objs[ci->top++] = top; - - top_cyclic = false; - /* now search the rest of this structure */ - if (is_pair(top)) - { - s7_pointer p; - if ((has_structure(car(top))) && - (collect_shared_info(sc, ci, car(top), stop_at_print_length))) - top_cyclic = true; - - for (p = cdr(top); is_pair(p); p = cdr(p)) - { - if (is_collected_or_shared(p)) - { - set_cyclic(top); - set_cyclic(p); - if (!is_shared(p)) - return(check_collected(p, ci)); - if (!top_cyclic) - for (s7_pointer cp = top; cp != p; cp = cdr(cp)) set_shared(cp); - return(top_cyclic); - } - set_collected(p); - if (ci->top == ci->size) - enlarge_shared_info(ci); - ci->objs[ci->top++] = p; - if ((has_structure(car(p))) && - (collect_shared_info(sc, ci, car(p), stop_at_print_length))) - top_cyclic = true; - } - if ((has_structure(p)) && - (collect_shared_info(sc, ci, p, stop_at_print_length))) - { - set_cyclic(top); - return(true); - } - if (!top_cyclic) - for (s7_pointer cp = top; is_pair(cp); cp = cdr(cp)) set_shared(cp); - else set_cyclic(top); - return(top_cyclic); - } - - switch (type(top)) - { - case T_VECTOR: - if (collect_vector_info(sc, ci, top, stop_at_print_length)) - top_cyclic = true; - break; - - case T_ITERATOR: - if ((is_sequence(iterator_sequence(top))) && /* might be a function with +iterator+ local */ - (collect_shared_info(sc, ci, iterator_sequence(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, iterator_sequence(top)) == 0) - check_collected(iterator_sequence(top), ci); - top_cyclic = true; - } - break; - - case T_HASH_TABLE: - if (hash_table_entries(top) > 0) - { - s7_int len = hash_table_mask(top) + 1; - hash_entry_t **entries = hash_table_elements(top); - bool keys_safe = hash_keys_not_cyclic(sc, top); - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - { - if ((!keys_safe) && - (has_structure(hash_entry_key(p))) && - (collect_shared_info(sc, ci, hash_entry_key(p), stop_at_print_length))) - top_cyclic = true; - if ((has_structure(hash_entry_value(p))) && - (collect_shared_info(sc, ci, hash_entry_value(p), stop_at_print_length))) - { - if ((is_c_pointer(hash_entry_value(p))) || - (is_iterator(hash_entry_value(p))) || - (is_c_object(hash_entry_value(p)))) - check_collected(top, ci); - top_cyclic = true; - }}} - break; - - case T_SLOT: /* this can be hit if we somehow collect_shared_info on sc->rootlet via collect_vector_info (see the let case below) */ - if ((has_structure(slot_value(top))) && - (collect_shared_info(sc, ci, slot_value(top), stop_at_print_length))) - top_cyclic = true; - break; - - case T_LET: - if (top == sc->rootlet) - { - if (collect_vector_info(sc, ci, top, stop_at_print_length)) - top_cyclic = true; - } - else - for (s7_pointer q = top; is_let(q) && (q != sc->rootlet); q = let_outlet(q)) - for (s7_pointer p = let_slots(q); tis_slot(p); p = next_slot(p)) - if ((has_structure(slot_value(p))) && - (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) - { - top_cyclic = true; - if ((is_c_pointer(slot_value(p))) || - (is_iterator(slot_value(p))) || - (is_c_object(slot_value(p)))) - check_collected(top, ci); - } - break; - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (collect_shared_info(sc, ci, closure_body(top), stop_at_print_length)) - { - if (peek_shared_ref(ci, top) == 0) - check_collected(top, ci); - top_cyclic = true; - } - break; - - case T_C_POINTER: - if ((has_structure(c_pointer_type(top))) && - (collect_shared_info(sc, ci, c_pointer_type(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, c_pointer_type(top)) == 0) - check_collected(c_pointer_type(top), ci); - top_cyclic = true; - } - if ((has_structure(c_pointer_info(top))) && - (collect_shared_info(sc, ci, c_pointer_info(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, c_pointer_info(top)) == 0) - check_collected(c_pointer_info(top), ci); - top_cyclic = true; - } - break; - - case T_C_OBJECT: - if ((c_object_to_list(sc, top)) && - (c_object_set(sc, top)) && - (collect_shared_info(sc, ci, (*(c_object_to_list(sc, top)))(sc, set_plist_1(sc, top)), stop_at_print_length))) - { - if (peek_shared_ref(ci, top) == 0) - check_collected(top, ci); - top_cyclic = true; - } - break; - } - if (!top_cyclic) - set_shared(top); - else set_cyclic(top); - return(top_cyclic); -} - -static shared_info_t *init_circle_info(s7_scheme *sc) -{ - shared_info_t *ci = (shared_info_t *)Calloc(1, sizeof(shared_info_t)); - ci->size = INITIAL_SHARED_INFO_SIZE; - ci->size2 = ci->size - 2; - ci->objs = (s7_pointer *)Malloc(ci->size * sizeof(s7_pointer)); - ci->refs = (int32_t *)Calloc(ci->size, sizeof(int32_t)); /* finder expects 0 = unseen previously */ - ci->defined = (bool *)Calloc(ci->size, sizeof(bool)); - ci->cycle_port = sc->F; - ci->init_port = sc->F; - return(ci); -} - -static inline shared_info_t *new_shared_info(s7_scheme *sc) -{ - shared_info_t *ci = sc->circle_info; - if (ci->top > 0) - { - memclr((void *)(ci->refs), ci->top * sizeof(int32_t)); - memclr((void *)(ci->defined), ci->top * sizeof(bool)); - for (int32_t i = 0; i < ci->top; i++) - clear_cyclic_bits(ci->objs[i]); /* LOOP_4 is not faster */ - ci->top = 0; - } - ci->ref = 0; - ci->has_hits = false; - ci->ctr = 0; - return(ci); -} - -static shared_info_t *make_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length) -{ - /* for the printer, here only if is_structure(top) and top is not sc->rootlet */ - bool no_problem = true; - s7_int k, stop_len; - - /* check for simple cases first */ - if (is_pair(top)) - { - s7_pointer x = top; - if (stop_at_print_length) - { - s7_pointer slow = top; - stop_len = sc->print_length; - for (k = 0; k < stop_len; k += 2) - { - if (!is_pair(x)) break; - if (has_structure(car(x))) {no_problem = false; break;} - x = cdr(x); - if (!is_pair(x)) break; - if (has_structure(car(x))) {no_problem = false; break;} - x = cdr(x); - slow = cdr(slow); - if (x == slow) {no_problem = false; break;} - }} - else - if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */ - no_problem = false; - else - for (; is_pair(x); x = cdr(x)) - if (has_structure(car(x))) {no_problem = false; break;} /* perhaps (and (length > 0)) or vector typer etc */ - if ((no_problem) && - (!is_null(x)) && (has_structure(x))) - no_problem = false; - if (no_problem) return(NULL); - } - else - if (is_normal_vector(top)) /* any other vector can't happen */ - { - stop_len = vector_length(top); - if ((stop_at_print_length) && - (stop_len > sc->print_length)) - stop_len = sc->print_length; - for (k = 0; k < stop_len; k++) - if (has_structure(vector_element(top, k))) {no_problem = false; break;} - if (no_problem) return(NULL); - } -#if 1 - else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */ - if ((is_let(top)) && (top != sc->rootlet)) - { - for (s7_pointer lp = top; (no_problem) && (is_let(lp)) && (lp != sc->rootlet); lp = let_outlet(lp)) - for (s7_pointer p = let_slots(lp); tis_slot(p); p = next_slot(p)) - if (has_structure(slot_value(p))) /* slot_symbol need not be checked? */ - {no_problem = false; break;} - if (no_problem) return(NULL); - } - else - if (is_hash_table(top)) - { - s7_int len = hash_table_mask(top) + 1; - hash_entry_t **entries = hash_table_elements(top); - bool keys_safe = hash_keys_not_cyclic(sc, top); - if (hash_table_entries(top) == 0) return(NULL); - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - if (((!keys_safe) && (has_structure(hash_entry_key(p)))) || - (has_structure(hash_entry_value(p)))) - {no_problem = false; break;} - if (no_problem) return(NULL); - } -#endif - if ((S7_DEBUGGING) && (is_any_vector(top)) && (!is_normal_vector(top))) fprintf(stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__); - - { - shared_info_t *ci = new_shared_info(sc); - /* collect all pointers associated with top */ - bool cyclic = collect_shared_info(sc, ci, top, stop_at_print_length); - s7_pointer *ci_objs = ci->objs; - int32_t *ci_refs = ci->refs; - int32_t refs = 0; - - for (int32_t i = 0; i < ci->top; i++) - clear_collected_and_shared(ci_objs[i]); - - if (!cyclic) - return(NULL); - if (!(ci->has_hits)) - return(NULL); - - /* find if any were referenced twice (once for just being there, so twice=shared) - * we know there's at least one such reference because has_hits is true. - */ - for (int32_t i = 0; i < ci->top; i++) - if (ci_refs[i] > 0) - { - set_collected(ci_objs[i]); - if (i == refs) - refs++; - else - { - ci_objs[refs] = ci_objs[i]; - ci_refs[refs++] = ci_refs[i]; - ci_refs[i] = 0; - ci_objs[i] = NULL; - }} - ci->top = refs; - return(ci); - } -} - - -/* -------------------------------- cyclic-sequences -------------------------------- */ -static s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj) -{ - if (has_structure(obj)) - { - shared_info_t *ci = (sc->object_out_locked) ? sc->circle_info : make_shared_info(sc, obj, false); /* false=don't stop at print length (vectors etc) */ - if (ci) - { - s7_pointer lst; - sc->w = sc->nil; - check_free_heap_size(sc, ci->top); - for (int32_t i = 0; i < ci->top; i++) - sc->w = cons_unchecked(sc, ci->objs[i], sc->w); - lst = sc->w; - sc->w = sc->unused; - return(lst); - }} - return(sc->nil); -} - -static s7_pointer g_cyclic_sequences(s7_scheme *sc, s7_pointer args) -{ - #define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic." - #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T) - return(cyclic_sequences_p_p(sc, car(args))); -} - - -/* -------------------------------- object->port (display format etc) -------------------------------- */ -static int32_t circular_list_entries(s7_pointer lst) -{ - int32_t i = 1; - for (s7_pointer x = cdr(lst); ; i++, x = cdr(x)) - { - int32_t j = 0; - for (s7_pointer y = lst; j < i; y = cdr(y), j++) - if (x == y) - return(i); - } -} - -static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info_t *ci); -#define object_to_port_with_circle_check(Sc, Vr, Port, Use_Write, Ci) \ - do { \ - s7_pointer _V_ = Vr; \ - if ((Ci) && (has_structure(_V_))) \ - object_to_port_with_circle_check_1(Sc, _V_, Port, Use_Write, Ci); \ - else object_to_port(Sc, _V_, Port, Use_Write, Ci); \ - } while (0) - -static void (*display_functions[256])(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci); -#define object_to_port(Sc, Obj, Port, Use_Write, Ci) (*display_functions[unchecked_type(Obj)])(Sc, Obj, Port, Use_Write, Ci) - -static bool string_needs_slashification(const uint8_t *str, s7_int len) -{ - /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */ - const uint8_t *pend = (const uint8_t *)(str + len); - for (const uint8_t *p = str; p < pend; p++) - if (slashify_table[*p]) - return(true); - return(false); -} - -#define IN_QUOTES true -#define NOT_IN_QUOTES false - -static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char *p, s7_int len, bool quoted) -{ - uint8_t *pcur, *pend, *pstart = NULL; - if (len == 0) - { - if (quoted) - port_write_string(port)(sc, "\"\"", 2, port); - return; - } - pend = (uint8_t *)(p + len); - - /* what about the trailing nulls? Guile writes them out (as does s7 currently) - * but that is not ideal. I'd like to use ~S for error messages, so that - * strings are clearly identified via the double-quotes, but this way of - * writing them is ugly: - * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) str) -> "a\x00\x00\x00\x00\x00\x00\x00" - * but it would be misleading to omit them because: - * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) (string-append str "bc")) -> "a\x00\x00\x00\x00\x00\x00\x00bc" - * also it is problematic to use sc->print_length here (rather than a separate string-print-length) because - * it is normally (say) 8 which truncates just about every string. In CL, *print-length* - * does not affect strings, symbols, or bit-vectors. But if the string is enormous, - * this function can bring us to a complete halt. string-print-length (as a *s7* field) is - * also problematic -- it does not behave as expected in many cases if it is limited to this - * function and string_to_port below, and if set too low, disables the repl. - */ - if (quoted) port_write_character(port)(sc, '"', port); - for (pcur = (uint8_t *)p; pcur < pend; pcur++) - if (slashify_table[*pcur]) - { - if (pstart) pstart++; else pstart = (uint8_t *)p; - if (pstart != pcur) - { - port_write_string(port)(sc, (char *)pstart, pcur - pstart, port); - pstart = pcur; - } - port_write_character(port)(sc, '\\', port); - switch (*pcur) - { - case '"': port_write_character(port)(sc, '"', port); break; - case '\\': port_write_character(port)(sc, '\\', port); break; - case '\'': port_write_character(port)(sc, '\'', port); break; - case '\t': port_write_character(port)(sc, 't', port); break; - case '\r': port_write_character(port)(sc, 'r', port); break; - case '\b': port_write_character(port)(sc, 'b', port); break; - case '\f': port_write_character(port)(sc, 'f', port); break; - case '\?': port_write_character(port)(sc, '?', port); break; - case 'x': port_write_character(port)(sc, 'x', port); break; - default: - { - char buf[5]; - s7_int n = (s7_int)(*pcur); - buf[0] = 'x'; - buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16]; - buf[2] = dignum[n % 16]; - buf[3] = ';'; - buf[4] = '\0'; - port_write_string(port)(sc, buf, 4, port); - } - break; - }} - if (!pstart) - port_write_string(port)(sc, (char *)p, len, port); - else - { - pstart++; - if (pstart != pcur) - port_write_string(port)(sc, (char *)pstart, pcur - pstart, port); - } - if (quoted) port_write_character(port)(sc, '"', port); -} - -static void output_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if ((obj == sc->standard_output) || - (obj == sc->standard_error)) - port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port); - else - if (use_write == P_READABLE) - { - if (port_is_closed(obj)) - port_write_string(port)(sc, "(let ((p (open-output-string))) (close-output-port p) p)", 56, port); - else - if (is_string_port(obj)) - { - port_write_string(port)(sc, "(let ((p (open-output-string)))", 31, port); - if (port_position(obj) > 0) - { - port_write_string(port)(sc, " (display ", 10, port); - slashify_string_to_port(sc, port, (const char *)port_data(obj), port_position(obj), IN_QUOTES); - port_write_string(port)(sc, " p)", 3, port); - } - port_write_string(port)(sc, " p)", 3, port); - } - else - if (is_file_port(obj)) - { - char str[256]; - int32_t nlen; - str[0] = '\0'; - nlen = catstrs(str, 256, "(open-output-file \"", port_filename(obj), "\" \"a\")", (char *)NULL); - port_write_string(port)(sc, str, nlen, port); - } - else port_write_string(port)(sc, "#", 23, port); - } - else - { - if (is_string_port(obj)) - port_write_string(port)(sc, "#", 8, port); - else port_write_character(port)(sc, '>', port); - } -} - -static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (obj == sc->standard_input) - port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port); - else - if (use_write == P_READABLE) - { - if (port_is_closed(obj)) - port_write_string(port)(sc, "(call-with-input-string \"\" (lambda (p) p))", 42, port); - else - if (is_function_port(obj)) - port_write_string(port)(sc, "#", 22, port); - else - if (is_file_port(obj)) - { - char str[256]; - int32_t nlen; - str[0] = '\0'; - nlen = catstrs(str, 256, "(open-input-file \"", port_filename(obj), "\")", (char *)NULL); - port_write_string(port)(sc, str, nlen, port); - } - else - { - s7_int data_len = port_data_size(obj) - port_position(obj); - if (data_len > 100) - { - const char *filename = (const char *)s7_port_filename(sc, obj); - if (filename) - { - #define DO_STR_LEN 1024 - char do_str[DO_STR_LEN]; - int32_t len; - do_str[0] = '\0'; - if (port_position(obj) > 0) - { - len = catstrs(do_str, DO_STR_LEN, "(let ((port (open-input-file \"", filename, "\")))", (char *)NULL); - port_write_string(port)(sc, do_str, len, port); - do_str[0] = '\0'; - len = catstrs(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ", - pos_int_to_str_direct(sc, port_position(obj) - 1), - ") port)))", (char *)NULL); - } - else len = catstrs(do_str, DO_STR_LEN, "(open-input-file \"", filename, "\")", (char *)NULL); - port_write_string(port)(sc, do_str, len, port); - return; - }} - port_write_string(port)(sc, "(open-input-string ", 19, port); - /* not port_write_string here because there might be embedded double-quotes */ - slashify_string_to_port(sc, port, (const char *)(port_data(obj) + port_position(obj)), port_data_size(obj) - port_position(obj), IN_QUOTES); - port_write_character(port)(sc, ')', port); - }} - else - { - if (is_string_port(obj)) - port_write_string(port)(sc, "#", 8, port); - else port_write_character(port)(sc, '>', port); - } -} - -static bool symbol_needs_slashification(s7_scheme *sc, s7_pointer obj) -{ - uint8_t *pend; - const char *str = symbol_name(obj); - s7_int len; - - if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ',')) - return(true); - if (is_number(make_atom(sc, (char *)str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) - return(true); - - len = symbol_name_length(obj); - pend = (uint8_t *)(str + len); - for (uint8_t *p = (uint8_t *)str; p < pend; p++) - if (symbol_slashify_table[*p]) - return(true); - set_clean_symbol(obj); - return(false); -} - -static /* inline */ void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - /* I think this is the only place we print a symbol's name; ci is needed to be a display_function, it is not used */ - if ((!is_clean_symbol(obj)) && - (symbol_needs_slashification(sc, obj))) - { - port_write_string(port)(sc, "(symbol \"", 9, port); - slashify_string_to_port(sc, port, symbol_name(obj), symbol_name_length(obj), NOT_IN_QUOTES); - port_write_string(port)(sc, "\")", 2, port); - } - else - { - char c = '\0'; - if ((use_write == P_READABLE) || (use_write == P_CODE)) - { - if (!is_keyword(obj)) c = '\''; - } - else if ((use_write == P_KEY) && (!is_keyword(obj))) c = ':'; - if (is_string_port(port)) - { - s7_int new_len = port_position(port) + symbol_name_length(obj) + ((c) ? 1 : 0); - if (new_len >= port_data_size(port)) - resize_port_data(sc, port, new_len * 2); - if (c) port_data(port)[port_position(port)++] = c; - memcpy((void *)(port_data(port) + port_position(port)), (void *)symbol_name(obj), symbol_name_length(obj)); - port_position(port) = new_len; - } - else - { - if (c) port_write_character(port)(sc, c, port); - port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port); - }} -} - -static char *multivector_indices_to_string(s7_scheme *sc, s7_int index, s7_pointer vect, char *str, int32_t str_len, int32_t cur_dim) -{ - s7_int size = vector_dimension(vect, cur_dim); - s7_int ind = index % size; - if (cur_dim > 0) - multivector_indices_to_string(sc, (index - ind) / size, vect, str, str_len, cur_dim - 1); - catstrs(str, str_len, " ", pos_int_to_str_direct(sc, ind), (char *)NULL); - return(str); -} - -#define NOT_P_DISPLAY(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice) - -static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer port, - int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, bool *last, - use_write_t use_write, shared_info_t *ci) -{ - if (use_write != P_READABLE) - { - if (*last) - port_write_string(port)(sc, " (", 2, port); - else port_write_character(port)(sc, '(', port); - (*last) = false; - } - for (int32_t i = 0; i < vector_dimension(vec, dimension); i++) - if (dimension == (dimensions - 1)) - { - if (flat_ref < out_len) - { - object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, NOT_P_DISPLAY(use_write), ci); - - if (use_write == P_READABLE) - port_write_string(port)(sc, ") ", 2, port); - flat_ref++; - } - else - { - port_write_string(port)(sc, "...)", 4, port); - return(flat_ref); - } - if ((use_write != P_READABLE) && - (i < (vector_dimension(vec, dimension) - 1))) - port_write_character(port)(sc, ' ', port); - } - else - if (flat_ref < out_len) - flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, NOT_P_DISPLAY(use_write), ci); - else - { - port_write_string(port)(sc, "...)", 4, port); - return(flat_ref); - } - if (use_write != P_READABLE) - port_write_character(port)(sc, ')', port); - (*last) = true; - return(flat_ref); -} - -static int32_t multivector_to_port(s7_scheme *sc, s7_pointer vec, s7_pointer port, - int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, - use_write_t use_write, shared_info_t *ci) -{ - bool last = false; - return(multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension, dimensions, &last, use_write, ci)); -} - -static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port) -{ - s7_int vlen; - int32_t plen; - char buf[128]; - const char* vtyp = ""; - - if (is_float_vector(vect)) - vtyp = "float-"; - else - if (is_int_vector(vect)) - vtyp = "int-"; - else - if (is_byte_vector(vect)) - vtyp = "byte-"; - vlen = vector_length(vect); - - if (vector_rank(vect) == 1) - { - plen = catstrs_direct(buf, "(make-", vtyp, "vector ", integer_to_string_no_length(sc, vlen), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else - { - s7_int dim; - plen = catstrs_direct(buf, "(make-", vtyp, "vector '(", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - for (dim = 0; dim < vector_ndims(vect) - 1; dim++) - { - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), ") ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } -} - -static void write_vector_dimensions(s7_scheme *sc, s7_pointer vect, s7_pointer port) -{ - char buf[128]; - s7_int dim, plen; - port_write_string(port)(sc, " '(", 3, port); - for (dim = 0; dim < vector_ndims(vect) - 1; dim++) - { - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), "))", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); -} - -static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port); - -static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - s7_int i, len = vector_length(vect), plen; - bool too_long = false; - char buf[2048]; /* 128 is too small -- this is the list of indices with a few minor flourishes */ - - if (len == 0) - { - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, "#()", 3, port); - return; - } - if (use_write != P_READABLE) - { - if (sc->print_length == 0) - { - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, "#(...)", 6, port); - return; - } - if (len > sc->print_length) - { - too_long = true; - len = sc->print_length; - }} - if ((!ci) && - (len > 1000)) - { - s7_int vlen = vector_length(vect); - s7_pointer *els = vector_elements(vect); - s7_pointer p0 = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != p0) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - object_to_port(sc, p0, port, use_write, NULL); - if (is_typed_vector(vect)) - { - port_write_character(port)(sc, ' ', port); - port_write_vector_typer(sc, vect, port); - } - port_write_character(port)(sc, ')', port); - return; - }} - - check_stack_size(sc); - s7_gc_protect_via_stack(sc, vect); - if (use_write == P_READABLE) - { - int32_t vref; - if ((ci) && - (is_cyclic(vect)) && - ((vref = peek_shared_ref(ci, vect)) != 0)) - { - s7_pointer *els = vector_elements(vect); - if (vref < 0) vref = -vref; - if ((ci->defined[vref]) || (port == ci->cycle_port)) - { - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, vref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - unstack(sc); - return; - } - - if (is_typed_vector(vect)) - port_write_string(port)(sc, "(let (( ", 11, port); - - if (vector_rank(vect) > 1) - port_write_string(port)(sc, "(subvector ", 11, port); - - port_write_string(port)(sc, "(vector", 7, port); /* top level let */ - for (i = 0; i < len; i++) - if (has_structure(els[i])) - { - int32_t eref = peek_shared_ref(ci, els[i]); - port_write_string(port)(sc, " #f", 3, port); - if (eref != 0) - { - if (eref < 0) eref = -eref; - if (vector_rank(vect) > 1) - { - s7_int dimension = vector_rank(vect) - 1; - int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t *b = callocate(sc, str_len); - char *indices = (char *)block_data(b); - multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */ - plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), ">", - indices, ") <", pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - liberate(sc, b); - } - else - { - size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string(sc, i, &plen), ") <", - pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); - }} - else - { - if (vector_rank(vect) > 1) - { - s7_int dimension = vector_rank(vect) - 1; - int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t *b = callocate(sc, str_len); - char *indices = (char *)block_data(b); - buf[0] = '\0'; - multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */ - plen = catstrs(buf, 2048, " (set! (<", pos_int_to_str_direct(sc, vref), ">", indices, ") ", (char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - liberate(sc, b); - } - else - { - size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string_no_length(sc, i), ") ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); - } - object_to_port_with_circle_check(sc, els[i], ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, els[i], port, P_READABLE, ci); - } - port_write_character(port)(sc, ')', port); - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - write_vector_dimensions(sc, vect, port); - } - if (is_typed_vector(vect)) - { - port_write_string(port)(sc, ")) (set! (vector-typer ) ", 28, port); - port_write_vector_typer(sc, vect, port); - port_write_string(port)(sc, ") )", 6, port); - }} - else - { - if (is_typed_vector(vect)) - port_write_string(port)(sc, "(let (( ", 11, port); - /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let (( (vector 'a 'a 'a))) (set! (vector-typer ) symbol?) )" */ - - if (vector_rank(vect) > 1) - port_write_string(port)(sc, "(subvector ", 11, port); - - if (is_immutable_vector(vect)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - port_write_string(port)(sc, "(vector", 7, port); - for (i = 0; i < len; i++) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, vector_element(vect, i), port, P_READABLE, ci); - } - - if (is_immutable_vector(vect)) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - - if (vector_rank(vect) > 1) /* subvector above */ - { - plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - write_vector_dimensions(sc, vect, port); - } - if (is_typed_vector(vect)) - { - port_write_string(port)(sc, ")) (set! (vector-typer ) ", 28, port); - port_write_vector_typer(sc, vect, port); - port_write_string(port)(sc, ") )", 6, port); - }}} - else /* not readable write */ - { - if (vector_rank(vect) > 1) - { - if (vector_ndims(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_character(port)(sc, '#', port); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), use_write, ci); - } - else - { - port_write_string(port)(sc, "#(", 2, port); - for (i = 0; i < len - 1; i++) - { - object_to_port_with_circle_check(sc, vector_element(vect, i), port, NOT_P_DISPLAY(use_write), ci); - port_write_character(port)(sc, ' ', port); - } - object_to_port_with_circle_check(sc, vector_element(vect, i), port, NOT_P_DISPLAY(use_write), ci); - - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - }} - unstack(sc); -} - -static int32_t print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write) -{ - int32_t plen, len = vector_length(vect); - char buf[128]; - const char *vtype = "r"; - - if (is_int_vector(vect)) vtype = "i"; - else if (is_byte_vector(vect)) vtype = "u"; - if (len == 0) - { - if (vector_rank(vect) > 1) - plen = catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL); - else plen = catstrs_direct(buf, "#", vtype, "()", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return(-1); - } - if (use_write == P_READABLE) - return(len); - if (sc->print_length != 0) - return((len > sc->print_length) ? sc->print_length : len); - - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else - if (is_int_vector(vect)) - port_write_string(port)(sc, "#i(...)", 7, port); - else - if (is_float_vector(vect)) - port_write_string(port)(sc, "#r(...)", 7, port); - else port_write_string(port)(sc, "#u(...)", 7, port); - return(-1); -} - -static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_int plen; - bool too_long; - char buf[128]; - char *p; - s7_int len = print_vector_length(sc, vect, port, use_write); - if (len < 0) return; - too_long = (len < vector_length(vect)); - - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (len > 1000) - { - s7_int i, vlen = vector_length(vect); - s7_int *els = int_vector_ints(vect); - s7_int first = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != first) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - p = integer_to_string(sc, int_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} - if (vector_rank(vect) == 1) - { - port_write_string(port)(sc, "#i(", 3, port); - if (!is_string_port(port)) - { - p = integer_to_string(sc, int_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - for (s7_int i = 1; i < len; i++) - { - plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - }} - else - { - s7_int new_len = port_position(port); - s7_int next_len = port_data_size(port) - 128; - uint8_t *dbuf = port_data(port); - if (new_len >= next_len) - { - resize_port_data(sc, port, port_data_size(port) * 2); - next_len = port_data_size(port) - 128; - dbuf = port_data(port); - } - p = integer_to_string(sc, int_vector(vect, 0), &plen); - memcpy((void *)(dbuf + new_len), (void *)p, plen); - new_len += plen; - for (s7_int i = 1; i < len; i++) - { - if (new_len >= next_len) - { - resize_port_data(sc, port, port_data_size(port) * 2); - next_len = port_data_size(port) - 128; - dbuf = port_data(port); - } - plen = catstrs_direct((char *)(dbuf + new_len), " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); - new_len += plen; - } - port_position(port) = new_len; - } - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - } - else - { - plen = catstrs_direct(buf, "#i", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - s7_gc_protect_via_stack(sc, vect); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL); - unstack(sc); - } - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); -} - -static void float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - #define FV_BUFSIZE 512 /* some floats can take around 312 bytes */ - char buf[FV_BUFSIZE]; - s7_int i, plen; - bool too_long; - s7_double *els = float_vector_floats(vect); - s7_int len = print_vector_length(sc, vect, port, use_write); - if (len < 0) return; /* vector-length=0 etc */ - too_long = (len < vector_length(vect)); - - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (len > 1000) - { - s7_int vlen = vector_length(vect); - s7_double first = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != first) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - plen = snprintf(buf, FV_BUFSIZE, "%.*g)", sc->float_format_precision, first); - port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); - return; - }} - - if (vector_rank(vect) == 1) - { - port_write_string(port)(sc, "#r(", 3, port); - plen = snprintf(buf, FV_BUFSIZE - 4, "%.*g", sc->float_format_precision, els[0]); /* -4 so floatify has room */ - floatify(buf, &plen); - port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); - for (i = 1; i < len; i++) - { - plen = snprintf(buf, FV_BUFSIZE - 4, " %.*g", sc->float_format_precision, els[i]); - plen--; /* fixup for the initial #\space */ - floatify((char *)(buf + 1), &plen); - port_write_string(port)(sc, buf, clamp_length(plen + 1, FV_BUFSIZE), port); - } - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - } - else - { - plen = catstrs_direct(buf, "#r", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - s7_gc_protect_via_stack(sc, vect); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL); - unstack(sc); - } - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); -} - -static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_int i, plen; - bool too_long; - char buf[128]; - char *p; - s7_int len = print_vector_length(sc, vect, port, use_write); - if (len < 0) return; - too_long = (len < vector_length(vect)); - - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (len > 1000) - { - s7_int vlen = vector_length(vect); - uint8_t *els = byte_vector_bytes(vect); - uint8_t first = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != first) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - p = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */ - port_write_string(port)(sc, p, plen, port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} - - if (vector_rank(vect) == 1) - { - port_write_string(port)(sc, "#u(", 3, port); - p = integer_to_string(sc, byte_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - for (i = 1; i < len; i++) - { - plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, byte_vector(vect, i)), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - } - else - { - plen = catstrs_direct(buf, "#u", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL); - } - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); -} - -static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - bool immutable = ((use_write == P_READABLE) && - (is_immutable_string(obj)) && - (string_length(obj) > 0)); /* (immutable "") looks dumb */ - if (immutable) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (string_length(obj) > 0) - { - /* since string_length is a scheme length, not C, this write can embed nulls from C's point of view */ - if (string_length(obj) > 1000) /* was 10000 28-Feb-18 */ - { - size_t size; - char buf[128]; - buf[0] = string_value(obj)[0]; - buf[1] = '\0'; - size = strspn((const char *)(string_value(obj) + 1), buf); /* if all #\null, this won't work */ - if (size == (size_t)(string_length(obj) - 1)) - { - s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))]; - int32_t nlen = catstrs_direct(buf, "(make-string ", pos_int_to_str_direct(sc, string_length(obj)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - port_write_string(port)(sc, character_name(c), character_name_length(c), port); - if (immutable) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} - if (use_write == P_DISPLAY) - port_write_string(port)(sc, string_value(obj), string_length(obj), port); - else - if (!string_needs_slashification((const uint8_t *)string_value(obj), string_length(obj))) - { - port_write_character(port)(sc, '"', port); - port_write_string(port)(sc, string_value(obj), string_length(obj), port); - port_write_character(port)(sc, '"', port); - } - else slashify_string_to_port(sc, port, string_value(obj), string_length(obj), IN_QUOTES); - } - else - if (use_write != P_DISPLAY) - port_write_string(port)(sc, "\"\"", 2, port); - - if (immutable) - port_write_character(port)(sc, ')', port); -} - -static s7_int list_length_with_immutable_check(s7_scheme *sc, s7_pointer a, bool *immutable) -{ - s7_pointer slow = a, fast = a; - for (s7_int i = 0; ; i += 2) - { - if (!is_pair(fast)) return((is_null(fast)) ? i : -i); - if (is_immutable(fast)) *immutable = true; - fast = cdr(fast); - if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); - if (is_immutable(fast)) *immutable = true; - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) return(0); - } - return(0); -} - -static void simple_list_readable_display(s7_scheme *sc, s7_pointer lst, s7_int true_len, s7_int len, s7_pointer port, shared_info_t *ci, bool immutable) -{ - /* the easier cases: no circles or shared refs to patch up */ - s7_pointer x; - - if ((true_len > 0) && (!immutable)) - { - port_write_string(port)(sc, "list", 4, port); - for (x = lst; is_pair(x); x = cdr(x)) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); - } - port_write_character(port)(sc, ')', port); - } - else - { - s7_int immutable_ctr = 0; - if (is_immutable(lst)) - { - port_write_string(port)(sc, "immutable! (cons ", 17, port); - immutable_ctr++; - } - else port_write_string(port)(sc, "cons ", 5, port); - object_to_port_with_circle_check(sc, car(lst), port, P_READABLE, ci); - - for (x = cdr(lst); is_pair(x); x = cdr(x)) - { - if (is_immutable(x)) - { - port_write_string(port)(sc, " (immutable! (cons ", 19, port); - immutable_ctr++; - } - else port_write_string(port)(sc, " (cons ", 7, port); - object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); - } - if (is_null(x)) - port_write_string(port)(sc, " ()", 3, port); - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, x, port, P_READABLE, ci); - } - for (s7_int i = (true_len <= 0) ? 1 : 0; i < len; i++) - port_write_character(port)(sc, ')', port); - for (s7_int i = 0; i < immutable_ctr; i++) - port_write_character(port)(sc, ')', port); - } -} - -static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - s7_pointer x; - s7_int i, len; - bool immutable = false; - s7_int true_len = list_length_with_immutable_check(sc, lst, &immutable); - if (true_len < 0) /* a dotted list -- handle cars, then final cdr */ - len = (-true_len + 1); - else len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */ - - if ((use_write == P_READABLE) && - (ci)) - { - int32_t href = peek_shared_ref(ci, lst); - if (href != 0) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return; - }}} - - if ((use_write != P_READABLE) && - (car(lst) == sc->quote_symbol) && - (true_len == 2)) - { - /* len == 1 is important, otherwise (list 'quote 1 2) -> '1 2 which looks weird - * or (object->string (apply . `''1)) -> "'quote 1" - * so (quote x) = 'x but (quote x y z) should be left alone (if evaluated, it's an error) - * :readable is tricky because the list might be something like (list 'quote (lambda () #f)) which needs to be evalable back to its original - */ - port_write_character(port)(sc, '\'', port); - object_to_port_with_circle_check(sc, cadr(lst), port, P_WRITE, ci); - return; - } - - if (is_multiple_value(lst)) - port_write_string(port)(sc, "(values ", 8, port); - else port_write_character(port)(sc, '(', port); - - check_stack_size(sc); - s7_gc_protect_via_stack(sc, lst); - - if (use_write == P_READABLE) - { - if (!is_cyclic(lst)) - { - /* here (and in the cyclic case) we need to handle immutable pairs -- this requires using cons rather than list etc */ - simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - unstack(sc); - return; - } - if (ci) - { - int32_t plen; - s7_pointer local_port; - char buf[128], lst_name[128]; - bool lst_local = false; - int32_t lst_ref = peek_shared_ref(ci, lst); - if (lst_ref == 0) - { - s7_pointer p; - for (p = lst; is_pair(p); p = cdr(p)) - if ((has_structure(car(p))) || - ((is_pair(cdr(p))) && - (peek_shared_ref(ci, cdr(p)) != 0))) - { - lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; - lst_local = true; - port_write_string(port)(sc, "let (( (list", 15, port); /* '(' above */ - break; - } - if (!lst_local) - { - if (has_structure(p)) - { - lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; - lst_local = true; - port_write_string(port)(sc, "let (( (list", 15, port); /* '(' above */ - } - else - { - simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - unstack(sc); - return; - }}} - else - { - if (lst_ref < 0) lst_ref = -lst_ref; - catstrs_direct(lst_name, "<", pos_int_to_str_direct(sc, lst_ref), ">", (const char *)NULL); - port_write_string(port)(sc, "list", 4, port); /* '(' above */ - } - - for (i = 0, x = lst; (i < len) && (is_pair(x)); x = cdr(x), i++) - { - if ((has_structure(car(x))) && - (is_cyclic(car(x)))) - port_write_string(port)(sc, " #f", 3, port); - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, car(x), port, use_write, ci); - } - if ((is_pair(cdr(x))) && - (peek_shared_ref(ci, cdr(x)) != 0)) - break; - } - - if (lst_local) - port_write_string(port)(sc, "))) ", 4, port); - else port_write_character(port)(sc, ')', port); - - /* fill in the cyclic entries */ - local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(x . 1) (signature (int-vector))) :readable) */ - for (x = lst, i = 0; (i < len) && (is_pair(x)); x = cdr(x), i++) - { - int32_t lref; - if ((has_structure(car(x))) && - (is_cyclic(car(x)))) - { - if (i == 0) - plen = catstrs_direct(buf, " (set-car! ", lst_name, " ", (const char *)NULL); - else plen = catstrs_direct(buf, " (set! (", lst_name, " ", pos_int_to_str_direct(sc, i), ") ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - lref = peek_shared_ref(ci, car(x)); - if (lref == 0) - object_to_port_with_circle_check(sc, car(x), local_port, use_write, ci); - else - { - if (lref < 0) lref = -lref; - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - } - port_write_string(local_port)(sc, ") ", 2, local_port); - } - if ((is_pair(cdr(x))) && - ((lref = peek_shared_ref(ci, cdr(x))) != 0)) - { - if (lref < 0) lref = -lref; - if (i == 0) - plen = catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! ", lst_name, " <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - else - if (i == 1) - plen = catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! (cdr ", lst_name, ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - else plen = catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct_1(sc, i), - ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - break; - }} - if (true_len < 0) /* dotted list */ - { - s7_pointer end_x; - for (end_x = lst; is_pair(end_x); end_x = cdr(end_x)); /* or maybe faster, start at x? */ - /* we can't depend on the loops above to set x to the last element because they sometimes break out */ - if (true_len == -1) /* cons cell */ - plen = catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! ", lst_name, " ", (const char *)NULL); - else - if (true_len == -2) - plen = catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! (cdr ", lst_name, ") ", (const char *)NULL); - else plen = catstrs_direct(buf, "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct(sc, len - 2), ") ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - object_to_port_with_circle_check(sc, end_x, local_port, use_write, ci); - port_write_string(local_port)(sc, ") ", 2, local_port); - } - if (lst_local) - port_write_string(local_port)(sc, " )", 8, local_port); - } - else simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - } - else /* not :readable */ - { - s7_int plen = (len > sc->print_length) ? sc->print_length : len; - if (plen <= 0) - { - port_write_string(port)(sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */ - unstack(sc); - return; - } - if (ci) - { - for (x = lst, i = 0; (is_pair(x)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, x) == 0)); i++, x = cdr(x)) - { - ci->ctr++; - if (ci->ctr > sc->print_length) - { - port_write_string(port)(sc, " ...)", 5, port); - unstack(sc); - return; - } - object_to_port_with_circle_check(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - if (i < (len - 1)) - port_write_character(port)(sc, ' ', port); - } - if (is_not_null(x)) - { - if (plen < len) - port_write_string(port)(sc, " ...", 4, port); - else - { - if ((true_len == 0) && - (i == len)) - port_write_string(port)(sc, " . ", 3, port); - else port_write_string(port)(sc, ". ", 2, port); - object_to_port_with_circle_check(sc, x, port, NOT_P_DISPLAY(use_write), ci); - }} - port_write_character(port)(sc, ')', port); - } - else - { - s7_int len1 = plen - 1; - if (is_string_port(port)) - { - for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) - { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - if (port_position(port) >= sc->objstr_max_len) - { - unstack(sc); - return; - } - if (port_position(port) >= port_data_size(port)) - resize_port_data(sc, port, port_data_size(port) * 2); - port_data(port)[port_position(port)++] = (uint8_t)' '; - }} - else - for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) - { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - port_write_character(port)(sc, ' ', port); - } - if (is_pair(x)) - { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - x = cdr(x); - } - if (is_not_null(x)) - { - if (plen < len) - port_write_string(port)(sc, " ...", 4, port); - else - { - port_write_string(port)(sc, ". ", 2, port); - object_to_port(sc, x, port, NOT_P_DISPLAY(use_write), ci); - }} - port_write_character(port)(sc, ')', port); - }} - unstack(sc); -} - -static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let); -static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht); - -static const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer) -{ - s7_pointer sym; - if (is_c_function(typer)) return(c_function_name(typer)); - if (is_boolean(typer)) return("#t"); - sym = find_closure(sc, typer, closure_let(typer)); - if (is_null(sym)) return(NULL); - return(symbol_name(sym)); -} - -static void hash_typers_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port) -{ - if (((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash)))) && - ((!is_boolean(hash_table_key_typer(hash))) || (!is_boolean(hash_table_value_typer(hash))))) - { - const char *typer = hash_table_typer_name(sc, hash_table_key_typer(hash)); - port_write_string(port)(sc, " (cons ", 7, port); - port_write_string(port)(sc, typer, safe_strlen(typer), port); - port_write_character(port)(sc, ' ', port); - typer = hash_table_typer_name(sc, hash_table_value_typer(hash)); - port_write_string(port)(sc, typer, safe_strlen(typer), port); - port_write_string(port)(sc, "))", 2, port); - } - else port_write_character(port)(sc, ')', port); -} - -static void hash_table_procedures_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, bool closed, shared_info_t *ci) -{ - const char *typer = hash_table_checker_name(sc, hash); - if ((closed) && (is_immutable(hash))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (typer[0] == '#') /* #f */ - { - if (is_pair(hash_table_procedures(hash))) - { - s7_int nlen = 0; - const char *str = (const char *)integer_to_string(sc, hash_table_mask(hash) + 1, &nlen); - const char *checker = hash_table_typer_name(sc, hash_table_procedures_checker(hash)); - const char *mapper = hash_table_typer_name(sc, hash_table_procedures_mapper(hash)); - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); - else port_write_string(port)(sc, "(make-hash-table ", 17, port); - port_write_string(port)(sc, str, nlen, port); - if ((checker) && (mapper)) - { - if ((is_boolean(hash_table_procedures_checker(hash))) && (is_boolean(hash_table_procedures_mapper(hash)))) - port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ - else - { - port_write_string(port)(sc, " (cons ", 7, port); - port_write_string(port)(sc, checker, safe_strlen(checker), port); - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, mapper, safe_strlen(mapper), port); - port_write_character(port)(sc, ')', port); - }} - else - if ((is_any_closure(hash_table_procedures_checker(hash))) || - (is_any_closure(hash_table_procedures_mapper(hash)))) - { - port_write_string(port)(sc, " (cons ", 7, port); - if (is_any_closure(hash_table_procedures_checker(hash))) - object_to_port_with_circle_check(sc, hash_table_procedures_checker(hash), port, P_READABLE, ci); - else port_write_string(port)(sc, checker, safe_strlen(checker), port); - port_write_character(port)(sc, ' ', port); - if (is_any_closure(hash_table_procedures_mapper(hash))) - object_to_port_with_circle_check(sc, hash_table_procedures_mapper(hash), port, P_READABLE, ci); - else port_write_string(port)(sc, mapper, safe_strlen(mapper), port); - port_write_character(port)(sc, ')', port); - } - else port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ - hash_typers_to_port(sc, hash, port); - } - else - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table)", 17, port); - else port_write_string(port)(sc, "(hash-table)", 12, port); - } - else - { - s7_int nlen = 0; - char *str = integer_to_string(sc, hash_table_mask(hash) + 1, &nlen); - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); - else port_write_string(port)(sc, "(make-hash-table ", 17, port); - port_write_string(port)(sc, str, nlen, port); - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, typer, safe_strlen(typer), port); - hash_typers_to_port(sc, hash, port); - } - if (is_immutable(hash)) - port_write_character(port)(sc, ')', port); -} - -static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - s7_int gc_iter, len = hash_table_entries(hash); - bool too_long = false, hash_cyclic = false, copied = false, immut = false, letd = false; - s7_pointer iterator, p; - int32_t href = -1; - - if (len == 0) - { - if (use_write == P_READABLE) - hash_table_procedures_to_port(sc, hash, port, true, ci); - else - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table)", 17, port); - else port_write_string(port)(sc, "(hash-table)", 12, port); - } - return; - } - - if (use_write != P_READABLE) - { - s7_int plen = sc->print_length; - if (plen <= 0) - { - port_write_string(port)(sc, "(hash-table ...)", 16, port); - return; - } - if (len > plen) - { - too_long = true; - len = plen; - }} - - if ((use_write == P_READABLE) && - (ci)) - { - href = peek_shared_ref(ci, hash); - if (href != 0) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return; - }}} - - iterator = s7_make_iterator(sc, hash); - gc_iter = gc_protect_1(sc, iterator); - p = cons_unchecked(sc, sc->F, sc->F); - iterator_current(iterator) = p; - set_mark_seq(iterator); - hash_cyclic = ((ci) && (is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0)); - - if (use_write == P_READABLE) - { - if ((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash))) || (hash_chosen(hash))) - { - port_write_string(port)(sc, "(let (( ", 11, port); - letd = true; - } - else - if ((is_immutable(hash)) && (!hash_cyclic)) - { - port_write_string(port)(sc, "(immutable! ", 12, port); - immut = true; - }} - - if ((use_write == P_READABLE) && - (hash_cyclic)) - { - if (href < 0) href = -href; - if ((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table", 16, port); - else port_write_string(port)(sc, "(hash-table", 11, port); /* top level let */ - } - else - { - hash_table_procedures_to_port(sc, hash, port, true, ci); - port_write_character(port)(sc, ')', port); - } - - /* output here is deferred via ci->cycle_port until later in cyclic_out */ - for (s7_int i = 0; i < len; i++) - { - s7_pointer key_val = hash_table_iterate(sc, iterator); - s7_pointer key = car(key_val); - s7_pointer val = cdr(key_val); - char buf[128]; - int32_t eref = peek_shared_ref(ci, val); - int32_t kref = peek_shared_ref(ci, key); - int32_t plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - if (kref != 0) - { - if (kref < 0) kref = -kref; - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, kref), ">", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - } - else object_to_port(sc, key, ci->cycle_port, P_READABLE, ci); - if (eref != 0) - { - if (eref < 0) eref = -eref; - plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - } - else - { - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }}} - else - { - if (((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) || (use_write != P_READABLE)) - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table", 16, port); - else port_write_string(port)(sc, "(hash-table", 11, port); - } - else - { - hash_table_procedures_to_port(sc, hash, port, true, ci); - port_write_character(port)(sc, ')', port); - port_write_string(port)(sc, ") (copy (hash-table", 19, port); - copied = true; - } - for (s7_int i = 0; i < len; i++) - { - s7_pointer key_val = hash_table_iterate(sc, iterator); - port_write_character(port)(sc, ' ', port); - if ((use_write != P_READABLE) && (use_write != P_CODE) && (is_normal_symbol(car(key_val)))) - port_write_character(port)(sc, '\'', port); - object_to_port_with_circle_check(sc, car(key_val), port, NOT_P_DISPLAY(use_write), ci); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, cdr(key_val), port, NOT_P_DISPLAY(use_write), ci); - } - if (use_write != P_READABLE) - { - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - }} - - if (use_write == P_READABLE) - { - if (copied) - { - if (!letd) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, ") ))", 7, port); - } - else - if (letd) - port_write_string(port)(sc, ") )", 6, port); - else port_write_character(port)(sc, ')', port); - - if ((is_immutable(hash)) && (!hash_cyclic) && (!is_typed_hash_table(hash))) - port_write_character(port)(sc, ')', port); - - if ((!immut) && (is_immutable(hash)) && (!hash_cyclic)) - port_write_string(port)(sc, ") (immutable! ))", 19, port); - } - s7_gc_unprotect_at(sc, gc_iter); - iterator_current(iterator) = sc->nil; - free_cell(sc, p); /* free_cell(sc, iterator); */ /* 18-Dec-18 removed */ -} - -static void slot_list_to_port(s7_scheme *sc, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) /* bindings=let/inlet choice */ -{ - bool first_time = true; - for (; tis_slot(slot); slot = next_slot(slot)) - { - if (bindings) - { - if (first_time) - { - port_write_character(port)(sc, '(', port); - first_time = false; - } - else port_write_string(port)(sc, " (", 2, port); - } - else port_write_character(port)(sc, ' ', port); - symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? P_DISPLAY : P_KEY, NULL); /* (object->string (inlet (symbol "(\")") 1) :readable) */ - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, slot_value(slot), port, P_READABLE, ci); - if (bindings) port_write_character(port)(sc, ')', port); - } -} - -static void slot_list_to_port_with_cycle(s7_scheme *sc, s7_pointer obj, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) -{ - bool first_time = true; - for (; tis_slot(slot); slot = next_slot(slot)) - { - s7_pointer sym = slot_symbol(slot), val = slot_value(slot); - if (bindings) - { - if (first_time) - { - port_write_character(port)(sc, '(', port); - first_time = false; - } - else port_write_string(port)(sc, " (", 2, port); - } - else port_write_character(port)(sc, ' ', port); - symbol_to_port(sc, sym, port, (bindings) ? P_DISPLAY : P_KEY, NULL); - if (has_structure(val)) - { - char buf[128]; - int32_t symref; - int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), "> ", (const char *)NULL); - port_write_string(port)(sc, " #f", 3, port); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - symbol_to_port(sc, sym, ci->cycle_port, P_KEY, NULL); - - symref = peek_shared_ref(ci, val); - if (symref != 0) - { - if (symref < 0) symref = -symref; - len = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, symref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - } - else - { - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - } - if (bindings) port_write_character(port)(sc, ')', port); - if (is_immutable(obj)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, " (immutable! <", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - }} -} - -static bool let_has_setter(s7_pointer obj) -{ - for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) - if ((slot_has_setter(slot)) || (is_immutable(slot))) - return(true); - return(false); -} - -static bool slot_setters_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) -{ - bool spaced_out = false; - for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) - if (slot_has_setter(slot)) - { - if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; - port_write_string(port)(sc, "(set! (setter '", 15, port); - symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); - port_write_string(port)(sc, ") ", 2, port); - object_to_port_with_circle_check(sc, slot_setter(slot), port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); - } - return(spaced_out); -} - -static void immutable_slots_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, bool spaced_out) -{ - for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) - if (is_immutable(slot)) - { - if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; - port_write_string(port)(sc, "(immutable! '", 13, port); - symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); - port_write_character(port)(sc, ')', port); - } -} - -static void slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - /* the slot symbol might need (symbol...) in which case we don't want the preceding quote */ - symbol_to_port(sc, slot_symbol(obj), port, P_READABLE, NULL); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci); -} - -static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - /* if outer env points to (say) method list, the object needs to specialize object->string itself */ - - if (has_active_methods(sc, obj)) - { - s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol); - if (print_func != sc->undefined) - { - s7_pointer p; - /* what needs to be protected here? for one, the function might not return a string! */ - - clear_has_methods(obj); - if ((use_write == P_WRITE) || (use_write == P_CODE)) - p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - else p = s7_apply_function(sc, print_func, set_plist_2(sc, obj, (use_write == P_DISPLAY) ? sc->F : sc->readable_keyword)); - set_has_methods(obj); - - if ((is_string(p)) && - (string_length(p) > 0)) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} - if (obj == sc->rootlet) {port_write_string(port)(sc, "(rootlet)", 9, port); return;} - if (obj == sc->s7_starlet) {port_write_string(port)(sc, "*s7*", 4, port); return;} - if (sc->short_print) {port_write_string(port)(sc, "#", 6, port); return;} - - /* circles can happen here: - * (let () (let ((b (curlet))) (curlet))): #> - * or (let ((b #f)) (set! b (curlet)) (curlet)): #1=# - */ - if (use_write == P_READABLE) - { - int32_t lref; - if ((ci) && - (is_cyclic(obj)) && - ((lref = peek_shared_ref(ci, obj)) != 0)) - { - if (lref < 0) lref = -lref; - if ((ci->defined[lref]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - return; - } - if ((let_outlet(obj) != sc->nil) && - (let_outlet(obj) != sc->rootlet)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - let_to_port(sc, let_outlet(obj), ci->cycle_port, use_write, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - } - if (is_openlet(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - /* not immutable here because we'll need to set the let fields below, then declare it immutable */ - if (let_has_setter(obj)) /* both explicit setters and immutable slots */ - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (is_openlet(obj)) - port_write_character(port)(sc, ')', port); - } - else - { - if (is_openlet(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - if (is_immutable(obj)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - /* this ignores outlet -- but is that a problem? */ - /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ - if (let_has_setter(obj)) - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); - /* perhaps set outlet here?? */ - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - if ((let_outlet(obj) != sc->nil) && - (let_outlet(obj) != sc->rootlet)) - { - int32_t ref; - port_write_string(port)(sc, "(sublet ", 8, port); - if ((ci) && ((ref = peek_shared_ref(ci, let_outlet(obj))) < 0)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - } - else - { - s7_pointer name = let_ref(sc, obj, sc->class_name_symbol); - if (is_symbol(name)) - symbol_to_port(sc, name, port, P_DISPLAY, NULL); - else let_to_port(sc, let_outlet(obj), port, use_write, ci); - }} - else port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (is_immutable(obj)) - port_write_character(port)(sc, ')', port); - if (is_openlet(obj)) - port_write_character(port)(sc, ')', port); - }} - else /* not readable write */ - { - s7_pointer slot = let_slots(obj); - port_write_string(port)(sc, "(inlet", 6, port); - for (int32_t i = 1; tis_slot(slot); i++, slot = next_slot(slot)) - { - port_write_character(port)(sc, ' ', port); - slot_to_port(sc, slot, port, use_write, ci); - if ((tis_slot(next_slot(slot))) && (i == sc->print_length)) - { - port_write_string(port)(sc, " ...", 4, port); - break; - }} - port_write_character(port)(sc, ')', port); - } -} - -static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - s7_pointer expr, body = closure_body(obj), arglist = closure_args(obj); - /* this doesn't handle recursive macros well -- we need letrec or the equivalent as in write_closure_readably */ - /* (letrec ((m2 (macro (x) `(if (> ,x 0) (m2 (- ,x 1)) 32)))) (object->string m2 :readable)) */ - - port_write_string(port)(sc, (is_either_macro(obj)) ? "(macro" : "(bacro", 6, port); - if ((is_macro_star(obj)) || (is_bacro_star(obj))) - port_write_character(port)(sc, '*', port); - if (is_symbol(arglist)) - { - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, symbol_name(arglist), symbol_name_length(arglist), port); - port_write_character(port)(sc, ' ', port); - } - else - if (is_pair(arglist)) - { - port_write_string(port)(sc, " (", 2, port); - for (expr = arglist; is_pair(expr); expr = cdr(expr)) - { - object_to_port(sc, car(expr), port, P_WRITE, NULL); - if (is_pair(cdr(expr))) - port_write_character(port)(sc, ' ', port); - } - if (!is_null(expr)) - { - port_write_string(port)(sc, " . ", 3, port); - object_to_port(sc, expr, port, P_WRITE, NULL); - } - port_write_string(port)(sc, ") ", 2, port); - } - else port_write_string(port)(sc, " () ", 4, port); - - for (expr = body; is_pair(expr); expr = cdr(expr)) - object_to_port(sc, car(expr), port, P_WRITE, NULL); - port_write_character(port)(sc, ')', port); -} - - -static s7_pointer match_symbol(const s7_pointer symbol, s7_pointer e) -{ - for (s7_pointer le = e; is_let(le); le = let_outlet(le)) - for (s7_pointer y = let_slots(le); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - return(NULL); -} - -static bool slot_memq(const s7_pointer symbol, s7_pointer symbols) -{ - for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) - if (slot_symbol(car(x)) == symbol) - return(true); - return(false); -} - -static bool arg_memq(const s7_pointer symbol, s7_pointer args) -{ - for (s7_pointer x = args; is_pair(x); x = cdr(x)) - if ((car(x) == symbol) || - ((is_pair(car(x))) && - (caar(x) == symbol))) - return(true); - return(false); -} - -static void collect_symbol(s7_scheme *sc, s7_pointer sym, s7_pointer e, s7_pointer args, s7_int gc_loc) -{ - if ((!arg_memq(T_Sym(sym), args)) && - (!slot_memq(sym, gc_protected_at(sc, gc_loc)))) - { - s7_pointer slot = match_symbol(sym, e); - if (slot) - gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc)); - } -} - -static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer e, s7_pointer args, s7_int gc_loc) /* currently called only in write_closure_readably */ -{ - if (is_pair(body)) - { - collect_locals(sc, car(body), e, args, gc_loc); - collect_locals(sc, cdr(body), e, args, gc_loc); - } - else - if (is_symbol(body)) - collect_symbol(sc, body, e, args, gc_loc); -} - -static void collect_specials(s7_scheme *sc, s7_pointer e, s7_pointer args, s7_int gc_loc) -{ - collect_symbol(sc, sc->local_signature_symbol, e, args, gc_loc); - collect_symbol(sc, sc->local_setter_symbol, e, args, gc_loc); - collect_symbol(sc, sc->local_documentation_symbol, e, args, gc_loc); - collect_symbol(sc, sc->local_iterator_symbol, e, args, gc_loc); -} - -static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let) -{ - for (s7_pointer e = current_let; is_let(e); e = let_outlet(e)) - { - if ((is_funclet(e)) || (is_maclet(e))) - { - s7_pointer sym = funclet_function(e); - s7_pointer f = s7_symbol_local_value(sc, sym, e); - if (f == closure) - return(sym); - } - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_value(y) == closure) - return(slot_symbol(y)); - } - if ((is_any_macro(closure)) && /* can't be a c_macro here */ - (has_pair_macro(closure))) /* maybe macro never called, so no maclet exists */ - return(pair_macro(closure_body(closure))); - return(sc->nil); -} - -static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer port) -{ - s7_pointer x = find_closure(sc, closure, closure_let(closure)); - if (is_symbol(x)) - { - port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port); - return; - } - switch (type(closure)) - { - case T_CLOSURE: port_write_string(port)(sc, "#", 3, port); - else - { - s7_pointer args = closure_args(closure); - if (is_symbol(args)) - { - port_write_string(port)(sc, symbol_name(args), symbol_name_length(args), port); - port_write_character(port)(sc, '>', port); /* (lambda a a) -> # */ - } - else - { - port_write_character(port)(sc, '(', port); - x = car(args); - if (is_pair(x)) x = car(x); - port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port); - if (!is_null(cdr(args))) - { - s7_pointer y; - port_write_character(port)(sc, ' ', port); - if (is_pair(cdr(args))) - { - y = cadr(args); - if (is_pair(y)) - y = car(y); - else - if (y == sc->rest_keyword) - { - port_write_string(port)(sc, ":rest ", 6, port); - args = cdr(args); - y = cadr(args); - if (is_pair(y)) y = car(y); - }} - else - { - port_write_string(port)(sc, ". ", 2, port); - y = cdr(args); - } - port_write_string(port)(sc, symbol_name(y), symbol_name_length(y), port); - if ((is_pair(cdr(args))) && - (!is_null(cddr(args)))) - port_write_string(port)(sc, " ...", 4, port); - } - port_write_string(port)(sc, ")>", 2, port); - }} -} - -static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure) -{ - /* this is used by the error handlers to get the current function name */ - s7_pointer x = find_closure(sc, closure, sc->curlet); - if (is_symbol(x)) - return(x); - if (is_pair(current_code(sc))) - return(current_code(sc)); - return(closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */ -} - -static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - s7_pointer p = cdr(a), tp; - gc_protect_via_stack(sc, b); - if (is_null(p)) - tp = cons(sc, car(a), b); - else - { - s7_pointer np; - tp = list_1(sc, car(a)); - set_stack_protected2(sc, tp); - for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, list_1(sc, car(p))); - set_cdr(np, b); - } - unstack(sc); - return(tp); -} - -static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer arglist, s7_pointer body, s7_pointer port) -{ - s7_int old_print_length = sc->print_length; - - if (type(obj) == T_CLOSURE_STAR) - port_write_string(port)(sc, "(lambda* ", 9, port); - else port_write_string(port)(sc, "(lambda ", 8, port); - - if ((is_pair(arglist)) && - (allows_other_keys(arglist))) - { - sc->temp9 = (is_null(cdr(arglist))) ? - set_plist_2(sc, car(arglist), sc->allow_other_keys_keyword) : - pair_append(sc, arglist, list_1(sc, sc->allow_other_keys_keyword)); - object_to_port(sc, sc->temp9, port, P_WRITE, NULL); - sc->temp9 = sc->unused; - } - else object_to_port(sc, arglist, port, P_WRITE, NULL); /* here we just want the straight output (a b) not (list 'a 'b) */ - - sc->print_length = 1048576; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - { - port_write_character(port)(sc, ' ', port); - object_to_port(sc, car(p), port, P_WRITE, NULL); - } - port_write_character(port)(sc, ')', port); - sc->print_length = old_print_length; -} - -static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) -{ - s7_pointer body = closure_body(obj); - s7_pointer arglist = closure_args(obj); - s7_pointer pe, local_slots, setter = NULL, obj_slot = NULL; - s7_int gc_loc; - bool sent_let = false, sent_letrec = false; - - if (sc->safety > NO_SAFETY) - { - if (tree_is_cyclic(sc, body)) - { - port_write_string(port)(sc, "#", 32, port); /* not s7_error here! */ - return; - } - /* perhaps: if any sequence in the closure_body is cyclic, complain, but how to check without clobbering ci? - * perhaps pass ci, and use make_shared_info if ci=null else continue_shared_info? - * this can happen only if (apply lambda ... cyclic-seq ...) I think - * long-term we need to include closure_body(obj) in the top object_out make_shared_info - */ - } - if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); - pe = closure_let(obj); - - gc_loc = gc_protect_1(sc, sc->nil); - collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here (and below) */ - collect_specials(sc, pe, arglist, gc_loc); - - if (s7_is_dilambda(obj)) - { - setter = closure_setter(obj); - if (has_closure_let(setter)) /* collect args etc so need the arglist */ - { - arglist = closure_args(setter); - if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); - collect_locals(sc, closure_body(setter), pe, arglist, gc_loc); - }} - - local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */ - if (!is_null(local_slots)) - { - /* if (let|letrec ((f (lambda () f))) (object->string f :readable)), local_slots: ('f f) */ - /* but we can't handle it below because that leads to an infinite loop */ - for (s7_pointer x = local_slots; is_pair(x); x = cdr(x)) - { - s7_pointer slot = car(x); - if ((!is_any_closure(slot_value(slot))) && /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */ - ((!has_structure(slot_value(slot))) || /* see s7test example, vector has closure that refers to vector */ - (slot_symbol(slot) == sc->local_signature_symbol))) - { - if (!sent_let) - { - port_write_string(port)(sc, "(let (", 6, port); - sent_let = true; - } - port_write_character(port)(sc, '(', port); - port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); - port_write_character(port)(sc, ' ', port); - /* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */ - object_to_port(sc, slot_value(slot), port, P_READABLE, NULL); - if (is_null(cdr(x))) - port_write_character(port)(sc, ')', port); - else port_write_string(port)(sc, ") ", 2, port); - }} - if (sent_let) port_write_string(port)(sc, ") ", 2, port); - } - - /* now we need to know if obj is in the closure_let via letrec, and if so, send out letrec+obj name+def below, then close it with obj-name?? - * the two cases are: (let ((f (lambda () f)))...) which is ok now, and (letrec ((f (lambda () f)))...) which needs the letrec - */ - if (!is_null(local_slots)) - for (s7_pointer x = local_slots; is_pair(x); x = cdr(x)) - { - s7_pointer slot = car(x); - if ((is_any_closure(slot_value(slot))) && - (slot_value(slot) == obj)) - { - port_write_string(port)(sc, "(letrec ((", 10, port); /* (letrec ((f (lambda () f))) f) */ - sent_letrec = true; - port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); - port_write_character(port)(sc, ' ', port); - obj_slot = slot; - break; - }} - - if (setter) - port_write_string(port)(sc, "(dilambda ", 10, port); - - write_closure_readably_1(sc, obj, closure_args(obj), body, port); - - if (setter) - { - port_write_character(port)(sc, ' ', port); - if (has_closure_let(setter)) - write_closure_readably_1(sc, setter, closure_args(setter), closure_body(setter), port); - else object_to_port_with_circle_check(sc, setter, port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); - } - if (sent_letrec) - { - port_write_string(port)(sc, ")) ", 3, port); - port_write_string(port)(sc, symbol_name(slot_symbol(obj_slot)), symbol_name_length(slot_symbol(obj_slot)), port); - port_write_character(port)(sc, ')', port); - } - - if (sent_let) - port_write_character(port)(sc, ')', port); - - s7_gc_unprotect_at(sc, gc_loc); -} - -static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - if (use_write == P_READABLE) - { - if (iterator_is_at_end(obj)) - { - switch (type(iterator_sequence(obj))) - { - case T_NIL: - case T_PAIR: port_write_string(port)(sc, "(make-iterator ())", 18, port); break; - case T_STRING: port_write_string(port)(sc, "(make-iterator \"\")", 18, port); break; - case T_BYTE_VECTOR: port_write_string(port)(sc, "(make-iterator #u())", 20, port); break; - case T_VECTOR: port_write_string(port)(sc, "(make-iterator #())", 19, port); break; - case T_INT_VECTOR: port_write_string(port)(sc, "(make-iterator #i())", 20, port); break; - case T_FLOAT_VECTOR: port_write_string(port)(sc, "(make-iterator #r())", 20, port); break; - case T_LET: port_write_string(port)(sc, "(make-iterator (inlet))", 23, port); break; - - case T_HASH_TABLE: - if (is_weak_hash_table(iterator_sequence(obj))) - port_write_string(port)(sc, "(make-iterator (weak-hash-table))", 33, port); - else port_write_string(port)(sc, "(make-iterator (hash-table))", 28, port); - break; - - default: - port_write_string(port)(sc, "(make-iterator ())", 18, port); break; /* c-object?? function? */ - }} - else - { - s7_pointer seq = iterator_sequence(obj); - int32_t iter_ref; - if ((ci) && - (is_cyclic(obj)) && - ((iter_ref = peek_shared_ref(ci, obj)) != 0)) - { - /* basically the same as c_pointer_to_port */ - if (!is_cyclic_set(obj)) - { - int32_t nlen; - char buf[128]; - if (iter_ref < 0) iter_ref = -iter_ref; - - if (ci->init_port == sc->F) - { - ci->init_port = s7_open_output_string(sc); - ci->init_loc = gc_protect_1(sc, ci->init_port); - } - port_write_string(port)(sc, "#f", 2, port); - nlen = catstrs_direct(buf, " (set! <", pos_int_to_str_direct(sc, iter_ref), "> (make-iterator ", (const char *)NULL); - port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); - - flip_ref(ci, seq); - object_to_port_with_circle_check(sc, seq, ci->init_port, use_write, ci); - flip_ref(ci, seq); - - port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); - set_cyclic_set(obj); - return; - }} - - if (is_string(seq)) - { - s7_int len = string_length(seq) - iterator_position(obj); - if (len == 0) - port_write_string(port)(sc, "(make-iterator \"\")", 18, port); - else - { - const char *iter_str = (const char *)(string_value(seq) + iterator_position(obj)); - port_write_string(port)(sc, "(make-iterator \"", 16, port); - if (!string_needs_slashification((const uint8_t *)iter_str, len)) - port_write_string(port)(sc, iter_str, len, port); - else slashify_string_to_port(sc, port, iter_str, len, NOT_IN_QUOTES); - port_write_string(port)(sc, "\")", 2, port); - }} - else - { - if (is_pair(seq)) - { - port_write_string(port)(sc, "(make-iterator ", 15, port); - object_to_port_with_circle_check(sc, iterator_current(obj), port, use_write, ci); - port_write_character(port)(sc, ')', port); - } - else - { - if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->s7_starlet)) - { - port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); - object_to_port_with_circle_check(sc, seq, port, use_write, ci); - port_write_string(port)(sc, "))) ", 4, port); - for (s7_pointer slot = let_slots(seq); slot != iterator_current_slot(obj); slot = next_slot(slot)) - port_write_string(port)(sc, "(iter) ", 7, port); - port_write_string(port)(sc, "iter)", 5, port); - } - else - { - if (iterator_position(obj) > 0) - port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); - else port_write_string(port)(sc, "(make-iterator ", 15, port); - object_to_port_with_circle_check(sc, seq, port, use_write, ci); - if (iterator_position(obj) > 0) - { - if (iterator_position(obj) == 1) - port_write_string(port)(sc, "))) (iter) iter)", 16, port); - else - { - char str[128]; - int32_t nlen = catstrs_direct(str, "))) (do ((i 0 (+ i 1))) ((= i ", - pos_int_to_str_direct(sc, iterator_position(obj)), - ") iter) (iter)))", (const char *)NULL); - port_write_string(port)(sc, str, nlen, port); - }} - else port_write_character(port)(sc, ')', port); - }}}}} - else - { - const char *str; - if ((is_hash_table(iterator_sequence(obj))) && (is_weak_hash_table(iterator_sequence(obj)))) - str = "weak-hash-table"; - else str = type_name(sc, iterator_sequence(obj), NO_ARTICLE); - port_write_string(port)(sc, "#', port); - } -} - -static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - #define CP_BUFSIZE 128 - char buf[CP_BUFSIZE]; - int32_t nlen; - /* c-pointer is special because we can't set the type or info fields from scheme except via the c-pointer function */ - - if (use_write == P_READABLE) - { - int32_t ref; - if ((ci) && - (is_cyclic(obj)) && - ((ref = peek_shared_ref(ci, obj)) != 0)) - { - port_write_string(port)(sc, "#f", 2, port); - if (!is_cyclic_set(obj)) - { - if (ci->init_port == sc->F) - { - ci->init_port = s7_open_output_string(sc); - ci->init_loc = gc_protect_1(sc, ci->init_port); - } - nlen = snprintf(buf, CP_BUFSIZE, " (set! <%d> (c-pointer %" p64, -ref, (intptr_t)c_pointer(obj)); - port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); - - if ((c_pointer_type(obj) != sc->F) || - (c_pointer_info(obj) != sc->F)) - { - flip_ref(ci, c_pointer_type(obj)); - - port_write_character(ci->init_port)(sc, ' ', ci->init_port); - object_to_port_with_circle_check(sc, c_pointer_type(obj), ci->init_port, use_write, ci); - - flip_ref(ci, c_pointer_type(obj)); - flip_ref(ci, c_pointer_info(obj)); - - port_write_character(ci->init_port)(sc, ' ', ci->init_port); - object_to_port_with_circle_check(sc, c_pointer_info(obj), ci->init_port, use_write, ci); - - flip_ref(ci, c_pointer_info(obj)); - } - port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); - set_cyclic_set(obj); - }} - else - { - nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(obj)); - port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); - if ((c_pointer_type(obj) != sc->F) || - (c_pointer_info(obj) != sc->F)) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, c_pointer_type(obj), port, use_write, ci); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, c_pointer_info(obj), port, use_write, ci); - } - port_write_character(port)(sc, ')', port); - }} - else - { - if ((is_symbol(c_pointer_type(obj))) && - (symbol_name_length(c_pointer_type(obj)) < (CP_BUFSIZE / 2))) - nlen = snprintf(buf, CP_BUFSIZE, "#<%s %p>", symbol_name(c_pointer_type(obj)), c_pointer(obj)); - else nlen = snprintf(buf, CP_BUFSIZE, "#", c_pointer(obj)); - port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); - } -} - -static void random_state_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - #define B_BUFSIZE 128 - char buf[B_BUFSIZE]; - int32_t nlen; -#if WITH_GMP - if (use_write == P_READABLE) - nlen = snprintf(buf, B_BUFSIZE, "#"); - else nlen = snprintf(buf, B_BUFSIZE, "#", obj); -#else - if (use_write == P_READABLE) - nlen = snprintf(buf, B_BUFSIZE, "(random-state %" PRIu64 " %" PRIu64 ")", random_seed(obj), random_carry(obj)); - else nlen = snprintf(buf, B_BUFSIZE, "#", random_seed(obj), random_carry(obj)); -#endif - port_write_string(port)(sc, buf, clamp_length(nlen, B_BUFSIZE), port); -} - -static void display_fallback(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ -#if S7_DEBUGGING - print_debugging_state(sc, obj, port); -#else - if (is_free(obj)) - port_write_string(port)(sc, "", 12, port); - else port_write_string(port)(sc, "", 17, port); -#endif -} - -static void unique_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port); -} - -static void undefined_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if ((obj != sc->undefined) && - (use_write == P_READABLE)) - { - port_write_string(port)(sc, "(with-input-from-string \"", 25, port); - port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port); - port_write_string(port)(sc, "\" read)", 7, port); - } - else port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port); -} - -static void eof_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (use_write == P_READABLE) - port_write_string(port)(sc, "(begin #)", 14, port); - else port_write_string(port)(sc, eof_name(obj), eof_name_length(obj), port); -} - -static void counter_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_write_string(port)(sc, "#", 10, port); -} - -static void integer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (has_number_name(obj)) - { - if (is_string_port(port)) - { - if (port_position(port) + number_name_length(obj) < port_data_size(port)) - { - memcpy((void *)(port_data(port) + port_position(port)), (void *)number_name(obj), number_name_length(obj)); - port_position(port) += number_name_length(obj); - } - else string_write_string_resized(sc, number_name(obj), number_name_length(obj), port); - } - else port_write_string(port)(sc, number_name(obj), number_name_length(obj), port); - } - else - { - s7_int nlen = 0; - char *str = integer_to_string(sc, integer(obj), &nlen); - set_number_name(obj, str, nlen); - port_write_string(port)(sc, str, nlen, port); - } -} - -static void number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (has_number_name(obj)) - port_write_string(port)(sc, number_name(obj), number_name_length(obj), port); - else - { - s7_int nlen = 0; - char *str = number_to_string_base_10(sc, obj, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */ - if ((nlen < NUMBER_NAME_SIZE) && - (str[0] != 'n') && (str[0] != 'i') && - ((!(is_t_complex(obj))) || - ((!is_NaN(imag_part(obj))) && (!is_inf(imag_part(obj)))))) - set_number_name(obj, str, nlen); - port_write_string(port)(sc, str, nlen, port); - } -} - -#if WITH_GMP -static void big_number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_int nlen = 0; - block_t *str = big_number_to_string_with_radix(sc, obj, BASE_10, 0, &nlen, use_write); - port_write_string(port)(sc, (char *)block_data(str), nlen, port); - liberate(sc, str); -} -#endif - -static void syntax_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_display(port)(sc, symbol_name(syntax_symbol(obj)), port); -} - -static void character_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (use_write == P_DISPLAY) - port_write_character(port)(sc, character(obj), port); - else port_write_string(port)(sc, character_name(obj), character_name_length(obj), port); -} - -static void closure_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - if (has_active_methods(sc, obj)) - { - /* look for object->string method else fallback on ordinary case. - * can't use recursion on closure_let here because then the fallback name is #. - * this is tricky!: (display (openlet (with-let (mock-c-pointer 0) (lambda () 1)))) - * calls object->string on the closure whose closure_let is the mock-c-pointer; - * it has an object->string method that clears mock-c-pointers and tries again... - * so, display methods need to use coverlet/openlet. - */ - s7_pointer print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol); - if (print_func != sc->undefined) - { - s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - if (string_length(p) > 0) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} - if (use_write == P_READABLE) - write_closure_readably(sc, obj, port, ci); - else write_closure_name(sc, obj, port); -} - -static void macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (has_active_methods(sc, obj)) - { - s7_pointer print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol); - if (print_func != sc->undefined) - { - s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - if (string_length(p) > 0) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} - if (use_write == P_READABLE) - write_macro_readably(sc, obj, port); - else write_closure_name(sc, obj, port); -} - -static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_pointer sym = c_function_name_to_symbol(sc, obj); - if ((!is_global(sym)) && - (is_slot(initial_slot(sym))) && - ((use_write == P_READABLE) || (lookup(sc, sym) != initial_value(sym)))) - { - port_write_string(port)(sc, "#_", 2, port); - port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); - return; - } - if (c_function_name_length(obj) > 0) - port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); - else port_write_string(port)(sc, "#", 13, port); -} - -static void c_macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (c_macro_name_length(obj) > 0) - port_write_string(port)(sc, c_macro_name(obj), c_macro_name_length(obj), port); - else port_write_string(port)(sc, "#", 10, port); -} - -static void continuation_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (is_symbol(continuation_name(obj))) - { - port_write_string(port)(sc, "#', port); - } - else port_write_string(port)(sc, "#", 15, port); -} - -static void goto_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (is_symbol(call_exit_name(obj))) - { - port_write_string(port)(sc, "#', port); - } - else port_write_string(port)(sc, "#", 7, port); -} - -static void catch_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_write_string(port)(sc, "#", 8, port); -} - -static void dynamic_wind_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */ - port_write_string(port)(sc, "#", 15, port); -} - -static void c_object_name_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - port_write_string(port)(sc, string_value(c_object_scheme_name(sc, obj)), string_length(c_object_scheme_name(sc, obj)), port); -} - -static void c_object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ -#if (!DISABLE_DEPRECATED) - if (c_object_print(sc, obj)) - { - char *str = ((*(c_object_print(sc, obj)))(sc, c_object_value(obj))); - port_display(port)(sc, str, port); - free(str); - return; - } -#endif - if (c_object_to_string(sc, obj)) /* plist here and below can clobber args if SHOW_EVAL_ARGS */ - port_display(port)(sc, s7_string((*(c_object_to_string(sc, obj)))(sc, set_mlist_2(sc, obj, (use_write == P_READABLE) ? sc->readable_keyword : sc->T))), port); - else - { - if ((use_write == P_READABLE) && - (c_object_to_list(sc, obj)) && /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */ - (c_object_set(sc, obj))) - { - int32_t href; - s7_pointer old_w = sc->w; - s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj))); - s7_pointer p = obj_list; - sc->w = obj_list; - if ((ci) && - (is_cyclic(obj)) && - ((href = peek_shared_ref(ci, obj)) != 0)) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - return; - } - port_write_character(port)(sc, '(', port); - c_object_name_to_port(sc, obj, port); - for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) - { - s7_pointer val = car(p); - if (has_structure(val)) - { - char buf[128]; - int32_t symref; - int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", pos_int_to_str_direct_1(sc, i), ") ", (const char *)NULL); - port_write_string(port)(sc, " #f", 3, port); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - - symref = peek_shared_ref(ci, val); - if (symref != 0) - { - if (symref < 0) symref = -symref; - len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, symref), ">)\n", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - } - else - { - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - }}} - else - { - port_write_character(port)(sc, '(', port); - c_object_name_to_port(sc, obj, port); - for (p = obj_list; is_pair(p); p = cdr(p)) - { - s7_pointer val = car(p); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - }} - port_write_character(port)(sc, ')', port); - sc->w = old_w; - } - else - { - char buf[128]; - int32_t nlen; - port_write_string(port)(sc, "#<", 2, port); - c_object_name_to_port(sc, obj, port); - nlen = snprintf(buf, 128, " %p>", obj); - port_write_string(port)(sc, buf, clamp_length(nlen, 128), port); - }} -} - -static void stack_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (obj == sc->stack) - port_write_string(port)(sc, "#", 16, port); - else port_write_string(port)(sc, "#", 8, port); -} - -static void init_display_functions(void) -{ - for (int32_t i = 0; i < 256; i++) display_functions[i] = display_fallback; - display_functions[T_FLOAT_VECTOR] = float_vector_to_port; - display_functions[T_INT_VECTOR] = int_vector_to_port; - display_functions[T_BYTE_VECTOR] = byte_vector_to_port; - display_functions[T_VECTOR] = vector_to_port; - display_functions[T_PAIR] = pair_to_port; - display_functions[T_HASH_TABLE] = hash_table_to_port; - display_functions[T_ITERATOR] = iterator_to_port; - display_functions[T_LET] = let_to_port; - display_functions[T_BOOLEAN] = unique_to_port; - display_functions[T_NIL] = unique_to_port; - display_functions[T_UNUSED] = unique_to_port; - display_functions[T_UNSPECIFIED] = unique_to_port; - display_functions[T_UNDEFINED] = undefined_to_port; - display_functions[T_EOF] = eof_to_port; - display_functions[T_INPUT_PORT] = input_port_to_port; - display_functions[T_OUTPUT_PORT] = output_port_to_port; - display_functions[T_COUNTER] = counter_to_port; - display_functions[T_STACK] = stack_to_port; - display_functions[T_INTEGER] = integer_to_port; - display_functions[T_RATIO] = number_to_port; - display_functions[T_REAL] = number_to_port; - display_functions[T_COMPLEX] = number_to_port; -#if WITH_GMP - display_functions[T_BIG_INTEGER] = big_number_to_port; - display_functions[T_BIG_RATIO] = big_number_to_port; - display_functions[T_BIG_REAL] = big_number_to_port; - display_functions[T_BIG_COMPLEX] = big_number_to_port; -#endif - display_functions[T_SYMBOL] = symbol_to_port; - display_functions[T_SYNTAX] = syntax_to_port; - display_functions[T_STRING] = string_to_port; - display_functions[T_CHARACTER] = character_to_port; - display_functions[T_CLOSURE] = closure_to_port; - display_functions[T_CLOSURE_STAR] = closure_to_port; - display_functions[T_MACRO] = macro_to_port; - display_functions[T_MACRO_STAR] = macro_to_port; - display_functions[T_BACRO] = macro_to_port; - display_functions[T_BACRO_STAR] = macro_to_port; - display_functions[T_C_RST_NO_REQ_FUNCTION] = c_function_to_port; - display_functions[T_C_FUNCTION] = c_function_to_port; - display_functions[T_C_FUNCTION_STAR] = c_function_to_port; - display_functions[T_C_MACRO] = c_macro_to_port; - display_functions[T_C_POINTER] = c_pointer_to_port; - display_functions[T_RANDOM_STATE] = random_state_to_port; - display_functions[T_CONTINUATION] = continuation_to_port; - display_functions[T_GOTO] = goto_to_port; - display_functions[T_CATCH] = catch_to_port; - display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port; - display_functions[T_C_OBJECT] = c_object_to_port; - display_functions[T_SLOT] = slot_to_port; -} - -static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - int32_t ref = (is_collected(vr)) ? shared_ref(ci, vr) : 0; - if (ref == 0) - object_to_port(sc, vr, port, use_write, ci); - else - { - char buf[32]; - int32_t nlen; - if (ref > 0) - { - if (use_write == P_READABLE) - { - if (ci->defined[ref]) - { - flip_ref(ci, vr); - nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - return; - } - object_to_port(sc, vr, port, P_READABLE, ci); - } - else - { /* "normal" printout involving #n= and #n# */ - s7_int len = 0; - char *p = pos_int_to_str(sc, (s7_int)ref, &len, '='); - *--p = '#'; - port_write_string(port)(sc, p, len, port); - object_to_port(sc, vr, port, NOT_P_DISPLAY(use_write), ci); - }} - else - if (use_write == P_READABLE) - { - nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - } - else - { - s7_int len = 0; - char *p = pos_int_to_str(sc, (s7_int)(-ref), &len, '#'); - *--p = '#'; - port_write_string(port)(sc, p, len, port); - }} -} - -static s7_pointer cyclic_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) -{ - int32_t ref, len; - char buf[128]; - - ci->cycle_port = s7_open_output_string(sc); - ci->cycle_loc = gc_protect_1(sc, ci->cycle_port); - - port_write_string(port)(sc, "(let (", 6, port); - for (int32_t i = 0; i < ci->top; i++) - { - ref = peek_shared_ref(ci, ci->objs[i]); /* refs may be in any order */ - if (ref < 0) {ref = -ref; flip_ref(ci, ci->objs[i]);} - len = catstrs_direct(buf, (i == 0) ? "(<" : "\n (<", pos_int_to_str_direct(sc, ref), "> ", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - ci->defined[ref] = false; - object_to_port_with_circle_check(sc, ci->objs[i], port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); - ci->defined[ref] = true; - if (peek_shared_ref(ci, ci->objs[i]) > 0) flip_ref(ci, ci->objs[i]); /* ref < 0 -> use <%d> in object_to_port */ - } - port_write_string(port)(sc, ")\n", 2, port); - - if (ci->init_port != sc->F) - { - port_write_string(port)(sc, (const char *)(port_data(ci->init_port)), port_position(ci->init_port), port); - s7_close_output_port(sc, ci->init_port); - s7_gc_unprotect_at(sc, ci->init_loc); - ci->init_port = sc->F; - } - - if (port_position(ci->cycle_port) > 0) /* 0 if e.g. (object->string (object->let (rootlet)) :readable) */ - port_write_string(port)(sc, (const char *)(port_data(ci->cycle_port)), port_position(ci->cycle_port), port); - s7_close_output_port(sc, ci->cycle_port); - s7_gc_unprotect_at(sc, ci->cycle_loc); - ci->cycle_port = sc->F; - - if ((is_immutable(obj)) && (!is_let(obj))) - port_write_string(port)(sc, " (immutable! ", 14, port); - else port_write_string(port)(sc, " ", 2, port); - - ref = peek_shared_ref(ci, obj); - if (ref == 0) - object_to_port_with_circle_check(sc, obj, port, P_READABLE, ci); - else - { - len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, (ref < 0) ? -ref : ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - } - - if ((is_immutable(obj)) && (!is_let(obj))) - port_write_string(port)(sc, "))\n", 3, port); - else port_write_string(port)(sc, ")\n", 2, port); - return(obj); -} - -static void object_out_1(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice) -{ - if (sc->object_out_locked) - object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, sc->circle_info); - else - { - shared_info_t *ci = make_shared_info(sc, T_Pos(obj), choice != P_READABLE); - if (ci) - { - sc->object_out_locked = true; - if (choice == P_READABLE) - cyclic_out(sc, obj, strport, ci); - else object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, ci); - sc->object_out_locked = false; - } - else object_to_port(sc, obj, strport, choice, NULL); - } -} - -static inline s7_pointer object_out(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice) -{ - if ((has_structure(obj)) && - (obj != sc->rootlet)) - object_out_1(sc, obj, strport, choice); - else object_to_port(sc, obj, strport, choice, NULL); - return(obj); -} - -static s7_pointer new_format_port(s7_scheme *sc) -{ - s7_pointer x = alloc_pointer(sc); - s7_int len = FORMAT_PORT_LENGTH; - block_t *block, *b; - set_full_type(x, T_OUTPUT_PORT); - b = mallocate_port(sc); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = STRING_PORT; - port_set_closed(x, false); - port_data_size(x) = len; - port_next(x) = NULL; - block = mallocate(sc, len); - port_data(x) = (uint8_t *)(block_data(block)); - port_data_block(x) = block; - port_data(x)[0] = '\0'; - port_position(x) = 0; - port_needs_free(x) = false; - port_port(x)->pf = &output_string_functions; - return(x); -} - -static inline s7_pointer open_format_port(s7_scheme *sc) -{ - s7_pointer x = sc->format_ports; - if (!x) return(new_format_port(sc)); - sc->format_ports = (s7_pointer)(port_next(x)); - port_position(x) = 0; - port_data(x)[0] = '\0'; - return(x); -} - -static void close_format_port(s7_scheme *sc, s7_pointer port) -{ - port_next(port) = (struct block_t *)(sc->format_ports); - sc->format_ports = port; -} - -char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj) -{ - char *str; - s7_pointer strport; - s7_int len; - - TRACK(sc); - if ((sc->safety > NO_SAFETY) && - (!s7_is_valid(sc, obj))) - s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); - - strport = open_format_port(sc); - object_out(sc, T_Pos(obj), strport, P_WRITE); - len = port_position(strport); - if ((S7_DEBUGGING) && (len == 0)) fprintf(stderr, "%s[%d]: len == 0\n", __func__, __LINE__); - /* if (len == 0) {close_format_port(sc, strport); return(NULL);} */ /* probably never happens */ - str = (char *)Malloc(len + 1); - memcpy((void *)str, (void *)port_data(strport), len); - str[len] = '\0'; - close_format_port(sc, strport); - return(str); -} - -static inline void restore_format_port(s7_scheme *sc, s7_pointer strport) -{ - block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); - port_data(strport) = (uint8_t *)(block_data(block)); - port_data_block(strport) = block; - port_data(strport)[0] = '\0'; - port_position(strport) = 0; - port_data_size(strport) = FORMAT_PORT_LENGTH; - port_needs_free(strport) = false; - close_format_port(sc, strport); -} - - -/* -------------------------------- object->string -------------------------------- */ -s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */ -{ - s7_pointer strport, res; - - if ((sc->safety > NO_SAFETY) && - (!s7_is_valid(sc, obj))) - s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); - - strport = open_format_port(sc); - object_out(sc, obj, strport, (use_write) ? P_WRITE : P_DISPLAY); - - if (port_position(strport) >= port_data_size(strport)) - res = block_to_string(sc, reallocate(sc, port_data_block(strport), port_position(strport) + 1), port_position(strport)); - else res = block_to_string(sc, port_data_block(strport), port_position(strport)); - restore_format_port(sc, strport); - return(res); -} - -static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_object_to_string "(object->string obj (write #t) (max-len (*s7* 'most-positive-fixnum))) returns a string representation of obj." - #define Q_object_to_string s7_make_signature(sc, 4, \ - sc->is_string_symbol, sc->T, \ - s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol), sc->is_integer_symbol) - use_write_t choice; - s7_pointer obj = car(args), strport, res; - s7_int out_len, pending_max = S7_INT64_MAX; - bool old_openlets = sc->has_openlets; - - if (is_not_null(cdr(args))) - { - s7_pointer arg = cadr(args); - if (arg == sc->F) choice = P_DISPLAY; - else {if (arg == sc->T) choice = P_WRITE; - else {if (arg == sc->readable_keyword) choice = P_READABLE; - else {if (arg == sc->display_keyword) choice = P_DISPLAY; - else {if (arg == sc->write_keyword) choice = P_WRITE; - else wrong_type_error_nr(sc, sc->object_to_string_symbol, 2, arg, wrap_string(sc, "a boolean or :readable", 22));}}}} - - if (is_not_null(cddr(args))) - { - arg = caddr(args); - if (!s7_is_integer(arg)) - { - if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable "hi") */ - wrong_type_error_nr(sc, sc->object_to_string_symbol, 3, arg, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, arg, sc->object_to_string_symbol, args, sc->type_names[T_INTEGER], 3)); - } - if (s7_integer_clamped_if_gmp(sc, arg) < 0) - out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, arg, a_non_negative_integer_string); - pending_max = s7_integer_clamped_if_gmp(sc, arg); - }} - else choice = P_WRITE; - /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */ - - if (choice == P_READABLE) - sc->has_openlets = false; /* so (object->string obj :readable) ignores obj's object->string method -- is this a good idea? */ - else check_method(sc, obj, sc->object_to_string_symbol, args); - - strport = open_format_port(sc); - sc->objstr_max_len = pending_max; - object_out(sc, obj, strport, choice); - sc->objstr_max_len = S7_INT64_MAX; - out_len = port_position(strport); - - if ((pending_max >= 0) && - (out_len > pending_max)) - { - if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable 4) */ - { - close_format_port(sc, strport); - sc->has_openlets = old_openlets; - out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, wrap_integer(sc, out_len), wrap_string(sc, "the readable string is too long", 31)); - } - out_len = pending_max; - if (out_len < 3) - { - close_format_port(sc, strport); - sc->has_openlets = old_openlets; - return(make_string_with_length(sc, "...", 3)); - } - for (s7_int i = out_len - 3; i < out_len; i++) - port_data(strport)[i] = (uint8_t)'.'; - } - if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */ - res = block_to_string(sc, reallocate(sc, port_data_block(strport), out_len + 1), out_len); - else res = block_to_string(sc, port_data_block(strport), out_len); - restore_format_port(sc, strport); - sc->has_openlets = old_openlets; - return(res); -} - -#if S7_DEBUGGING -const char *s7_object_to_c_string_x(s7_scheme *sc, s7_pointer obj, s7_pointer urchoice) {return(string_value(g_object_to_string(sc, list_2(sc, obj, urchoice))));} -#endif - - -/* -------------------------------- newline -------------------------------- */ -void s7_newline(s7_scheme *sc, s7_pointer port) -{ - if (port != sc->F) - port_write_character(port)(sc, (uint8_t)'\n', port); -} - -#define newline_char chars[(uint8_t)'\n'] - -static s7_pointer g_newline(s7_scheme *sc, s7_pointer args) -{ - #define H_newline "(newline (port (current-output-port))) writes a carriage return to the port" - #define Q_newline s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer port = (is_not_null(args)) ? car(args) : current_output_port(sc); - if (!is_output_port(port)) - { - if (port == sc->F) return(newline_char); - check_method(sc, port, sc->newline_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, an_output_port_or_f_string); /* 0 -> "zeroth" */ - } - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, an_open_output_port_string); - s7_newline(sc, port); - return(newline_char); /* return(sc->unspecified) until 28-Sep-17, but for example (display c) returns c */ -} - -static s7_pointer newline_p(s7_scheme *sc) -{ - s7_newline(sc, current_output_port(sc)); - return(newline_char); -} - -static s7_pointer newline_p_p(s7_scheme *sc, s7_pointer port) -{ - if (!is_output_port(port)) - { - if (port == sc->F) return(newline_char); - return(sole_arg_method_or_bust_p(sc, port, sc->newline_symbol, an_output_port_string)); - } - s7_newline(sc, port); - return(newline_char); -} - - -/* -------------------------------- write -------------------------------- */ -s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - if (port != sc->F) - { - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string); - object_out(sc, obj, port, P_WRITE); - } - return(obj); -} - -static s7_pointer write_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port) -{ - if (!is_output_port(port)) - { - if (port == sc->F) return(x); - check_method(sc, port, sc->write_symbol, set_mlist_2(sc, x, port)); - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string); - return(object_out(sc, x, port, P_WRITE)); -} - -static s7_pointer g_write(s7_scheme *sc, s7_pointer args) -{ - #define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port" - #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - check_method(sc, car(args), sc->write_symbol, args); - return(write_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); -} - -static s7_pointer write_p_p(s7_scheme *sc, s7_pointer x) -{ - return((current_output_port(sc) == sc->F) ? x : object_out(sc, x, current_output_port(sc), P_WRITE)); -} - - -/* -------------------------------- display -------------------------------- */ -s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - if (port != sc->F) - { - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string); - object_out(sc, obj, port, P_DISPLAY); - } - return(obj); -} - -static s7_pointer display_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port) -{ - if (!is_output_port(port)) - { - if (port == sc->F) return(x); - check_method(sc, port, sc->display_symbol, set_mlist_2(sc, x, port)); - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string); - check_method(sc, x, sc->display_symbol, set_plist_2(sc, x, port)); - return(object_out(sc, x, port, P_DISPLAY)); -} - -static s7_pointer g_display(s7_scheme *sc, s7_pointer args) -{ - #define H_display "(display obj (port (current-output-port))) prints obj" - #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(display_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); -} - -static s7_pointer g_display_2(s7_scheme *sc, s7_pointer args) {return(display_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_display_f(s7_scheme *unused_sc, s7_pointer args) {return(car(args));} - -static s7_pointer display_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */ - return((caddr(expr) == sc->F) ? sc->display_f : sc->display_2); - return(f); -} - -static s7_pointer display_p_p(s7_scheme *sc, s7_pointer x) -{ - if (current_output_port(sc) == sc->F) return(x); - check_method(sc, x, sc->display_symbol, set_plist_1(sc, x)); - return(object_out(sc, x, current_output_port(sc), P_DISPLAY)); -} - - -/* -------------------------------- call-with-output-string -------------------------------- */ -static s7_pointer g_call_with_output_string(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output" - #define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer port, proc = car(args); - if (is_let(proc)) - check_method(sc, proc, sc->call_with_output_string_symbol, args); - if ((!is_any_procedure(proc)) || /* this disallows goto/continuation */ - (!s7_is_aritable(sc, proc, 1))) - return(method_or_bust(sc, proc, sc->call_with_output_string_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 1)); - - port = s7_open_output_string(sc); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* # here is a marker (needed) */ - push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); /* args checked in call_with_exit */ - push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc); - return(sc->F); -} - - -/* -------------------------------- call-with-output-file -------------------------------- */ -static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument" - #define Q_call_with_output_file sc->pl_sf - - s7_pointer port, file = car(args), proc = cadr(args); - if (!is_string(file)) - return(method_or_bust(sc, file, sc->call_with_output_file_symbol, args, sc->type_names[T_STRING], 1)); - if ((!is_any_procedure(proc)) || - (!s7_is_aritable(sc, proc, 1))) - return(method_or_bust(sc, proc, sc->call_with_output_file_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 2)); - - port = s7_open_output_file(sc, string_value(file), "w"); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* # here is a marker (needed) */ - push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc); - return(sc->F); -} - - -/* -------------------------------- with-output-to-string -------------------------------- */ -static s7_pointer g_with_output_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, \ -calls thunk, then returns the collected output" - #define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer old_output_port, p = car(args); - if (!is_thunk(sc, p)) - return(method_or_bust(sc, p, sc->with_output_to_string_symbol, args, a_thunk_string, 1)); - if ((is_continuation(p)) || (is_goto(p))) - wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, p, a_normal_procedure_string); - - old_output_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_string(sc)); - push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, current_output_port(sc)); - push_stack(sc, OP_GET_OUTPUT_STRING, old_output_port, current_output_port(sc)); - push_stack(sc, OP_APPLY, sc->nil, p); - return(sc->F); -} - - -/* -------------------------------- with-output-to-file -------------------------------- */ -static s7_pointer g_with_output_to_file(s7_scheme *sc, s7_pointer args) -{ - #define H_with_output_to_file "(with-output-to-file filename thunk) opens filename as the temporary current-output-port and calls thunk" - #define Q_with_output_to_file sc->pl_sf - - s7_pointer old_output_port, file = car(args), proc = cadr(args); - if (!is_string(file)) - return(method_or_bust(sc, file, sc->with_output_to_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_thunk(sc, proc)) - return(method_or_bust(sc, proc, sc->with_output_to_file_symbol, args, a_thunk_string, 2)); - if ((is_continuation(proc)) || (is_goto(proc))) - wrong_type_error_nr(sc, sc->with_output_to_file_symbol, 1, proc, a_normal_procedure_string); - - old_output_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_file(sc, string_value(file), "w")); - push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, current_output_port(sc)); - push_stack(sc, OP_APPLY, sc->nil, proc); - return(sc->F); -} - - -/* -------------------------------- format -------------------------------- */ -static inline s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst); - -static noreturn void format_error_nr(s7_scheme *sc, const char *ur_msg, s7_int msg_len, const char *str, s7_pointer ur_args, format_data_t *fdat) -{ - s7_pointer x = NULL; - s7_pointer ctrl_str = (fdat->orig_str) ? fdat->orig_str : wrap_string(sc, str, safe_strlen(str)); - s7_pointer args = (is_elist(ur_args)) ? copy_proper_list(sc, ur_args) : ur_args; - s7_pointer msg = wrap_string(sc, ur_msg, msg_len); - if (fdat->loc == 0) - { - if (is_pair(args)) - x = set_elist_4(sc, format_string_1, ctrl_str, args, msg); - else x = set_elist_3(sc, format_string_2, ctrl_str, msg); - } - else - if (is_pair(args)) - x = set_elist_5(sc, format_string_3, ctrl_str, args, wrap_integer(sc, fdat->loc + 20), msg); - else x = set_elist_4(sc, format_string_4, ctrl_str, wrap_integer(sc, fdat->loc + 20), msg); - if (fdat->port) - { - close_format_port(sc, fdat->port); - fdat->port = NULL; - } - error_nr(sc, sc->format_error_symbol, x); -} - -static void format_append_char(s7_scheme *sc, char c, s7_pointer port) -{ - port_write_character(port)(sc, c, port); - sc->format_column++; -} - -static void format_append_newline(s7_scheme *sc, s7_pointer port) -{ - port_write_character(port)(sc, '\n', port); - sc->format_column = 0; -} - -static void format_append_string(s7_scheme *sc, format_data_t *fdat, const char *str, s7_int len, s7_pointer port) -{ - port_write_string(port)(sc, str, len, port); - fdat->loc += len; - sc->format_column += len; -} - -static void format_append_chars(s7_scheme *sc, format_data_t *fdat, char pad, s7_int chars, s7_pointer port) -{ - if (is_string_port(port)) - { - if ((port_position(port) + chars) < port_data_size(port)) - { - local_memset((char *)port_data(port) + port_position(port), pad, chars); - port_position(port) += chars; - } - else - { - s7_int new_len = port_position(port) + chars; - resize_port_data(sc, port, new_len * 2); - local_memset((char *)port_data(port) + port_position(port), pad, chars); - port_position(port) = new_len; - } - fdat->loc += chars; - sc->format_column += chars; - } - else - { - block_t *b = mallocate(sc, chars + 1); - char *str = (char *)block_data(b); - local_memset((void *)str, pad, chars); - str[chars] = '\0'; - format_append_string(sc, fdat, str, chars, port); - liberate(sc, b); - } -} - -static s7_int format_read_integer(s7_int *cur_i, s7_int str_len, const char *str) -{ - /* we know that str[*cur_i] is a digit */ - s7_int i, lval = 0; - for (i = *cur_i; i < str_len - 1; i++) - { - int32_t dig = digits[(uint8_t)str[i]]; - if (dig < 10) - { -#if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(lval, 10, &lval)) || - (add_overflow(lval, dig, &lval))) - break; -#else - lval = dig + (lval * 10); -#endif - } - else break; - } - *cur_i = i; - return(lval); -} - -static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_int width, s7_int precision, char float_choice, char pad, s7_pointer port) -{ - char *tmp; - block_t *b = NULL; - s7_int nlen = 0; - if (width < 0) width = 0; - - /* precision choice depends on float_choice if it's -1 */ - if (precision < 0) - { - if ((float_choice == 'e') || - (float_choice == 'f') || - (float_choice == 'g')) - precision = 6; - else - /* in the "int" cases, precision depends on the arg type */ - switch (type(car(fdat->args))) - { - case T_INTEGER: case T_RATIO: - precision = 0; - break; - default: - precision = 6; - break; - }} - /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */ - - if (pad != ' ') - { - char *padtmp; -#if (!WITH_GMP) - if (radix == 10) - tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); - else -#endif - { - b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); - tmp = (char *)block_data(b); - } - padtmp = tmp; - while (*padtmp == ' ') (*(padtmp++)) = pad; - format_append_string(sc, fdat, tmp, nlen, port); - if ((WITH_GMP) || (radix != 10)) liberate(sc, b); - } - else - { -#if (!WITH_GMP) - if (radix == 10) - tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); - else -#endif - { - b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); - tmp = (char *)block_data(b); - } - format_append_string(sc, fdat, tmp, nlen, port); - if ((WITH_GMP) || (radix != 10)) liberate(sc, b); - } - fdat->args = cdr(fdat->args); - fdat->ctr++; -} - -static const char *ordinal[11] = {"zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth"}; -static const s7_int ordinal_length[11] = {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5}; - -static void format_ordinal_number(s7_scheme *sc, format_data_t *fdat, s7_pointer port) -{ - s7_int num = s7_integer_clamped_if_gmp(sc, car(fdat->args)); - if (num < 11) - format_append_string(sc, fdat, ordinal[num], ordinal_length[num], port); - else - { - s7_int nlen = 0; - char *tmp = integer_to_string(sc, num, &nlen); - format_append_string(sc, fdat, tmp, nlen, port); - num = num % 100; - if ((num >= 11) && (num <= 13)) - format_append_string(sc, fdat, "th", 2, port); - else - { - num = num % 10; - if (num == 1) format_append_string(sc, fdat, "st", 2, port); - else - if (num == 2) format_append_string(sc, fdat, "nd", 2, port); - else - if (num == 3) format_append_string(sc, fdat, "rd", 2, port); - else format_append_string(sc, fdat, "th", 2, port); - }} - fdat->args = cdr(fdat->args); - fdat->ctr++; -} - -static s7_int format_nesting(const char *str, char opener, char closer, s7_int start, s7_int end) /* start=i, end=str_len-1 */ -{ - s7_int nesting = 1; - for (s7_int k = start + 2; k < end; k++) - if (str[k] == '~') - { - if (str[k + 1] == closer) - { - nesting--; - if (nesting == 0) - return(k - start - 1); - } - else - if (str[k + 1] == opener) - nesting++; - } - return(-1); -} - -static bool format_method(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer port) -{ - s7_pointer func, obj = car(fdat->args); - char ctrl_str[3]; - - if ((!has_active_methods(sc, obj)) || - ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) - return(false); - - ctrl_str[0] = '~'; - ctrl_str[1] = str[0]; - ctrl_str[2] = '\0'; - - if (port == obj) /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */ - s7_apply_function(sc, func, set_plist_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), s7_make_string_wrapper(sc, "#"))); - else s7_apply_function(sc, func, set_plist_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), obj)); - - fdat->args = cdr(fdat->args); - fdat->ctr++; - return(true); -} - -static s7_int format_n_arg(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer args) -{ - s7_int n; - - if (is_null(fdat->args)) /* (format #f "~nT") */ - format_error_nr(sc, "~~N: missing argument", 21, str, args, fdat); - if (!s7_is_integer(car(fdat->args))) - format_error_nr(sc, "~~N: integer argument required", 30, str, args, fdat); - n = s7_integer_clamped_if_gmp(sc, car(fdat->args)); - - if (n < 0) - format_error_nr(sc, "~~N value is negative?", 22, str, args, fdat); - if (n > sc->max_format_length) - format_error_nr(sc, "~~N value is too big", 20, str, args, fdat); - - fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */ - return(n); -} - -static s7_int format_numeric_arg(s7_scheme *sc, const char *str, s7_int str_len, format_data_t *fdat, s7_int *i) -{ - s7_int old_i = *i; - s7_int width = format_read_integer(i, str_len, str); - if (width < 0) - { - if (str[old_i - 1] != ',') /* need branches here, not if-expr because format_error creates the permanent string */ - format_error_nr(sc, "width is negative?", 18, str, fdat->args, fdat); - format_error_nr(sc, "precision is negative?", 22, str, fdat->args, fdat); - } - if (width > sc->max_format_length) - { - if (str[old_i - 1] != ',') - format_error_nr(sc, "width is too big", 16, str, fdat->args, fdat); - format_error_nr(sc, "precision is too big", 20, str, fdat->args, fdat); - } - return(width); -} - -static format_data_t *open_format_data(s7_scheme *sc) -{ - format_data_t *fdat; - sc->format_depth++; - if (sc->format_depth >= sc->num_fdats) - { - int32_t new_num_fdats = sc->format_depth * 2; - sc->fdats = (format_data_t **)Realloc(sc->fdats, sizeof(format_data_t *) * new_num_fdats); - for (int32_t k = sc->num_fdats; k < new_num_fdats; k++) sc->fdats[k] = NULL; - sc->num_fdats = new_num_fdats; - } - fdat = sc->fdats[sc->format_depth]; - if (!fdat) - { - fdat = (format_data_t *)Malloc(sizeof(format_data_t)); - sc->fdats[sc->format_depth] = fdat; - fdat->curly_len = 0; - fdat->curly_str = NULL; - fdat->ctr = 0; - } - else - { - if (fdat->port) - close_format_port(sc, fdat->port); - if (fdat->strport) - close_format_port(sc, fdat->strport); - } - fdat->port = NULL; - fdat->strport = NULL; - fdat->loc = 0; - fdat->curly_arg = sc->nil; - return(fdat); -} - -#if WITH_GMP -static bool is_one_or_big_one(s7_scheme *sc, s7_pointer p) -{ - if (!is_big_number(p)) return(is_one(p)); - if (is_t_big_integer(p)) return(mpz_cmp_ui(big_integer(p), 1) == 0); - if (is_t_big_real(p)) return(mpfr_cmp_d(big_real(p), 1.0) == 0); - return(false); -} -#else -#define is_one_or_big_one(Sc, Num) is_one(Num) -#endif - -static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj); - -static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, - s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str) -{ - s7_int i, str_len; - format_data_t *fdat; - s7_pointer deferred_port; - - if (len <= 0) - { - str_len = safe_strlen(str); - if (str_len == 0) - { - if (is_not_null(args)) - error_nr(sc, sc->format_error_symbol, - set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args)); - return((with_result) ? nil_string : sc->F); - }} - else str_len = len; - - fdat = open_format_data(sc); - fdat->args = args; - fdat->orig_str = orig_str; - - if (with_result) - { - deferred_port = port; - port = open_format_port(sc); - fdat->port = port; - } - else deferred_port = sc->F; - - for (i = 0; i < str_len - 1; i++) - { - if ((uint8_t)(str[i]) == (uint8_t)'~') - { - use_write_t use_write; - switch (str[i + 1]) - { - case '%': /* -------- newline -------- */ - /* sbcl apparently accepts numeric args here (including 0) */ - if ((port_data(port)) && - (port_position(port) < port_data_size(port))) - { - port_data(port)[port_position(port)++] = '\n'; - sc->format_column = 0; - } - else format_append_newline(sc, port); - i++; - break; - - case '&': /* -------- conditional newline -------- */ - /* this only works if all output goes through format -- display/write for example do not update format_column */ - if (sc->format_column > 0) - format_append_newline(sc, port); - i++; - break; - - case '~': /* -------- tilde -------- */ - format_append_char(sc, '~', port); - i++; - break; - - case '\n': /* -------- trim white-space -------- so (format #f "hiho~\n") -> "hiho"! */ - for (i = i + 2; i args)) /* (format #f "~*~A") */ - format_error_nr(sc, "can't skip argument!", 20, str, args, fdat); - fdat->args = cdr(fdat->args); - break; - - case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */ - if ((is_pair(fdat->args)) && - (fdat->ctr >= sc->print_length)) - { - format_append_string(sc, fdat, " ...", 4, port); - fdat->args = sc->nil; - } - /* fall through */ - - case '^': /* -------- exit -------- */ - if (is_null(fdat->args)) - { - i = str_len; - goto ALL_DONE; - } - i++; - break; - - case '@': /* -------- plural, 'y' or 'ies' -------- */ - i += 2; - if ((str[i] != 'P') && (str[i] != 'p')) - format_error_nr(sc, "unknown '@' directive", 21, str, args, fdat); - if (!is_pair(fdat->args)) - format_error_nr(sc, "'@' directive argument missing", 30, str, args, fdat); - if (!is_real(car(fdat->args))) /* CL accepts non numbers here */ - format_error_nr(sc, "'@P' directive argument is not a real number", 44, str, args, fdat); - - if (!is_one_or_big_one(sc, car(fdat->args))) - format_append_string(sc, fdat, "ies", 3, port); - else format_append_char(sc, 'y', port); - - fdat->args = cdr(fdat->args); - break; - - case 'P': case 'p': /* -------- plural in 's' -------- */ - if (!is_pair(fdat->args)) - format_error_nr(sc, "'P' directive argument missing", 30, str, args, fdat); - if (!is_real(car(fdat->args))) - format_error_nr(sc, "'P' directive argument is not a real number", 43, str, args, fdat); - if (!is_one_or_big_one(sc, car(fdat->args))) - format_append_char(sc, 's', port); - i++; - fdat->args = cdr(fdat->args); - break; - - case '{': /* -------- iteration -------- */ - { - s7_int curly_len; - - if (is_null(fdat->args)) - format_error_nr(sc, "missing argument", 16, str, args, fdat); - - if ((is_pair(car(fdat->args))) && /* any sequence is possible here */ - (s7_list_length(sc, car(fdat->args)) < 0)) /* (format #f "~{~a~e~}" (cons 1 2)) */ - format_error_nr(sc, "~{ argument is a dotted list", 28, str, args, fdat); - - curly_len = format_nesting(str, '{', '}', i, str_len - 1); - - if (curly_len == -1) - format_error_nr(sc, "'{' directive, but no matching '}'", 34, str, args, fdat); - if (curly_len == 1) - format_error_nr(sc, "~{~}' doesn't consume any arguments!", 36, str, args, fdat); - - /* what about cons's here? I can't see any way to specify the car or cdr of a cons within the format string */ - if (is_not_null(car(fdat->args))) /* (format #f "~{~A ~}" ()) -> "" */ - { - s7_pointer curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */ - /* perhaps use an iterator here -- rootlet->list is expensive! */ - if (is_pair(curly_arg)) /* (format #f "~{~A ~}" #()) -> "" */ - { - char *curly_str = NULL; /* this is the local (nested) format control string */ - s7_pointer orig_arg, cycle_arg; - - fdat->curly_arg = curly_arg; - orig_arg = (curly_arg != car(fdat->args)) ? curly_arg : sc->nil; - if (curly_len > fdat->curly_len) - { - if (fdat->curly_str) free(fdat->curly_str); - fdat->curly_len = curly_len; - fdat->curly_str = (char *)Malloc(curly_len); - } - curly_str = fdat->curly_str; - memcpy((void *)curly_str, (void *)(str + i + 2), curly_len - 1); - curly_str[curly_len - 1] = '\0'; - - if ((sc->format_depth < sc->num_fdats - 1) && - (sc->fdats[sc->format_depth + 1])) - sc->fdats[sc->format_depth + 1]->ctr = 0; - - /* it's not easy to use an iterator here instead of a list (so object->list isn't needed above), - * because the curly brackets may enclose multiple arguments -- we would need to use - * iterators throughout this function. - */ - cycle_arg = curly_arg; - while (is_pair(curly_arg)) - { - s7_pointer new_arg = sc->nil; - format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); - if (curly_arg == new_arg) - { - if (cdr(curly_arg) == curly_arg) break; - fdat->curly_arg = sc->nil; - format_error_nr(sc, "'{...}' doesn't consume any arguments!", 38, str, args, fdat); - } - curly_arg = new_arg; - if ((!is_pair(curly_arg)) || (curly_arg == cycle_arg)) - break; - cycle_arg = cdr(cycle_arg); - format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); - curly_arg = new_arg; - } - fdat->curly_arg = sc->nil; - while (is_pair(orig_arg)) /* free_cell below clears the type, so a circular list here is ok */ - { - s7_pointer p = orig_arg; - orig_arg = cdr(orig_arg); - free_cell(sc, p); /* if car(fdar->args) is a hash-table, we could also free_cell(car(p)), but not in any other case */ - }} - else - if (!is_null(curly_arg)) - format_error_nr(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat); - } - i += (curly_len + 2); /* jump past the ending '}' too */ - fdat->args = cdr(fdat->args); - fdat->ctr++; - } - break; - - case '}': - format_error_nr(sc, "unmatched '}'", 13, str, args, fdat); - - case '$': - use_write = P_CODE; - goto OBJSTR; - - case 'W': case 'w': - use_write = P_READABLE; - goto OBJSTR; - - case 'S': case 's': - use_write = P_WRITE; - goto OBJSTR; - - case 'A': case 'a': - use_write = P_DISPLAY; - OBJSTR: /* object->string */ - { - s7_pointer obj, strport; - if (is_null(fdat->args)) - format_error_nr(sc, "missing argument", 16, str, args, fdat); - i++; - obj = car(fdat->args); - if ((use_write == P_READABLE) || - (!has_active_methods(sc, obj)) || - (!format_method(sc, (char *)(str + i), fdat, port))) - { - bool old_openlets = sc->has_openlets; - /* for the column check, we need to know the length of the object->string output */ - if (columnized) - { - strport = open_format_port(sc); - fdat->strport = strport; - } - else strport = port; - if (use_write == P_READABLE) - sc->has_openlets = false; - object_out(sc, obj, strport, use_write); - if (use_write == P_READABLE) - sc->has_openlets = old_openlets; - if (columnized) - { - if (port_position(strport) >= port_data_size(strport)) - resize_port_data(sc, strport, port_data_size(strport) * 2); - port_data(strport)[port_position(strport)] = '\0'; - if (port_position(strport) > 0) - format_append_string(sc, fdat, (const char *)port_data(strport), port_position(strport), port); - close_format_port(sc, strport); - fdat->strport = NULL; - } - fdat->args = cdr(fdat->args); - fdat->ctr++; - }} - break; - - /* -------- numeric args -------- */ - case ':': - i += 2; - if ((str[i] != 'D') && (str[i] != 'd')) - format_error_nr(sc, "unknown ':' directive", 21, str, args, fdat); - if (!is_pair(fdat->args)) - format_error_nr(sc, "':D' directive argument missing", 31, str, args, fdat); - if (!s7_is_integer(car(fdat->args))) - format_error_nr(sc, "':D' directive argument is not an integer", 41, str, args, fdat); - if (s7_integer_clamped_if_gmp(sc, car(fdat->args)) < 0) - format_error_nr(sc, "':D' directive argument can't be negative", 41, str, args, fdat); - format_ordinal_number(sc, fdat, port); - break; - - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': case ',': - case 'N': case 'n': - - case 'B': case 'b': - case 'D': case 'd': - case 'E': case 'e': - case 'F': case 'f': - case 'G': case 'g': - case 'O': case 'o': - case 'X': case 'x': - - case 'T': case 't': - case 'C': case 'c': - { - s7_int width = -1, precision = -1; - char pad = ' '; - i++; /* str[i] == '~' */ - - if (isdigit((int32_t)(str[i]))) - width = format_numeric_arg(sc, str, str_len, fdat, &i); - else - if ((str[i] == 'N') || (str[i] == 'n')) - { - i++; - width = format_n_arg(sc, str, fdat, args); - } - if (str[i] == ',') - { - i++; /* is (format #f "~12,12D" 1) an error? The precision (or is it the width?) has no use here */ - if (isdigit((int32_t)(str[i]))) - precision = format_numeric_arg(sc, str, str_len, fdat, &i); - else - if ((str[i] == 'N') || (str[i] == 'n')) - { - i++; - precision = format_n_arg(sc, str, fdat, args); - } - else - if (str[i] == '\'') /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */ - { - pad = str[i + 1]; - i += 2; - if (i >= str_len) /* (format #f "~,'") */ - format_error_nr(sc, "incomplete numeric argument", 27, str, args, fdat); - }} /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */ - - switch (str[i]) - { - /* -------- pad to column -------- - * are columns numbered from 1 or 0? there seems to be disagreement about this directive, does "space over to" mean including? - */ - case 'T': case 't': - if (width == -1) width = 0; - if (precision == -1) precision = 0; - if ((width > 0) || (precision > 0)) /* (format #f "a~8Tb") */ - { - /* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T.")) - * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%")) - */ - if (precision > 0) - { - int32_t mult = (int32_t)(ceil((s7_double)(sc->format_column + 1 - width) / (s7_double)precision)); /* CLtL2 ("least positive int") */ - if (mult < 1) mult = 1; - width += (precision * mult); - } - width -= (sc->format_column + 1); - if (width > 0) - format_append_chars(sc, fdat, pad, width, port); - } - break; - - case 'C': case 'c': - { - s7_pointer obj; - - if (is_null(fdat->args)) - format_error_nr(sc, "~~C: missing argument", 21, str, args, fdat); - /* the "~~" here and below protects against "~C" being treated as a directive */ - obj = car(fdat->args); - if (!is_character(obj)) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) /* i stepped forward above */ - format_error_nr(sc, "'C' directive requires a character argument", 43, str, args, fdat); - } - else - { - /* here use_write is false, so we just add the char, not its name */ - if (width == -1) - format_append_char(sc, character(obj), port); - else - if (width > 0) - format_append_chars(sc, fdat, character(obj), width, port); - - fdat->args = cdr(fdat->args); - fdat->ctr++; - }} - break; - - /* -------- numbers -------- */ - case 'F': case 'f': - if (is_null(fdat->args)) - format_error_nr(sc, "~~F: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~F: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'f', pad, port); - break; - - case 'G': case 'g': - if (is_null(fdat->args)) - format_error_nr(sc, "~~G: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~G: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'g', pad, port); - break; - - case 'E': case 'e': - if (is_null(fdat->args)) - format_error_nr(sc, "~~E: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~E: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'e', pad, port); - break; - - /* how to handle non-integer arguments in the next 4 cases? clisp just returns - * the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581: - * "if arg is not an integer, it is printed in ~A format and decimal base")!! - * I think I'll use the type of the number to choose the output format. - */ - case 'D': case 'd': - if (is_null(fdat->args)) - format_error_nr(sc, "~~D: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - /* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123))) - * port here is a string-port, str has the width/precision data if the caller wants it, - * args is the current arg. But format_number handles fdat->args and so on, so - * I think I'll pass the format method the current control string (str), the - * current object (car(fdat->args)), and the arglist (args), and assume it will - * return a (scheme) string. - */ - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~D: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'd', pad, port); - break; - - case 'O': case 'o': - if (is_null(fdat->args)) - format_error_nr(sc, "~~O: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~O: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 8, width, precision, 'o', pad, port); - break; - - case 'X': case 'x': - if (is_null(fdat->args)) - format_error_nr(sc, "~~X: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~X: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 16, width, precision, 'x', pad, port); - break; - - case 'B': case 'b': - if (is_null(fdat->args)) - format_error_nr(sc, "~~B: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~B: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 2, width, precision, 'b', pad, port); - break; - - default: - if (width > 0) - format_error_nr(sc, "unused numeric argument", 23, str, args, fdat); - format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); - }} - break; - - default: - format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); - }} - else /* str[i] is not #\~ */ - { - const char *p = (char *)strchr((const char *)(str + i + 1), (int)'~'); - s7_int j = (p) ? p - str : str_len; - s7_int new_len = j - i; - - if ((port_data(port)) && - ((port_position(port) + new_len) < port_data_size(port))) - { - memcpy((void *)(port_data(port) + port_position(port)), (void *)(str + i), new_len); - port_position(port) += new_len; - } - else port_write_string(port)(sc, (char *)(str + i), new_len, port); - fdat->loc += new_len; - sc->format_column += new_len; - i = j - 1; - }} - - ALL_DONE: - if (next_arg) - (*next_arg) = fdat->args; - else - if (is_not_null(fdat->args)) - format_error_nr(sc, "too many arguments", 18, str, args, fdat); - - if (i < str_len) - { - if (str[i] == '~') - format_error_nr(sc, "control string ends in tilde", 28, str, args, fdat); - format_append_char(sc, str[i], port); - } - sc->format_depth--; - if (with_result) - { - s7_pointer result; - if ((is_output_port(deferred_port)) && - (port_position(port) > 0)) - { - if (port_position(port) < port_data_size(port)) - port_data(port)[port_position(port)] = '\0'; - port_write_string(deferred_port)(sc, (const char *)port_data(port), port_position(port), deferred_port); - } - if (port_position(port) < port_data_size(port)) - { - block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); - result = inline_block_to_string(sc, port_data_block(port), port_position(port)); - port_data_size(port) = FORMAT_PORT_LENGTH; - port_data_block(port) = block; - port_data(port) = (uint8_t *)(block_data(block)); - port_data(port)[0] = '\0'; - port_position(port) = 0; - } - else result = make_string_with_length(sc, (char *)port_data(port), port_position(port)); - close_format_port(sc, port); - fdat->port = NULL; - return(result); - } - return(sc->F); -} - -static bool is_columnizing(const char *str) /* look for ~t ~,T ~,t */ -{ - for (char *p = (char *)str; (*p);) - if (*p++ == '~') /* this is faster than strchr */ - { - char c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); - if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) - { - while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); /* ~,1 for example */ - if (c == ',') - { - c = *p++; - while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); - }}} - return(false); -} - -static s7_pointer format_to_port(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, bool with_result, s7_int len) -{ - if ((with_result) || - (port != sc->F)) - return(format_to_port_1(sc, port, str, args, NULL, with_result, true /* is_columnizing(str) */, len, NULL)); - /* is_columnizing on every call is much slower than ignoring the issue */ - return(sc->F); -} - -static s7_pointer g_format(s7_scheme *sc, s7_pointer args) -{ - #define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \ -s7's format directives are taken from CL: ~% = newline, ~& = newline if the preceding output character was \ -no a newline, ~~ = ~, ~ trims white space, ~* skips an argument, ~^ exits {} iteration if the arg list is exhausted, \ -~nT spaces over to column n, ~A prints a representation of any object, ~S is the same, but puts strings in double quotes, \ -~C prints a character, numbers are handled by ~F, ~E, ~G, ~B, ~O, ~D, and ~X with preceding numbers giving \ -spacing (and spacing character) and precision. ~{ starts an embedded format directive which is ended by ~}: \n\ -\n\ - >(format #f \"dashed: ~{~A~^-~}\" '(1 2 3))\n\ - \"dashed: 1-2-3\"\n\ -\n\ -~P inserts \"s\" if the current it is not 1 or 1.0 (use ~@P for \"ies\" or \"y\").\n\ -~B is number->string in base 2, ~O in base 8, ~D base 10, ~X base 16,\n\ -~E: (format #f \"~E\" 100.1) -> \"1.001000e+02\" (%e in C)\n\ -~F: (format #f \"~F\" 100.1) -> \"100.100000\" (%f in C)\n\ -~G: (format #f \"~G\" 100.1) -> \"100.1\" (%g in C)\n\ -\n\ -If the 'out' it is not an output port, the resultant string is returned. If it \ -is #t, the string is also sent to the current-output-port." - - #define Q_format s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), \ - s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) - - s7_pointer pt = car(args), str; - if (is_null(pt)) - { - pt = current_output_port(sc); /* () -> (current-output-port) */ - if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ - return(pt); /* but this means some error checks are skipped? */ - } - sc->format_column = 0; - if (!((is_boolean(pt)) || /* #f or #t */ - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) - return(method_or_bust(sc, pt, sc->format_symbol, args, an_output_port_string, 1)); - - str = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2)); - return(format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, - string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str)); -} - -const char *s7_format(s7_scheme *sc, s7_pointer args) -{ - s7_pointer result = g_format(sc, args); - return((is_string(result)) ? string_value(result) : NULL); -} - -static s7_pointer g_format_f(s7_scheme *sc, s7_pointer args) -{ - /* port == #f, there are other args */ - s7_pointer str = cadr(args); - sc->format_column = 0; - if (!is_string(str)) - return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2)); - return(format_to_port_1(sc, sc->F, string_value(str), cddr(args), NULL, true, true, string_length(str), str)); -} - -static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) -{ - s7_pointer pt = car(args); - s7_pointer str = cadr(args); - if (pt == sc->F) - return(str); - - if (is_null(pt)) - { - pt = current_output_port(sc); - if (pt == sc->F) - return(sc->F); - } - if (pt == sc->T) - { - if ((current_output_port(sc) != sc->F) && (string_length(str) != 0)) - port_write_string(sc->output_port)(sc, string_value(str), string_length(str), current_output_port(sc)); - return(str); - } - if ((!is_output_port(pt)) || - (port_is_closed(pt))) - return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1)); - - if (string_length(str) == 0) - return((is_output_port(pt)) ? sc->F : nil_string); - - port_write_string(pt)(sc, string_value(str), string_length(str), pt); - return(sc->F); -} - -static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args) -{ - s7_pointer func, obj = caddr(args); - if ((!has_active_methods(sc, obj)) || - ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) - return(s7_object_to_string(sc, obj, false)); - return(s7_apply_function(sc, func, set_plist_3(sc, sc->F, cadr(args), obj))); -} - -static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args) -{ - s7_pointer pt = car(args), str; - if (is_null(pt)) - { - pt = current_output_port(sc); - if (pt == sc->F) - return(sc->F); - } - if (!((is_boolean(pt)) || - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) - return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1)); - - str = cadr(args); - sc->format_column = 0; - return(format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, - string_value(str), cddr(args), NULL, - !is_output_port(pt), /* i.e. is boolean port so we're returning a string */ - false, /* we checked in advance that it is not columnized */ - string_length(str), str)); -} - -static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args > 1) - { - s7_pointer port = cadr(expr); - s7_pointer str_arg = caddr(expr); - if (is_string(str_arg)) - { - if ((ops) && ((args == 2) || (args == 3))) - { - s7_int len; - char *orig = string_value(str_arg); - const char *p = strchr((const char *)orig, (int)'~'); - if (!p) - return((args == 2) ? sc->format_just_control_string : f); - - len = string_length(str_arg); - if ((args == 2) && - (len > 1) && - (orig[len - 1] == '%') && - ((p - orig) == len - 2)) - { - orig[len - 2] = '\n'; - orig[len - 1] = '\0'; - string_length(str_arg) = len - 1; - return(sc->format_just_control_string); - } - if ((args == 3) && - (len == 2) && - (port == sc->F) && - (orig[0] == '~') && - ((orig[1] == 'A') || (orig[1] == 'a'))) - return(sc->format_as_objstr); - } - /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ - if (!is_columnizing(string_value(str_arg))) - return(sc->format_no_column); - } - if (port == sc->F) - return(sc->format_f); - } - return(f); -} - - -#if WITH_SYSTEM_EXTRAS -#include - -/* -------------------------------- directory? -------------------------------- */ -static s7_pointer g_is_directory(s7_scheme *sc, s7_pointer args) -{ - #define H_is_directory "(directory? str) returns #t if str is the name of a directory" - #define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->is_directory_symbol, args, sc->type_names[T_STRING])); - return(s7_make_boolean(sc, is_directory(string_value(name)))); -} - -static bool is_directory_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_string(p)) - sole_arg_wrong_type_error_nr(sc, sc->is_directory_symbol, p, sc->type_names[T_STRING]); - return(is_directory(string_value(p))); -} - -static bool file_probe(const char *arg) -{ -#if (!MS_WINDOWS) - return(access(arg, F_OK) == 0); -#else - int32_t fd = open(arg, O_RDONLY, 0); - if (fd == -1) return(false); - close(fd); - return(true); -#endif -} - -/* -------------------------------- file-exists? -------------------------------- */ -static s7_pointer g_file_exists(s7_scheme *sc, s7_pointer args) -{ - #define H_file_exists "(file-exists? filename) returns #t if the file exists" - #define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->file_exists_symbol, args, sc->type_names[T_STRING])); - return(s7_make_boolean(sc, file_probe(string_value(name)))); -} - -static bool file_exists_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_string(p)) - sole_arg_wrong_type_error_nr(sc, sc->file_exists_symbol, p, sc->type_names[T_STRING]); - return(file_probe(string_value(p))); -} - -/* -------------------------------- delete-file -------------------------------- */ -static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args) -{ - #define H_delete_file "(delete-file filename) deletes the file filename." - #define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->delete_file_symbol, args, sc->type_names[T_STRING])); - return(make_integer(sc, unlink(string_value(name)))); -} - -/* -------------------------------- getenv -------------------------------- */ -static s7_pointer g_getenv(s7_scheme *sc, s7_pointer args) /* r7rs says #f if no such variable. this used to return "" in that case, 6-May-22 */ -{ - #define H_getenv "(getenv var) returns the value of an environment variable, or #f if none is found" - #define Q_getenv s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_string_symbol) - - char *result; - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->getenv_symbol, args, sc->type_names[T_STRING])); - result = getenv(string_value(name)); - return((result) ? s7_make_string(sc, result) : sc->F); -} - -/* -------------------------------- system -------------------------------- */ -static s7_pointer g_system(s7_scheme *sc, s7_pointer args) -{ - #define H_system "(system command) executes the command. If the optional second argument is #t, \ -system captures the output as a string and returns it." - #define Q_system s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_boolean_symbol) - -#ifdef __EMSCRIPTEN__ - return s7_nil(sc); -#else - s7_pointer name = car(args); - - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->system_symbol, args, sc->type_names[T_STRING])); - - if ((is_pair(cdr(args))) && - (cadr(args) == sc->T)) - { - #define BUF_SIZE 256 - char buf[BUF_SIZE]; - char *str = NULL; - int32_t cur_len = 0, full_len = 0; - FILE *fd = popen(string_value(name), "r"); - while (fgets(buf, BUF_SIZE, fd)) - { - s7_int buf_len = safe_strlen(buf); - if (cur_len + buf_len >= full_len) - { - full_len += BUF_SIZE * 2; - str = (str) ? (char *)Realloc(str, full_len) : (char *)Malloc(full_len); - } - memcpy((void *)(str + cur_len), (void *)buf, buf_len); - cur_len += buf_len; - } - pclose(fd); - if (str) - { - block_t *b = mallocate_block(sc); - block_data(b) = (void *)str; - block_set_index(b, TOP_BLOCK_LIST); - return(block_to_string(sc, b, cur_len)); - } - return(nil_string); - } - return(make_integer(sc, system(string_value(name)))); -#endif -} - - -#if (!MS_WINDOWS) -#include - -/* -------------------------------- directory->list -------------------------------- */ -static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)." - #define Q_directory_to_list s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_string_symbol) /* can return nil */ - - s7_pointer name = car(args); - DIR *dpos; - s7_pointer result; - - if (!is_string(name)) - return(method_or_bust_p(sc, name, sc->directory_to_list_symbol, sc->type_names[T_STRING])); - - sc->w = sc->nil; - if ((dpos = opendir(string_value(name)))) - { - struct dirent *dirp; - while ((dirp = readdir(dpos))) - sc->w = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->w); - closedir(dpos); - } - result = sc->w; - sc->w = sc->unused; - return(result); -} - -/* -------------------------------- file-mtime -------------------------------- */ -static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args) -{ - #define H_file_mtime "(file-mtime file): return the write date of file" - #define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) - - struct stat statbuf; - int32_t err; - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->file_mtime_symbol, args, sc->type_names[T_STRING])); - err = stat(string_value(name), &statbuf); - if (err < 0) - file_error_nr(sc, "file-mtime", strerror(errno), string_value(name)); - return(make_integer(sc, (s7_int)(statbuf.st_mtime))); -} -#endif -#endif /* with_system_extras */ - - -/* -------------------------------- lists -------------------------------- */ -s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - s7_pointer x; - new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* apparently slightly faster as a function? */ - s7_pointer x; - new_cell_no_check(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, uint64_t type) -{ - s7_pointer x = alloc_pointer(sc); - set_full_type(x, type | T_UNHEAP); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer semipermanent_list(s7_scheme *sc, s7_int len) -{ - s7_pointer p = sc->nil; - for (s7_int j = 0; j < len; j++) - p = semipermanent_cons(sc, sc->unused, p, T_PAIR | T_IMMUTABLE); - return(p); -} - -s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...) -{ - va_list ap; - s7_int i; - s7_pointer res = sc->nil; - - for (i = 0; i < len; i++) - res = semipermanent_cons(sc, sc->unused, res, T_PAIR | T_IMMUTABLE); - va_start(ap, len); - i = 0; - for (s7_pointer p = res; is_pair(p); p = cdr(p), i++) - { - set_car(p, va_arg(ap, s7_pointer)); - if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) - s7_warn(sc, 512, "s7_make_signature got an invalid entry %s at position %" ld64, display(car(p)), i); - } - va_end(ap); - return((s7_pointer)res); -} - -s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...) -{ - va_list ap; - s7_int i; - s7_pointer p, res = sc->nil, back = NULL, end = NULL; - - for (i = 0; i < len; i++) - res = semipermanent_cons(sc, sc->nil, res, T_PAIR | T_IMMUTABLE); - va_start(ap, len); - for (p = res, i = 0; is_pair(p); p = cdr(p), i++) - { - set_car(p, va_arg(ap, s7_pointer)); - if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) - s7_warn(sc, 512, "s7_make_circular_signature got an invalid entry %s at position %" ld64, display(car(p)), i); - if (i == cycle_point) back = p; - if (i == (len - 1)) end = p; - } - va_end(ap); - if (end) set_cdr(end, back); - if (i < len) - s7_warn(sc, 256, "s7_make_circular_signature got too few entries: %s\n", display(res)); - return((s7_pointer)res); -} - - -bool s7_is_pair(s7_pointer p) {return(is_pair(p));} -static s7_pointer is_pair_p_p(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? sc->T : sc->F);} - -s7_pointer s7_car(s7_pointer p) {return(car(p));} -s7_pointer s7_cdr(s7_pointer p) {return(cdr(p));} - -s7_pointer s7_cadr(s7_pointer p) {return(cadr(p));} -s7_pointer s7_cddr(s7_pointer p) {return(cddr(p));} -s7_pointer s7_cdar(s7_pointer p) {return(cdar(p));} -s7_pointer s7_caar(s7_pointer p) {return(caar(p));} - -s7_pointer s7_caadr(s7_pointer p) {return(caadr(p));} -s7_pointer s7_caddr(s7_pointer p) {return(caddr(p));} -s7_pointer s7_cadar(s7_pointer p) {return(cadar(p));} -s7_pointer s7_caaar(s7_pointer p) {return(caaar(p));} -s7_pointer s7_cdadr(s7_pointer p) {return(cdadr(p));} -s7_pointer s7_cdddr(s7_pointer p) {return(cdddr(p));} -s7_pointer s7_cddar(s7_pointer p) {return(cddar(p));} -s7_pointer s7_cdaar(s7_pointer p) {return(cdaar(p));} - -s7_pointer s7_caaadr(s7_pointer p) {return(caaadr(p));} -s7_pointer s7_caaddr(s7_pointer p) {return(caaddr(p));} -s7_pointer s7_caadar(s7_pointer p) {return(caadar(p));} -s7_pointer s7_caaaar(s7_pointer p) {return(caaaar(p));} -s7_pointer s7_cadadr(s7_pointer p) {return(cadadr(p));} -s7_pointer s7_cadddr(s7_pointer p) {return(cadddr(p));} -s7_pointer s7_caddar(s7_pointer p) {return(caddar(p));} -s7_pointer s7_cadaar(s7_pointer p) {return(cadaar(p));} - -s7_pointer s7_cdaadr(s7_pointer p) {return(cdaadr(p));} -s7_pointer s7_cdaddr(s7_pointer p) {return(cdaddr(p));} -s7_pointer s7_cdadar(s7_pointer p) {return(cdadar(p));} -s7_pointer s7_cdaaar(s7_pointer p) {return(cdaaar(p));} -s7_pointer s7_cddadr(s7_pointer p) {return(cddadr(p));} -s7_pointer s7_cddddr(s7_pointer p) {return(cddddr(p));} -s7_pointer s7_cdddar(s7_pointer p) {return(cdddar(p));} -s7_pointer s7_cddaar(s7_pointer p) {return(cddaar(p));} - -s7_pointer s7_set_car(s7_pointer p, s7_pointer q) {set_car(p, q); return(q);} -s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q) {set_cdr(p, q); return(q);} - - -/* -------------------------------------------------------------------------------- */ -void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len) -{ - int32_t i = 0; - for (s7_pointer p = list; is_pair(p); p = cdr(p), i++) array[i] = car(p); - for (; i < len; i++) array[i] = sc->undefined; -} - - -/* ---------------- tree-leaves ---------------- */ -static inline s7_int tree_len_1(s7_scheme *sc, s7_pointer p) -{ - s7_int sum; - if ((S7_DEBUGGING) && (tree_is_cyclic(sc, p))) {fprintf(stderr, "%s[%d]: tree is cyclic\n", __func__, __LINE__); abort();} - for (sum = 0; is_pair(p); p = cdr(p)) - { - s7_pointer cp = car(p); - if ((!is_pair(cp)) || - (car(cp) == sc->quote_symbol)) - sum++; - else - { - do { - s7_pointer ccp = car(cp); - if ((!is_pair(ccp)) || - (car(ccp) == sc->quote_symbol)) - sum++; - else - { - do { - s7_pointer cccp = car(ccp); - if ((!is_pair(cccp)) || - (car(cccp) == sc->quote_symbol)) - sum++; - else sum += tree_len_1(sc, cccp); - ccp = cdr(ccp); - } while (is_pair(ccp)); - if (!is_null(ccp)) sum++; - } - cp = cdr(cp); - } while (is_pair(cp)); - if (!is_null(cp)) sum++; - }} - return((is_null(p)) ? sum : sum + 1); -} - -static inline s7_int tree_len(s7_scheme *sc, s7_pointer p) -{ - if (is_null(p)) - return(0); - if ((!is_pair(p)) || - (car(p) == sc->quote_symbol)) - return(1); - return(tree_len_1(sc, p)); -} - -static s7_int tree_leaves_i_7p(s7_scheme *sc, s7_pointer p) -{ - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, p))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), p)); - return(tree_len(sc, p)); -} - -static s7_pointer tree_leaves_p_p(s7_scheme *sc, s7_pointer tree) -{ - if ((sc->safety > NO_SAFETY) && /* repeat code to avoid extra call overhead */ - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), tree)); - return(make_integer(sc, tree_len(sc, tree))); -} - -static s7_pointer g_tree_leaves(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_leaves "(tree-leaves tree) returns the number of leaves in the tree" - #define Q_tree_leaves s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T) - return(tree_leaves_p_p(sc, car(args))); -} - - -/* ---------------- tree-memq ---------------- */ -static inline bool tree_memq_1(s7_scheme *sc, s7_pointer sym, s7_pointer tree) /* sym need not be a symbol */ -{ - if (car(tree) == sc->quote_symbol) - return((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(tree))) && (sym == cadr(tree))); - do { - if (sym == car(tree)) - return(true); - - if (is_pair(car(tree))) - { - s7_pointer cp = car(tree); - if (car(cp) == sc->quote_symbol) - { - if ((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(cp))) && (sym == cadr(cp))) - return(true); - } - else - do { - if (sym == car(cp)) - return(true); - if ((is_pair(car(cp))) && (tree_memq_1(sc, sym, car(cp)))) - return(true); - cp = cdr(cp); - if (sym == cp) - return(true); - } while (is_pair(cp)); - } - tree = cdr(tree); - if (sym == tree) - return(true); - } while (is_pair(tree)); - return(false); -} - -bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree) -{ - if (sym == tree) return(true); - if (!is_pair(tree)) return(false); - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-memq: tree is cyclic: ~S", 29), tree)); - return(tree_memq_1(sc, sym, tree)); -} - -static s7_pointer g_tree_memq(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_memq "(tree-memq obj tree) is a tree-oriented version of memq, but returning #t if the object is in the tree." - #define Q_tree_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - return(make_boolean(sc, s7_tree_memq(sc, car(args), cadr(args)))); -} - - -/* ---------------- tree-set-memq ---------------- */ -static inline bool pair_set_memq(s7_scheme *sc, s7_pointer tree) -{ - while (true) - { - s7_pointer p = car(tree); - if (is_symbol(p)) - { - if (symbol_is_in_list(sc, p)) - return(true); - } - else - if ((is_unquoted_pair(p)) && - (pair_set_memq(sc, p))) - return(true); - tree = cdr(tree); - if (!is_pair(tree)) break; - } - return((is_symbol(tree)) && (symbol_is_in_list(sc, tree))); -} - -static bool tree_set_memq(s7_scheme *sc, s7_pointer tree) -{ - if (is_symbol(tree)) - return(symbol_is_in_list(sc, tree)); - if ((!is_pair(tree)) || - (car(tree) == sc->quote_symbol)) - return(false); - return(pair_set_memq(sc, tree)); -} - -static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) -{ - if (!is_pair(syms)) return(false); - if (sc->safety > NO_SAFETY) - { - if (tree_is_cyclic(sc, syms)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: symbol list is cyclic: ~S", 40), syms)); - if (tree_is_cyclic(sc, tree)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); - } - clear_symbol_list(sc); - for (s7_pointer p = syms; is_pair(p); p = cdr(p)) - if (is_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - return(tree_set_memq(sc, tree)); -} - -static s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) -{ - return(make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree))); -} - -static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree" - #define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - return(make_boolean(sc, tree_set_memq_b_7pp(sc, car(args), cadr(args)))); -} - -static s7_pointer tree_set_memq_direct(s7_scheme *sc, s7_pointer syms, s7_pointer tree) -{ - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); - clear_symbol_list(sc); - for (s7_pointer p = syms; is_pair(p); p = cdr(p)) - add_symbol_to_list(sc, car(p)); - return(make_boolean(sc, tree_set_memq(sc, tree))); -} - -static s7_pointer g_tree_set_memq_1(s7_scheme *sc, s7_pointer args) -{ - return(tree_set_memq_direct(sc, car(args), cadr(args))); -} - -static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ... */ - (is_pair(cadadr(expr)))) - { - for (s7_pointer p = cadadr(expr); is_pair(p); p = cdr(p)) - if (!is_symbol(car(p))) - return(f); - return(sc->tree_set_memq_syms); /* this is tree_set_memq_1 */ - } - return(f); -} - - -/* ---------------- tree-count ---------------- */ -static s7_int tree_count(s7_scheme *sc, s7_pointer x, s7_pointer p, s7_int count) -{ - if (p == x) return(count + 1); - if ((!is_pair(p)) || (car(p) == sc->quote_symbol)) return(count); - return(tree_count(sc, x, cdr(p), tree_count(sc, x, car(p), count))); -} - -static inline s7_int tree_count_at_least(s7_scheme *sc, s7_pointer x, s7_pointer p, s7_int count, s7_int top) -{ - if (p == x) return(count + 1); - if ((!is_pair(p)) || (car(p) == sc->quote_symbol)) return(count); - do { - count = tree_count_at_least(sc, x, car(p), count, top); - if (count >= top) return(count); - p = cdr(p); - if (p == x) return(count + 1); - } while (is_pair(p)); - return(count); -} - -static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_count "(tree-count obj tree max-count) returns how many times obj is in tree (using eq?), stopping at max-count (if specified)" - #define Q_tree_count s7_make_signature(sc, 4, sc->is_integer_symbol, sc->T, sc->T, sc->is_integer_symbol) - s7_pointer obj = car(args); - s7_pointer tree = cadr(args), count; - - if (!is_pair(tree)) - { - if ((is_pair(cddr(args))) && - (!s7_is_integer(caddr(args)))) - wrong_type_error_nr(sc, sc->tree_count_symbol, 3, caddr(args), sc->type_names[T_INTEGER]); - /* here we need eqv? not eq? for integers: (tree-count <0-int-zero> <0-not-int-zero>) - * perhaps split tree_count|_at_least into eq?/eqv?/equal?/equivalent? cases? - * this is used primarily for symbol counts in lint.scm - */ - return((obj == tree) ? int_one : int_zero); - } - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-count: tree is cyclic: ~S", 30), tree)); - if (is_null(cddr(args))) - return(make_integer(sc, tree_count(sc, obj, tree, 0))); - count = caddr(args); - if (!s7_is_integer(count)) - wrong_type_error_nr(sc, sc->tree_count_symbol, 3, count, sc->type_names[T_INTEGER]); - return(make_integer(sc, tree_count_at_least(sc, obj, tree, 0, s7_integer_clamped_if_gmp(sc, count)))); -} - - -/* -------------------------------- pair? -------------------------------- */ -static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args) -{ - #define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" - #define Q_is_pair sc->pl_bt - check_boolean_method(sc, is_pair, sc->is_pair_symbol, args); -} - - -/* -------------------------------- list? -------------------------------- */ -bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));} - -static bool is_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));} - -static s7_pointer g_is_list(s7_scheme *sc, s7_pointer args) -{ - #define H_is_list "(list? obj) returns #t if obj is a pair or null" - #define Q_is_list sc->pl_bt - #define is_a_list(p) s7_is_list(sc, p) - check_boolean_method(sc, is_a_list, sc->is_list_symbol, args); -} - -static s7_int proper_list_length(s7_pointer a) -{ - s7_int i = 0; - for (s7_pointer b = a; is_pair(b); i++, b = cdr(b)) {}; - return(i); -} - -static s7_int proper_list_length_with_end(s7_pointer a, s7_pointer *c) -{ - s7_int i = 0; - s7_pointer b; - for (b = a; is_pair(b); i++, b = cdr(b)) {}; - *c = b; - return(i); -} - -s7_int s7_list_length(s7_scheme *sc, s7_pointer a) /* returns -len if list is dotted, 0 if it's (directly) circular */ -{ - s7_pointer slow = a, fast = a; - for (s7_int i = 0; ; i += 2) - { - if (!is_pair(fast)) return((is_null(fast)) ? i : -i); - fast = cdr(fast); - if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); /* if unrolled further, it's a lot slower? */ - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) return(0); - } - return(0); -} - - -/* -------------------------------- proper-list? -------------------------------- */ -static inline s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst) -{ - s7_pointer tp; - if (!is_pair(lst)) return(sc->nil); - sc->temp5 = lst; - tp = list_1(sc, car(lst)); - sc->temp8 = tp; - for (s7_pointer p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - { - set_cdr(np, list_1_unchecked(sc, car(p))); - p = cdr(p); - if (is_pair(p)) {np = cdr(np); set_cdr(np, list_1_unchecked(sc, car(p)));} else break; - p = cdr(p); - if (is_pair(p)) {np = cdr(np); set_cdr(np, list_1(sc, car(p)));} else break; - } - sc->temp8 = sc->unused; - sc->temp5 = sc->unused; - return(tp); -} - -bool s7_is_proper_list(s7_scheme *sc, s7_pointer lst) -{ - /* #t if () or undotted/non-circular pair */ - s7_pointer slow = lst, fast = lst; - while (true) - { - if (!is_pair(fast)) - return(is_null(fast)); /* else it's an improper list */ - LOOP_4(fast = cdr(fast); if (!is_pair(fast)) return(is_null(fast))); - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) return(false); - } - return(true); -} - -static s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args) -{ - #define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted." - #define Q_is_proper_list sc->pl_bt - return(make_boolean(sc, s7_is_proper_list(sc, car(args)))); -} - -static s7_pointer is_proper_list_p_p(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, s7_is_proper_list(sc, arg)));} - -static bool is_proper_list_1(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_null(cdr(p))));} -static bool is_proper_list_2(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));} -static bool is_proper_list_3(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p))) && (is_null(cdddr(p))));} -static bool is_proper_list_4(s7_scheme *unused_sc, s7_pointer p) {return(proper_list_length(p) == 4);} - - -/* -------------------------------- make-list -------------------------------- */ -static s7_pointer make_big_list(s7_scheme *sc, s7_int len, s7_pointer init) -{ - check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */ - sc->value = sc->nil; - for (s7_int i = 0; i < len; i++) sc->value = cons_unchecked(sc, init, sc->value); - return(sc->value); -} - -static inline s7_pointer make_list(s7_scheme *sc, s7_int len, s7_pointer init) -{ - switch (len) - { - case 0: return(sc->nil); - case 1: return(T_Pair(cons(sc, init, sc->nil))); - case 2: return(T_Pair(cons_unchecked(sc, init, cons(sc, init, sc->nil)))); - case 3: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))); - case 4: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))); - case 5: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))); - case 6: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, - cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))))); - case 7: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, - cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))))); - default: - return(make_big_list(sc, len, init)); - } - return(sc->nil); /* never happens, I hope */ -} - -s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init) {return(make_list(sc, len, init));} - -static s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init) -{ - s7_int len; - if (!s7_is_integer(n)) - return(method_or_bust(sc, n, sc->make_list_symbol, set_plist_2(sc, n, init), sc->type_names[T_INTEGER], 1)); - - len = s7_integer_clamped_if_gmp(sc, n); -#if WITH_GMP - if ((len == 0) && (!is_zero(n))) - out_of_range_error_nr(sc, sc->make_list_symbol, int_one, n, wrap_string(sc, "big integer is too big for s7_int", 33)); -#endif - if (len == 0) return(sc->nil); /* what about (make-list 0 123)? */ - if ((len < 0) || (len > sc->max_list_length)) - out_of_range_error_nr(sc, sc->make_list_symbol, int_one, n, (len < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_list(sc, len, init)); -} - -static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args) -{ - #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'." - #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T) - return(make_list_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F)); -} - - -/* -------------------------------- list-ref -------------------------------- */ -s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num) -{ - s7_int i; - s7_pointer x; - for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {} - if ((i == num) && (is_pair(x))) - return(car(x)); - return(sc->nil); -} - -static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind) -{ - s7_int index; - s7_pointer p = lst; - - if (!s7_is_integer(ind)) - return(method_or_bust_pp(sc, ind, sc->list_ref_symbol, lst, ind, sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} - if (is_pair(p)) return(car(p)); - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string); - return(NULL); -} - -static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices); - -static s7_pointer ref_index_checked(s7_scheme *sc, s7_pointer caller, s7_pointer in_obj, s7_pointer args) -{ - if (!is_applicable(in_obj)) /* let implicit_index shuffle syntax and closures */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - cons(sc, caller, args), cons(sc, in_obj, cddr(args)), in_obj)); - /* perhaps first $s -> "(~S ~{~$~^ ~})..." and we can pass the symbol rather than the global value as "caller" */ - return(implicit_index(sc, in_obj, cddr(args))); -} - -static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list" - #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) - /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) */ - - s7_pointer lst = car(args); - if (!is_pair(lst)) - return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); - - lst = list_ref_1(sc, lst, cadr(args)); - if (is_pair(cddr(args))) - return(ref_index_checked(sc, global_value(sc->list_ref_symbol), lst, args)); - return(lst); -} - -static bool op_implicit_pair_ref_a(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_pair(s)) {sc->last_function = s; return(false);} - sc->value = list_ref_1(sc, s, fx_call(sc, cdr(sc->code))); - return(true); -} - -static s7_pointer implicit_pair_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices) -{ - if (!is_applicable(in_obj)) - { - s7_pointer safe_indices = copy_proper_list(sc, indices); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - cons(sc, obj, safe_indices), cons(sc, in_obj, cdr(safe_indices)), in_obj)); - } - return(implicit_index(sc, in_obj, cdr(indices))); -} - -static bool op_implicit_pair_ref_aa(s7_scheme *sc) -{ - s7_pointer i1; - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_pair(s)) {sc->last_function = s; return(false);} - sc->args = fx_call(sc, cddr(sc->code)); - i1 = fx_call(sc, cdr(sc->code)); - sc->value = implicit_pair_index_checked(sc, s, list_ref_1(sc, s, i1), set_plist_2(sc, i1, sc->args)); - return(true); -} - -static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 2) - { - s7_pointer index = caddr(expr); - if (is_t_integer(index)) - { - if (integer(index) == 0) return(sc->list_ref_at_0); - if (integer(index) == 1) return(sc->list_ref_at_1); - if (integer(index) == 2) return(sc->list_ref_at_2); - }} - return(f); -} - -static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - s7_pointer p = p1; - if ((i1 < 0) || (i1 > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - for (s7_int i = 0; ((is_pair(p)) && (i < i1)); i++, p = cdr(p)); - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, a_proper_list_string); - } - return(car(p)); -} - -static s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if (!is_pair(p1)) - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, sc->type_names[T_PAIR]); - return(list_ref_p_pi_unchecked(sc, p1, i1)); -} - -static s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_pair(p1)) - return(g_list_ref(sc, set_plist_2(sc, p1, p2))); - if (!s7_is_integer(p2)) - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p2, sc->type_names[T_INTEGER]); - return(list_ref_p_pi_unchecked(sc, p1, s7_integer_clamped_if_gmp(sc, p2))); -} - - -/* -------------------------------- list-set! -------------------------------- */ -s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val) -{ - s7_int i; - s7_pointer x; - for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {} - if ((i == num) && - (is_pair(x))) - set_car(x, T_Ext(val)); - return(val); -} - -static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int32_t arg_num) -{ - #define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val" - #define Q_list_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_pair_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol) - - s7_int index; - s7_pointer p = lst, ind; - /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */ - - if (!is_mutable_pair(lst)) - return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_PAIR], 1)); - ind = car(args); - if ((arg_num > 2) && (is_null(cdr(args)))) - { - set_car(lst, ind); - return(ind); - } - if (!s7_is_integer(ind)) - return(method_or_bust(sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} - - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); - } - if (is_null(cddr(args))) - set_car(p, cadr(args)); - else - { - if (!s7_is_pair(car(p))) - wrong_number_of_args_error_nr(sc, "too many arguments for list-set!: ~S", args); - return(g_list_set_1(sc, car(p), cdr(args), arg_num + 1)); - } - return(cadr(args)); -} - -static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) {return(g_list_set_1(sc, car(args), cdr(args), 2));} - -static inline s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - s7_pointer p = p1; - if ((i1 < 0) || (i1 > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - for (s7_int i = 0; ((is_pair(p)) && (i < i1)); i++, p = cdr(p)); - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string); - } - set_car(p, p2); - return(p2); -} - -static s7_pointer list_increment_p_pip_unchecked(opt_info *o) -{ - s7_scheme *sc = o->sc; - s7_pointer p = slot_value(o->v[2].p), p1, p2; - s7_int index = integer(p); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); - p1 = slot_value(o->v[1].p); - p = p1; - for (s7_int i = 0; ((is_pair(p)) && (i < index)); i++, p = cdr(p)); - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string); - } - p2 = g_add_xi(sc, car(p), integer(o->v[3].p), index); - set_car(p, p2); - return(p2); -} - -static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - if (!is_pair(p1)) - wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, sc->type_names[T_PAIR]); - return(list_set_p_pip_unchecked(sc, p1, i1, p2)); -} - -static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lst = car(args), val; - s7_pointer p = lst; - s7_int index; - if (!is_mutable_pair(lst)) - return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, args, sc->type_names[T_PAIR], 1)); - - index = s7_integer_clamped_if_gmp(sc, cadr(args)); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); - } - val = caddr(args); - set_car(p, val); - return(val); -} - -static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if ((args == 3) && - (s7_is_integer(caddr(expr))) && - (s7_integer_clamped_if_gmp(sc, caddr(expr)) >= 0) && - (s7_integer_clamped_if_gmp(sc, caddr(expr)) < sc->max_list_length)) - return(sc->list_set_i); - return(f); -} - - -/* -------------------------------- list-tail -------------------------------- */ -static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer p) -{ - s7_int i, index; - if (!s7_is_integer(p)) - return(method_or_bust_pp(sc, p, sc->list_tail_symbol, lst, p, sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, p); - - if (!is_list(lst)) /* (list-tail () 0) -> () */ - return(method_or_bust_with_type_pi(sc, lst, sc->list_tail_symbol, lst, index, a_list_string, 1)); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (i = 0; (i < index) && (is_pair(lst)); i++, lst = cdr(lst)) {} - if (i < index) - out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - return(lst); -} - -static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args) -{ - #define H_list_tail "(list-tail lst i) returns the list from the i-th element on" - #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */ - return(list_tail_p_pp(sc, car(args), cadr(args))); -} - - -/* -------------------------------- cons -------------------------------- */ -static s7_pointer g_cons(s7_scheme *sc, s7_pointer args) -{ - #define H_cons "(cons a b) returns a pair containing a and b" - #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T) - - s7_pointer x; - new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, car(args)); - set_cdr(x, cadr(args)); - return(x); -} - -static s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - s7_pointer x; - new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, p1); - set_cdr(x, p2); - return(x); -} - - -/* -------- car -------- */ - -static s7_pointer g_car(s7_scheme *sc, s7_pointer args) -{ - #define H_car "(car pair) returns the first element of the pair" - #define Q_car sc->pl_p - - s7_pointer lst = car(args); - if (is_pair(lst)) - return(car(lst)); - return(sole_arg_method_or_bust(sc, lst, sc->car_symbol, args, sc->type_names[T_PAIR])); -} - -static s7_pointer car_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_pair(p)) - return(car(p)); - return(sole_arg_method_or_bust(sc, p, sc->car_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - -static s7_pointer g_list_ref_at_0(s7_scheme *sc, s7_pointer args) -{ - if (is_pair(car(args))) return(caar(args)); - return(method_or_bust(sc, car(args), sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); /* 1=arg num if error */ -} - - -static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args) -{ - #define H_set_car "(set-car! pair val) sets the pair's first element to val" - #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) - - s7_pointer p = car(args); - if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_car_symbol, args, sc->type_names[T_PAIR], 1)); - set_car(p, cadr(args)); - return(car(p)); -} - -static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_car_symbol, set_plist_1(sc, p1), sc->type_names[T_PAIR], 1)); - set_car(p1, p2); - return(p2); -} - -static s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_car(sc, p1, p2));} - - -/* -------- cdr -------- */ -static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdr "(cdr pair) returns the second element of the pair" - #define Q_cdr sc->pl_p - - s7_pointer lst = car(args); - if (is_pair(lst)) - return(cdr(lst)); - return(sole_arg_method_or_bust(sc, lst, sc->cdr_symbol, args, sc->type_names[T_PAIR])); -} - -static s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_pair(p)) - return(cdr(p)); - return(sole_arg_method_or_bust(sc, p, sc->cdr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - - -static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args) -{ - #define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val" - #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) - - s7_pointer p = car(args); - if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_cdr_symbol, args, sc->type_names[T_PAIR], 1)); - set_cdr(p, cadr(args)); - return(cdr(p)); -} - -static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_cdr_symbol, set_plist_1(sc, p1), sc->type_names[T_PAIR], 1)); - set_cdr(p1, p2); - return(p2); -} - -static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_cdr(sc, p1, p2));} - - -/* -------- caar --------*/ -static s7_pointer g_caar(s7_scheme *sc, s7_pointer args) -{ - #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1" - #define Q_caar sc->pl_p - - s7_pointer lst = car(args); - /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, lst, car_a_list_string); - return(caar(lst)); - -} - -static s7_pointer caar_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(car(p)))) return(caar(p)); - if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, p, car_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->caar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - - -/* -------- cadr --------*/ -static s7_pointer g_cadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2" - #define Q_cadr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, lst, cdr_a_list_string); - return(cadr(lst)); -} - -static s7_pointer cadr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p)))) return(cadr(p)); - if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, p, cdr_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->cadr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - -static s7_pointer g_list_ref_at_1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lst = car(args); - if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); - if (!is_pair(cdr(lst))) out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string); - return(cadr(lst)); -} - - -/* -------- cdar -------- */ -static s7_pointer g_cdar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)" - #define Q_cdar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, lst, car_a_list_string); - return(cdar(lst)); -} - -static s7_pointer cdar_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(car(p)))) return(cdar(p)); - if (!is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, p, car_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->cdar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - - -/* -------- cddr -------- */ -static s7_pointer g_cddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)" - #define Q_cddr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, lst, cdr_a_list_string); - return(cddr(lst)); -} - -static s7_pointer cddr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p)))) return(cddr(p)); - if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, p, cdr_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->cddr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - -/* -------- caaar -------- */ -static s7_pointer caaar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, caar_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, caar_a_list_string); - return(caaar(lst)); -} - -static s7_pointer g_caaar(s7_scheme *sc, s7_pointer args) -{ - #define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" - #define Q_caaar sc->pl_p - return(caaar_p_p(sc, car(args))); -} - -/* -------- caadr -------- */ -static s7_pointer caadr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cadr(p)))) return(caadr(p)); - if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->caadr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); - if (!is_pair(cdr(p))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, p, cdr_a_list_string); - sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, p, cadr_a_list_string); - return(NULL); -} - -static s7_pointer g_caadr(s7_scheme *sc, s7_pointer args) -{ - #define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" - #define Q_caadr sc->pl_p - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, cadr_a_list_string); - return(caadr(lst)); -} - -/* -------- cadar -------- */ -static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args) -{ - #define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" - #define Q_cadar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, cdar_a_list_string); - return(cadar(lst)); -} - -static s7_pointer cadar_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(car(p))) && (is_pair(cdar(p)))) return(cadar(p)); - if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->cadar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); - if (!is_pair(car(p))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, p, car_a_list_string); - sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, p, cdar_a_list_string); - return(NULL); -} - -/* -------- cdaar -------- */ -static s7_pointer cdaar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, caar_a_list_string); - return(cdaar(lst)); -} - -static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" - #define Q_cdaar sc->pl_p - return(cdaar_p_p(sc, car(args))); -} - -/* -------- caddr -------- */ -static s7_pointer g_caddr(s7_scheme *sc, s7_pointer args) -{ - #define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" - #define Q_caddr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, cddr_a_list_string); - return(caddr(lst)); -} - -static s7_pointer caddr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p)))) return(caddr(p)); - if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->caddr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); - if (!is_pair(cdr(p))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, p, cdr_a_list_string); - sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, p, cddr_a_list_string); - return(NULL); -} - -static s7_pointer g_list_ref_at_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lst = car(args); - if (!is_pair(lst)) - return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); - if ((!is_pair(cdr(lst))) || (!is_pair(cddr(lst)))) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string); - return(caddr(lst)); -} - - -/* -------- cdddr -------- */ -static s7_pointer cdddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, cddr_a_list_string); - return(cdddr(lst)); -} - -static s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" - #define Q_cdddr sc->pl_p - return(cdddr_p_p(sc, car(args))); -} - -/* -------- cdadr -------- */ -static s7_pointer cdadr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, cadr_a_list_string); - return(cdadr(lst)); -} - -static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" - #define Q_cdadr sc->pl_p - return(cdadr_p_p(sc, car(args))); -} - -/* -------- cddar -------- */ -static s7_pointer cddar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, cdar_a_list_string); - return(cddar(lst)); -} - -static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args) -{ - #define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" - #define Q_cddar sc->pl_p - return(cddar_p_p(sc, car(args))); -} - -/* -------- caaaar -------- */ -static s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args) -{ - #define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1" - #define Q_caaaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, caar_a_list_string); - if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, caaar_a_list_string); - return(caaaar(lst)); -} - -/* -------- caaadr -------- */ -static s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args) -{ - #define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2" - #define Q_caaadr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, cadr_a_list_string); - if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, caadr_a_list_string); - return(caaadr(lst)); -} - -/* -------- caadar -------- */ -static s7_pointer g_caadar(s7_scheme *sc, s7_pointer args) -{ - #define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2" - #define Q_caadar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, cdar_a_list_string); - if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, cadar_a_list_string); - return(caadar(lst)); -} - -/* -------- cadaar -------- */ -static s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2" - #define Q_cadaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, caar_a_list_string); - if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, cdaar_a_list_string); - return(cadaar(lst)); -} - -/* -------- caaddr -------- */ - -static s7_pointer caaddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, cddr_a_list_string); - if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, caddr_a_list_string); - return(caaddr(lst)); -} - -static s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args) -{ - #define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3" - #define Q_caaddr sc->pl_p - return(caaddr_p_p(sc, car(args))); -} - -/* -------- cadddr -------- */ -static s7_pointer cadddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cddr_a_list_string); - if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cdddr_a_list_string); - return(cadddr(lst)); -} - -static s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4" - #define Q_cadddr sc->pl_p - return(cadddr_p_p(sc, car(args))); -} - -/* -------- cadadr -------- */ -static s7_pointer cadadr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cadr_a_list_string); - if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cdadr_a_list_string); - return(cadadr(lst)); -} - -static s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3" - #define Q_cadadr sc->pl_p - return(cadadr_p_p(sc, car(args))); -} - -/* -------- caddar -------- */ -static s7_pointer caddar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, cdar_a_list_string); - if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, cddar_a_list_string); - return(caddar(lst)); -} - -static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args) -{ - #define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3" - #define Q_caddar sc->pl_p - return(caddar_p_p(sc, car(args))); -} - -/* -------- cdaaar -------- */ -static s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)" - #define Q_cdaaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, caar_a_list_string); - if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, caaar_a_list_string); - return(cdaaar(lst)); -} - -/* -------- cdaadr -------- */ -static s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)" - #define Q_cdaadr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, cadr_a_list_string); - if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, caadr_a_list_string); - return(cdaadr(lst)); -} - -/* -------- cdadar -------- */ -static s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)" - #define Q_cdadar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, cdar_a_list_string); - if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, cadar_a_list_string); - return(cdadar(lst)); -} - -/* -------- cddaar -------- */ -static s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)" - #define Q_cddaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, caar_a_list_string); - if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, cdaar_a_list_string); - return(cddaar(lst)); -} - -/* -------- cdaddr -------- */ -static s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)" - #define Q_cdaddr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaddr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, cddr_a_list_string); - if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, caddr_a_list_string); - return(cdaddr(lst)); -} - -/* -------- cddddr -------- */ - -static s7_pointer cddddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cddr_a_list_string); - if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cdddr_a_list_string); - return(cddddr(lst)); -} - -static s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)" - #define Q_cddddr sc->pl_p - return(cddddr_p_p(sc, car(args))); -} - - -/* -------- cddadr -------- */ -static s7_pointer cddadr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cadr_a_list_string); - if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cdadr_a_list_string); - return(cddadr(lst)); -} - -static s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)" - #define Q_cddadr sc->pl_p - return(cddadr_p_p(sc, car(args))); -} - - -/* -------- cdddar -------- */ - -static s7_pointer cdddar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, cdar_a_list_string); - if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, cddar_a_list_string); - return(cdddar(lst)); -} - -static s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)" - #define Q_cdddar sc->pl_p - return(cdddar_p_p(sc, car(args))); -} - -/* -------------------------------- assoc assv assq -------------------------------- */ -s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - while (true) - { - /* we can blithely take the car of anything, since we're not treating it as an object, - * then if we get a bogus match, the following check that caar made sense ought to catch it. - * if car(#) = # (initialization time), then cdr(nil)->unspec - * and subsequent caar(unspec)->unspec so we could forgo half the is_pair checks below. - * This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose. - */ - LOOP_8(if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x)); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - return((is_pair(y)) ? s7_assq(sc, x, y) : - ((is_null(y)) ? sc->F : - method_or_bust_pp(sc, y, sc->assq_symbol, x, y, an_association_list_string, 2))); -} - -static s7_pointer g_assq(s7_scheme *sc, s7_pointer args) -{ - #define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist" - #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol) - return(assq_p_pp(sc, car(args), cadr(args))); - /* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc: - * (assq #f '(#f 2 . 3)) -> #f, (assoc #f '(#f 2 . 3)) -> 'error - */ -} - -static s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_pointer z; - if (!is_pair(y)) - { - if (is_null(y)) return(sc->F); - return(method_or_bust_pp(sc, y, sc->assv_symbol, x, y, an_association_list_string, 2)); - } - if (is_simple(x)) - return(s7_assq(sc, x, y)); - - z = y; - while (true) - { - /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */ - if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) return(car(y)); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) return(car(y)); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - z = cdr(z); - if (z == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static s7_pointer g_assv(s7_scheme *sc, s7_pointer args) /* g_assv is called by g_assoc below */ -{ - #define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist" - #define Q_assv Q_assq - return(assv_p_pp(sc, car(args), cadr(args))); -} - -s7_pointer s7_assoc(s7_scheme *sc, s7_pointer sym, s7_pointer lst) -{ - s7_pointer x, y; - if (!is_pair(lst)) - return(sc->F); - x = lst; - y = lst; - while (true) - { - if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args); -static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args); -static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr); - -static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - if (is_string(obj)) - { - while (true) - { - if (is_pair(car(x))) - { - s7_pointer val = caar(x); - if ((val == obj) || - ((is_string(val)) && - (scheme_strings_are_equal(obj, val)))) - return(car(x)); - } - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if (is_pair(car(x))) - { - s7_pointer val = caar(x); - if ((val == obj) || - ((is_string(val)) && - (scheme_strings_are_equal(obj, val)))) - return(car(x)); - } - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); - } - while (true) - { - if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static bool closure_has_two_normal_args(s7_scheme *sc, s7_pointer eq_func) /* sc for is_null */ -{ - return((is_closure(eq_func)) && - (is_pair(closure_args(eq_func))) && - (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ - (is_null(cddr(closure_args(eq_func))))); /* arity == 2 */ -} - -static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args) -{ - #define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\ -If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?" - #define Q_assoc s7_make_signature(sc, 4, \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), \ - sc->T, sc->is_list_symbol, sc->is_procedure_symbol) - s7_pointer x = cadr(args), obj, eq_func = NULL; - - if (!is_null(x)) - { - if (!is_pair(x)) - return(method_or_bust(sc, x, sc->assoc_symbol, args, an_association_list_string, 2)); - if (!is_pair(car(x))) - wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string); /* we're assuming caar below so it better exist */ - } - if (is_pair(cddr(args))) - { - s7_pointer y; - eq_func = caddr(args); - /* here we know x is a pair, but need to protect against circular lists */ - /* I wonder if the assoc equality function should get the cons, not just caar? */ - - if (is_safe_c_function(eq_func)) - { - s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(is_null(x) ? sc->F : s7_assq(sc, car(args), x)); - if (func == g_is_eqv) return(assv_p_pp(sc, car(args), x)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); - set_car(sc->t2_1, car(args)); - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); - x = cdr(x); - if ((!is_pair(x)) || (x == slow)) return(sc->F); - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); - } - return(sc->F); - } - if (closure_has_two_normal_args(sc, eq_func)) - { - s7_pointer body = closure_body(eq_func); - if (is_null(x)) return(sc->F); - if (is_null(cdr(body))) - { - s7_pfunc func; - sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); - func = s7_bool_optimize(sc, body); - if (func) - { - s7_pointer slowx = x; - opt_info *o = sc->opts[0]; - s7_pointer b = next_slot(let_slots(sc->curlet)); - while (true) - { - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - slowx = cdr(slowx); - if (x == slowx) return(sc->F); - } - return(sc->F); - }}} - - /* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the - * assoc point, leaving the op_eval_done on the stack, causing s7 to quit. - */ - if (type(eq_func) < T_CONTINUATION) - return(sole_arg_method_or_bust_p(sc, eq_func, sc->assoc_symbol, a_procedure_string)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); - if (is_null(x)) return(sc->F); - if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) clear_all_optimizations(sc, closure_body(eq_func)); - y = list_1(sc, copy_proper_list(sc, args)); - set_opt1_fast(y, x); - set_opt2_slow(y, x); - push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, y), eq_func); - if (needs_copied_args(eq_func)) - push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), caar(x)), eq_func); - else - { - set_car(sc->t2_1, car(args)); - set_car(sc->t2_2, caar(x)); - push_stack(sc, OP_APPLY, sc->t2_1, eq_func); - } - return(sc->unspecified); - } - if (is_null(x)) return(sc->F); - obj = car(args); - if (is_simple(obj)) - return(s7_assq(sc, obj, x)); - return(assoc_1(sc, obj, x)); -} - -static s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (!is_pair(x)) - { - if (is_null(x)) return(sc->F); - return(method_or_bust(sc, x, sc->assoc_symbol, set_plist_2(sc, obj, x), an_association_list_string, 2)); - } - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string); - if (is_simple(obj)) return(s7_assq(sc, obj, x)); - return(assoc_1(sc, obj, x)); -} - -static bool op_assoc_if(s7_scheme *sc) -{ - s7_pointer orig_args = car(sc->args); - /* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison - * (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =) - */ - if (sc->value != sc->F) /* previous comparison was not #f -- return (car list) */ - { - sc->value = car(opt1_fast(orig_args)); - return(true); - } - if (!is_pair(cdr(opt1_fast(orig_args)))) /* (assoc 3 '((1 . 2) . 3) =) or nil */ - { - sc->value = sc->F; - return(true); - } - set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */ - - if (sc->cur_op == OP_ASSOC_IF1) - { - /* circular list check */ - if (opt1_fast(orig_args) == opt2_slow(orig_args)) - { - sc->value = sc->F; - return(true); - } - set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */ - push_stack_direct(sc, OP_ASSOC_IF); - } - else push_stack_direct(sc, OP_ASSOC_IF1); - - if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "assoc: second argument is not an alist: ~S", 42), orig_args)); - /* not sure about this -- we could simply skip the entry both here and in g_assoc - * (assoc 1 '((2 . 2) 3)) -> #f - * (assoc 1 '((2 . 2) 3) =) -> error currently - */ - if (needs_copied_args(sc->code)) - sc->args = list_2(sc, caar(orig_args), caar(opt1_fast(orig_args))); - else sc->args = set_plist_2(sc, caar(orig_args), caar(opt1_fast(orig_args))); - return(false); -} - -static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args == 3) && (is_normal_symbol(cadddr(expr)))) - { - if (cadddr(expr) == sc->is_eq_symbol) return(global_value(sc->assq_symbol)); - if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->assv_symbol)); - } - return(f); -} - - -/* ---------------- member, memv, memq ---------------- */ -s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - return((is_pair(y)) ? s7_memq(sc, x, y) : - ((is_null(y)) ? sc->F : method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2))); -} - -static s7_pointer g_memq(s7_scheme *sc, s7_pointer args) -{ - #define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?" - #define Q_memq sc->pl_tl - - s7_pointer x = car(args); - s7_pointer y = cadr(args); - if (is_pair(y)) - return(s7_memq(sc, x, y)); - if (is_null(y)) - return(sc->F); - return(method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2)); -} - -/* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end */ -/* if memq's list is a quoted list, it won't be changing, so we can tell ahead of time that it is a proper list, and what its length is */ - -static s7_pointer g_memq_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = cadr(args); - s7_pointer obj = car(args); - if (obj == car(x)) return(x); - return((obj == cadr(x)) ? cdr(x) : sc->F); -} - -static s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (obj == car(x)) return(x); - return((obj == cadr(x)) ? cdr(x) : sc->F); -} - -static s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (obj == car(x)) return(x); - if (obj == cadr(x)) return(cdr(x)); - return((obj == caddr(x)) ? cddr(x) : sc->F); -} - -static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = cadr(args); - s7_pointer obj = car(args); - while (true) - { - if (obj == car(x)) return(x); - x = cdr(x); - if (obj == car(x)) return(x); - x = cdr(x); - if (obj == car(x)) return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - } - return(sc->F); -} - -static s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x)); - if (!is_pair(x)) return(sc->F); - } - return(sc->F); -} - -static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) {return(memq_4_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args) -{ - /* no circular list check needed in this case */ - s7_pointer x = cadr(args); - s7_pointer obj = car(args); - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - } - return(sc->F); -} - -static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - s7_pointer lst = caddr(expr); - if ((is_proper_quote(sc, lst)) && - (is_pair(cadr(lst)))) - { - s7_int len = s7_list_length(sc, cadr(lst)); - if (len > 0) - { - if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */ - return(sc->memq_2); - if ((len % 4) == 0) - return(sc->memq_4); - return(((len % 3) == 0) ? sc->memq_3 : sc->memq_any); - }} - return(f); -} - -static bool numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ -#if WITH_GMP - if ((is_big_number(a)) || (is_big_number(b))) - return(big_numbers_are_eqv(sc, a, b)); - if (type(a) != type(b)) return(false); -#endif - /* if (type(a) != type(b)) return(false); */ /* (eqv? 1 1.0) -> #f! but assume that we've checked types already */ - - /* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */ - if (is_t_integer(a)) return(integer(a) == integer(b)); - if (is_t_real(a)) return(real(a) == real(b)); /* NaNs are not equal to anything including themselves */ - if (is_t_ratio(a)) return((numerator(a) == numerator(b)) && (denominator(a) == denominator(b))); - if (!is_t_complex(a)) return(false); - return((real_part(a) == real_part(b)) && (imag_part(a) == imag_part(b))); -} - -static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; -#if (!WITH_GMP) - uint8_t obj_type = type(obj); -#endif - while (true) - { -#if WITH_GMP - LOOP_4(if ((is_number(car(x))) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); -#else - LOOP_4(if ((type(car(x)) == obj_type) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); -#endif - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_pointer z; - if (!is_pair(y)) - { - if (is_null(y)) return(sc->F); - return(method_or_bust_pp(sc, y, sc->memv_symbol, x, y, a_list_string, 2)); - } - if (is_simple(x)) return(s7_memq(sc, x, y)); - if (is_number(x)) return(memv_number(sc, x, y)); - - z = y; - while (true) - { - if (s7_is_eqv(sc, x, car(y))) return(y); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - if (s7_is_eqv(sc, x, car(y))) return(y); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - z = cdr(z); - if (z == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static s7_pointer g_memv(s7_scheme *sc, s7_pointer args) -{ - #define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?" - #define Q_memv sc->pl_tl - return(memv_p_pp(sc, car(args), cadr(args))); -} - - -s7_pointer s7_member(s7_scheme *sc, s7_pointer sym, s7_pointer lst) -{ - for (s7_pointer x = lst; is_pair(x); x = cdr(x)) - if (s7_is_equal(sc, sym, car(x))) - return(x); - return(sc->F); -} - -static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - if (is_string(obj)) - while (true) - { - if ((obj == car(x)) || - ((is_string(car(x))) && - (scheme_strings_are_equal(obj, car(x))))) - return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((obj == car(x)) || - ((is_string(car(x))) && - (scheme_strings_are_equal(obj, car(x))))) - return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } - else - while (true) - { - LOOP_4(if (s7_is_equal(sc, obj, car(x))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static bool p_to_b(opt_info *p); - -static s7_pointer g_member(s7_scheme *sc, s7_pointer args) -{ - #define H_member "(member obj list (func #f)) looks for obj in list and returns the list from that point if it is found, otherwise #f. \ -member uses equal? If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?" - #define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol) - - /* this could be extended to accept sequences: - * (member #\a "123123abnfc" char=?) -> "abnfc" - * (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication - * (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table? - * the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t) - * should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil - * - * here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so. - */ - s7_pointer x = cadr(args), obj; - - if ((!is_pair(x)) && (!is_null(x))) - return(method_or_bust(sc, x, sc->member_symbol, args, a_list_string, 2)); - - if (is_not_null(cddr(args))) - { - s7_pointer y, eq_func = caddr(args); - - if (is_safe_c_function(eq_func)) - { - s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(is_null(x) ? sc->F : s7_memq(sc, car(args), x)); - if (func == g_is_eqv) return(g_memv(sc, args)); - if (func == g_less) - func = g_less_2; - else - if (func == g_greater) - func = g_greater_2; - else - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); - set_car(sc->t2_1, car(args)); - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(x); - } - return(sc->F); - } - - if (closure_has_two_normal_args(sc, eq_func)) - { - s7_pointer body = closure_body(eq_func); - if (is_null(x)) return(sc->F); - if ((!no_bool_opt(body)) && - (is_null(cdr(body)))) - { - s7_pfunc func; - sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); - func = s7_bool_optimize(sc, body); - if (func) - { - opt_info *o = sc->opts[0]; - s7_pointer b = next_slot(let_slots(sc->curlet)); - if (o->v[0].fb == p_to_b) - { - s7_pointer (*fp)(opt_info *o) = o->v[O_WRAP].fp; - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - slot_set_value(b, car(x)); - if (fp(o) != sc->F) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - slot_set_value(b, car(x)); - if (fp(o) != sc->F) return(x); - }} - else - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - slot_set_value(b, car(x)); - if (o->v[0].fb(o)) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - slot_set_value(b, car(x)); - if (o->v[0].fb(o)) return(x); - } - return(sc->F); - } - set_no_bool_opt(body); - }} - if (type(eq_func) < T_CONTINUATION) - return(method_or_bust(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); - if (is_null(x)) return(sc->F); - if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) clear_all_optimizations(sc, closure_body(eq_func)); - y = list_1(sc, copy_proper_list(sc, args)); /* this could probably be handled with a counter cell (cdr here is unused) */ - set_opt1_fast(y, x); - set_opt2_slow(y, x); - push_stack(sc, OP_MEMBER_IF, list_1(sc, y), eq_func); - if (needs_copied_args(eq_func)) - push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), car(x)), eq_func); - else - { - set_car(sc->t2_1, car(args)); - set_car(sc->t2_2, car(x)); - push_stack(sc, OP_APPLY, sc->t2_1, eq_func); - } - return(sc->unspecified); - } - if (is_null(x)) return(sc->F); - obj = car(args); - if (is_simple(obj)) - return(s7_memq(sc, obj, x)); - /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer, but all the other cases are unlikely */ - if (is_number(obj)) - return(memv_number(sc, obj, x)); - return(member(sc, obj, x)); -} - -static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (is_null(x)) return(sc->F); - if (!is_pair(x)) return(method_or_bust(sc, x, sc->member_symbol, set_plist_2(sc, obj, x), a_list_string, 2)); - if (is_simple(obj)) return(s7_memq(sc, obj, x)); - if (is_number(obj)) return(memv_number(sc, obj, x)); - return(member(sc, obj, x)); -} - -static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args == 3) && (is_normal_symbol(cadddr(expr)))) - { - if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr, ops)); - if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol)); - } - return(f); -} - -static bool op_member_if(s7_scheme *sc) -{ - s7_pointer orig_args = car(sc->args); - /* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list), - * the extra indirection (list (list...)) is needed because call/cc copies arg lists - * value = result of comparison - */ - if (sc->value != sc->F) /* previous comparison was not #f -- return list */ - { - sc->value = opt1_fast(orig_args); - return(true); - } - if (!is_pair(cdr(opt1_fast(orig_args)))) /* no more args -- return #f */ - { - sc->value = sc->F; - return(true); - } - set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */ - - if (sc->cur_op == OP_MEMBER_IF1) - { - /* circular list check */ - if (opt1_fast(orig_args) == opt2_slow(orig_args)) - { - sc->value = sc->F; - return(true); - } - set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */ - push_stack_direct(sc, OP_MEMBER_IF); - } - else push_stack_direct(sc, OP_MEMBER_IF1); - - if (needs_copied_args(sc->code)) - sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args))); - else sc->args = set_plist_2(sc, caar(orig_args), car(opt1_fast(orig_args))); - return(false); -} - - -/* -------------------------------- list -------------------------------- */ -static s7_pointer g_list(s7_scheme *sc, s7_pointer args) -{ - #define H_list "(list ...) returns its arguments in a list" - #define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T) - return(copy_proper_list(sc, args)); -} - -static s7_pointer g_list_0(s7_scheme *sc, s7_pointer args) {return(sc->nil);} -static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args) {return(list_1(sc, car(args)));} -static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args) {return(list_2(sc, car(args), cadr(args)));} -static s7_pointer g_list_3(s7_scheme *sc, s7_pointer args) {return(list_3(sc, car(args), cadr(args), caddr(args)));} -static s7_pointer g_list_4(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = cddr(args); - return(list_4(sc, car(args), cadr(args), car(p), cadr(p))); -} - -static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 0) return(sc->list_0); - if (args == 1) return(sc->list_1); - if (args == 2) return(sc->list_2); - if (args == 3) return(sc->list_3); - return((args == 4) ? sc->list_4 : f); -} - -static s7_pointer list_p_p(s7_scheme *sc, s7_pointer p1) {return(list_1(sc, sc->value = p1));} -static s7_pointer list_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(list_2(sc, p1, p2));} -static s7_pointer list_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(list_3(sc, p1, p2, p3));} -/* if the GC sees a free cell here, protect it in the caller, not here, but sometimes the GC is called here! */ - -static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer lst) -{ - s7_pointer p = lst; - for (int32_t i = 1; is_pair(p); p = cdr(p), i++) - if (!s7_is_valid(sc, car(p))) - s7_warn(sc, 256, "bad argument (#%d) to %s: %p\n", i, caller, car(p)); -} - -s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...) -{ - va_list ap; - s7_pointer p; - if (num_values == 0) - return(sc->nil); - sc->w = make_list(sc, num_values, sc->unused); - p = sc->w; - va_start(ap, num_values); - for (s7_int i = 0; i < num_values; i++, p = cdr(p)) - set_car(p, va_arg(ap, s7_pointer)); - va_end(ap); - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_list", sc->w); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...) /* arglist should be NULL terminated */ -{ - s7_int i = 0; - va_list ap; - s7_pointer p; - - if (num_values == 0) - return(sc->nil); - - sc->w = make_list(sc, num_values, sc->unused); - va_start(ap, num_values); - for (s7_pointer q = sc->w; i < num_values; i++, q = cdr(q)) - { - p = va_arg(ap, s7_pointer); - if (!p) - { - va_end(ap); - wrong_number_of_args_error_nr(sc, "not enough arguments for s7_list_nl: ~S", sc->w); /* ideally we'd sublist this and append extra below */ - } - set_car(q, p); - } - p = va_arg(ap, s7_pointer); - va_end(ap); - if (p) wrong_number_of_args_error_nr(sc, "too many arguments for s7_list_nl: ~S", sc->w); - - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_list_nl", sc->w); - - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer safe_list_1(s7_scheme *sc) -{ - if (!list_is_in_use(sc->safe_lists[1])) - { - sc->current_safe_list = 1; - set_list_in_use(sc->safe_lists[1]); - return(sc->safe_lists[1]); - } - return(cons(sc, sc->nil, sc->nil)); -} - -static s7_pointer safe_list_2(s7_scheme *sc) -{ - if (!list_is_in_use(sc->safe_lists[2])) - { - sc->current_safe_list = 2; - set_list_in_use(sc->safe_lists[2]); - return(sc->safe_lists[2]); - } - return(cons_unchecked(sc, sc->nil, list_1(sc, sc->nil))); -} - -static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) -{ - if (num_args < NUM_SAFE_LISTS) - { - sc->current_safe_list = num_args; - if (!is_pair(sc->safe_lists[num_args])) - sc->safe_lists[num_args] = semipermanent_list(sc, num_args); - if (!list_is_in_use(sc->safe_lists[num_args])) - { - set_list_in_use(sc->safe_lists[num_args]); - return(sc->safe_lists[num_args]); - }} - return(make_big_list(sc, num_args, sc->nil)); -} - -static inline s7_pointer safe_list_if_possible(s7_scheme *sc, s7_int num_args) -{ - if ((num_args < NUM_SAFE_PRELISTS) && - (!list_is_in_use(sc->safe_lists[num_args]))) - { - sc->current_safe_list = num_args; - set_list_in_use(sc->safe_lists[num_args]); - return(sc->safe_lists[num_args]); - } - return(make_safe_list(sc, num_args)); -} - -static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) -{ - s7_pointer tp = sc->nil, np = NULL, pp; - - /* we know here that car(args) is a list and cdr(args) is not nil; this function does not check sc->max_list_length; called only in g_append */ - s7_gc_protect_via_stack(sc, args); - for (s7_pointer y = args; is_pair(y); y = cdr(y)) /* arglist so not dotted */ - { - s7_pointer p = car(y), func; - - if ((has_active_methods(sc, p)) && - ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined)) - { - unstack(sc); - return(s7_apply_function(sc, func, (is_null(tp)) ? y : set_ulist_1(sc, tp, y))); - } - if (is_null(cdr(y))) - { - if (is_null(tp)) - { - /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that - * (what does "share structure" mean when there are no structures? I assume they mean sequences) - */ - unstack(sc); - return(p); - } - if (is_list(p)) - set_cdr(np, p); - else - { - s7_int len = sequence_length(sc, p); - if (len > 0) - set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); - else - if (len < 0) - set_cdr(np, p); - } - sc->temp8 = sc->unused; - unstack(sc); - return(tp); - } - - if (!is_sequence(p)) - { - unstack(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); - } - if (!sequence_is_empty(sc, p)) - { - if (is_pair(p)) - { - if (!s7_is_proper_list(sc, p)) - { - sc->temp8 = sc->unused; - unstack(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_proper_list_string); - } - if (is_null(tp)) - { - tp = list_1(sc, car(p)); - np = tp; - sc->temp8 = tp; /* GC protect? */ - pp = cdr(p); - } - else pp = p; - for (; is_pair(pp); pp = cdr(pp), np = cdr(np)) - set_cdr(np, list_1(sc, car(pp))); - } - else - { - s7_int len = sequence_length(sc, p); - if (len > 0) - { - if (is_null(tp)) - { - tp = s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))); - np = tp; - sc->temp8 = tp; - } - else set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); - for (; is_pair(cdr(np)); np = cdr(np)); - } - else - if (len < 0) - { - unstack(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); - }}}} - unstack(sc); - return(tp); -} - -static s7_pointer append_in_place(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* tack b onto the end of a without copying either -- 'a' is changed! */ - s7_pointer p; - if (is_null(a)) return(b); - p = a; - while (is_not_null(cdr(p))) p = cdr(p); - set_cdr(p, b); - return(a); -} - - -/* -------------------------------- vectors -------------------------------- */ -bool s7_is_vector(s7_pointer p) {return(is_any_vector(p));} -bool s7_is_float_vector(s7_pointer p) {return(is_float_vector(p));} -bool s7_is_int_vector(s7_pointer p) {return(is_int_vector(p));} -bool s7_is_byte_vector(s7_pointer p) {return(is_byte_vector(p));} - -static bool is_byte_vector_b_p(s7_pointer b) {return(is_byte_vector(b));} - -s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));} - -static s7_pointer normal_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - vector_element(vec, loc) = val; - return(val); -} - -static s7_pointer typed_vector_typer_symbol(s7_scheme *sc, s7_pointer p) -{ - s7_pointer typer = typed_vector_typer(p); - return((is_c_function(typer)) ? c_function_symbol(typer) : find_closure(sc, typer, closure_let(typer))); -} - -static const char *typed_vector_typer_name(s7_scheme *sc, s7_pointer p) -{ - s7_pointer typer = typed_vector_typer(p); - return((is_c_function(typer)) ? c_function_name(typer) : symbol_name(typed_vector_typer_symbol(sc, p))); -} - -static const char *make_type_name(s7_scheme *sc, const char *name, article_t article); -static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg); - -static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg); - -static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port) -{ - const char *setter = make_type_name(sc, typed_vector_typer_name(sc, vect), NO_ARTICLE); - port_write_string(port)(sc, setter, safe_strlen(setter), port); -} - -static noreturn void typed_vector_type_error_nr(s7_scheme *sc, s7_pointer vec, s7_pointer val) -{ - const char *descr = typed_vector_typer_name(sc, vec); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "vector-set! third argument ~$, is ~A, but the vector's element type checker, ~A, rejects it", 91), - val, type_name_string(sc, val), wrap_string(sc, descr, safe_strlen(descr)))); -} - -static inline s7_pointer typed_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - if ((sc->safety >= NO_SAFETY) && - (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) == sc->F)) - typed_vector_type_error_nr(sc, vec, val); - vector_element(vec, loc) = val; - return(val); -} - -static s7_pointer normal_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(vector_element(vec, loc));} -static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_integer(sc, int_vector(vec, loc)));} -static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_real(sc, float_vector(vec, loc)));} -static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer bv, s7_int loc) {return(small_int(byte_vector(bv, loc)));} - -static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - if (s7_is_integer(val)) - int_vector(vec, loc) = s7_integer_clamped_if_gmp(sc, val); - else wrong_type_error_nr(sc, sc->int_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]); - return(val); -} - -static s7_pointer float_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!"); - return(val); -} - -static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val) -{ - s7_int byte; - if (!s7_is_integer(val)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]); - byte = s7_integer_clamped_if_gmp(sc, val); - if ((byte < 0) || (byte >= 256)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, wrap_string(sc, "a byte", 6)); - byte_vector(str, loc) = (uint8_t)byte; - return(val); -} - -static block_t *mallocate_empty_block(s7_scheme *sc) -{ - block_t *b; - b = mallocate_block(sc); - block_data(b) = NULL; - block_info(b) = NULL; - return(b); -} - -#define mallocate_vector(Sc, Len) ((Len) > 0) ? inline_mallocate(Sc, Len) : mallocate_empty_block(Sc) - -static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ -{ - s7_pointer x; - block_t *b = mallocate_vector(sc, len * sizeof(s7_pointer)); - new_cell(sc, x, T_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = b; - vector_elements(x) = (s7_pointer *)block_data(b); - vector_set_dimension_info(x, NULL); - vector_getter(x) = normal_vector_getter; - vector_setter(x) = normal_vector_setter; - add_vector(sc, x); - return(x); -} - -static inline s7_pointer make_simple_float_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ -{ - s7_pointer x; - block_t *b = mallocate_vector(sc, len * sizeof(s7_double)); - new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = b; - float_vector_floats(x) = (s7_double *)block_data(b); - vector_set_dimension_info(x, NULL); - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - add_vector(sc, x); - return(x); -} - -static inline s7_pointer make_simple_int_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ -{ - s7_pointer x; - block_t *b = mallocate_vector(sc, len * sizeof(s7_int)); - new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = b; - int_vector_ints(x) = (s7_int *)block_data(b); - vector_set_dimension_info(x, NULL); - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - add_vector(sc, x); - return(x); -} - -static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len) -{ - s7_pointer x; - block_t *b = inline_mallocate(sc, len); - new_cell(sc, x, T_BYTE_VECTOR | T_SAFE_PROCEDURE); - vector_block(x) = b; - byte_vector_bytes(x) = (uint8_t *)block_data(b); - vector_length(x) = len; - vector_set_dimension_info(x, NULL); - vector_getter(x) = byte_vector_getter; - vector_setter(x) = byte_vector_setter; - add_vector(sc, x); - return(x); -} - -static Vectorized void normal_vector_fill(s7_pointer vec, s7_pointer obj) -{ - s7_pointer *orig = vector_elements(vec); - s7_int len = vector_length(vec), i, left; - if (len == 0) return; - /* splitting out this part made no difference in speed; type check of obj is handled elsewhere */ - left = len - 8; - i = 0; - while (i <= left) - LOOP_8(orig[i++] = obj); - for (; i < len; i++) - orig[i] = obj; -} - -static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t typ) -{ - s7_pointer x; - - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_vector_symbol, int_one, wrap_integer(sc, len), (len < 0) ? it_is_negative_string : it_is_too_large_string); - - /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */ - new_cell(sc, x, typ | T_SAFE_PROCEDURE); - vector_length(x) = len; - if (len == 0) - { - vector_block(x) = mallocate_empty_block(sc); - any_vector_elements(x) = NULL; - if (typ == T_VECTOR) set_has_simple_elements(x); - } - else - if (typ == T_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer)); - vector_block(x) = b; - vector_elements(x) = (s7_pointer *)block_data(b); - vector_getter(x) = normal_vector_getter; - vector_setter(x) = normal_vector_setter; - if (filled) normal_vector_fill(x, sc->nil); - } - else - if (typ == T_FLOAT_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_double)); - vector_block(x) = b; - float_vector_floats(x) = (s7_double *)block_data(b); - if (filled) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); - } - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - } - else - if (typ == T_INT_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_int)); - vector_block(x) = b; - int_vector_ints(x) = (s7_int *)block_data(b); - if (filled) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); - } - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - } - else /* byte-vector */ - { - block_t *b = mallocate(sc, len); - vector_block(x) = b; - byte_vector_bytes(x) = (uint8_t *)block_data(b); - vector_getter(x) = byte_vector_getter; - vector_setter(x) = byte_vector_setter; - if (filled) - { - if (STEP_64(len)) - memclr64((void *)(byte_vector_bytes(x)), len); - else memclr((void *)(byte_vector_bytes(x)), len); - }} - vector_set_dimension_info(x, NULL); - return(x); -} - -#define FILLED true -#define NOT_FILLED false - -s7_pointer s7_make_vector(s7_scheme *sc, s7_int len) -{ - s7_pointer v = make_vector_1(sc, len, FILLED, T_VECTOR); - add_vector(sc, v); - return(v); -} - -s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill) -{ - s7_pointer vect = make_simple_vector(sc, len); - normal_vector_fill(vect, fill); - return(vect); -} - -static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */ -{ - vdims_t *v = (vdims_t *)mallocate_block(sc); - vdims_original(v) = sc->F; - vector_elements_should_be_freed(v) = false; - vdims_rank(v) = 1; - vdims_dims(v) = NULL; - vdims_offsets(v) = NULL; - return(v); -} - -static vdims_t *make_vdims(s7_scheme *sc, bool elements_should_be_freed, s7_int dims, s7_int *dim_info) -{ - vdims_t *v; - if ((dims == 1) && (!elements_should_be_freed)) - return(sc->wrap_only); - - if (dims > 1) - { - s7_int offset = 1; - v = (vdims_t *)mallocate(sc, dims * 2 * sizeof(s7_int)); - vdims_original(v) = sc->F; - vector_elements_should_be_freed(v) = elements_should_be_freed; - vdims_rank(v) = dims; - vdims_offsets(v) = (s7_int *)(vdims_dims(v) + dims); - for (s7_int i = 0; i < dims; i++) - vdims_dims(v)[i] = dim_info[i]; - for (s7_int i = dims - 1; i >= 0; i--) - { - vdims_offsets(v)[i] = offset; - offset *= vdims_dims(v)[i]; - } - return(v); - } - v = (vdims_t *)mallocate_block(sc); - vdims_original(v) = sc->F; - vector_elements_should_be_freed(v) = elements_should_be_freed; - vdims_rank(v) = 1; - vdims_dims(v) = NULL; - vdims_offsets(v) = NULL; - return(v); -} - -static s7_pointer make_any_vector(s7_scheme *sc, int32_t type, s7_int len, s7_int dims, s7_int *dim_info) -{ - s7_pointer p = make_vector_1(sc, len, FILLED, type); - if (dim_info) - { - vector_set_dimension_info(p, make_vdims(sc, false, dims, dim_info)); - add_multivector(sc, p); - } - else add_vector(sc, p); - return(p); -} - -s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_INT_VECTOR, len, dims, dim_info));} -s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_BYTE_VECTOR, len, dims, dim_info));} -s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_FLOAT_VECTOR, len, dims, dim_info));} -s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_VECTOR, len, dims, dim_info));} - -s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data) -{ - /* this wraps up a C-allocated/freed double array as an s7 vector */ - s7_pointer x; - block_t *b = mallocate_empty_block(sc); - new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_block(x) = b; - float_vector_floats(x) = data; - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - vector_length(x) = len; - if (!dim_info) - { - s7_int di[1]; - di[0] = len; - vector_set_dimension_info(x, make_vdims(sc, free_data, 1, di)); - } - else vector_set_dimension_info(x, make_vdims(sc, free_data, dims, dim_info)); - add_multivector(sc, x); - return(x); -} - - -/* -------------------------------- vector-fill! -------------------------------- */ -static Vectorized void float_vector_fill(s7_pointer vec, s7_double x) -{ - s7_int len = vector_length(vec); - if (len == 0) return; - if (x == 0.0) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(vec), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(vec), len * sizeof(s7_double)); - } - else - { - s7_int i = 0, left = len - 8; - s7_double *orig = float_vector_floats(vec); - while (i <= left) - LOOP_8(orig[i++] = x); - for (; i < len; i++) - orig[i] = x; - } -} - -static Vectorized void int_vector_fill(s7_pointer vec, s7_int k) -{ - s7_int len = vector_length(vec); - if (len == 0) return; - if (k == 0) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(vec), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(vec), len * sizeof(s7_int)); - } - else - { - s7_int i = 0, left = len - 8; - s7_int *orig = int_vector_ints(vec); - while (i <= left) - LOOP_8(orig[i++] = k); - for (; i < len; i++) - orig[i] = k; - } -} - -static void byte_vector_fill(s7_pointer vec, uint8_t byte) -{ - s7_int len = vector_length(vec); - if (len == 0) return; - if (byte > 0) - local_memset((void *)(byte_vector_bytes(vec)), byte, len); - else /* byte == 0 */ - if (STEP_64(len)) - memclr64((void *)(byte_vector_bytes(vec)), len); - else memclr((void *)(byte_vector_bytes(vec)), len); -} - -void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj) -{ - switch (type(vec)) - { - case T_FLOAT_VECTOR: - if (!is_real(obj)) - wrong_type_error_nr(sc, wrap_string(sc, "float-vector fill!", 18), 2, obj, sc->type_names[T_REAL]); - float_vector_fill(vec, s7_real(obj)); - break; - case T_INT_VECTOR: - if (!s7_is_integer(obj)) /* possibly a bignum */ - wrong_type_error_nr(sc, wrap_string(sc, "int-vector fill!", 16), 2, obj, sc->type_names[T_INTEGER]); - int_vector_fill(vec, s7_integer_clamped_if_gmp(sc, obj)); - break; - case T_BYTE_VECTOR: - if (!is_byte(obj)) - wrong_type_error_nr(sc, wrap_string(sc, "byte-vector fill!", 17), 2, obj, wrap_string(sc, "a byte", 6)); - byte_vector_fill(vec, (uint8_t)s7_integer_clamped_if_gmp(sc, obj)); - break; - case T_VECTOR: - default: - normal_vector_fill(vec, obj); - } -} - -static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - s7_pointer x = car(args), fill; - s7_int start = 0, end; - - if (!is_any_vector(x)) - { - check_method(sc, x, sc->vector_fill_symbol, args); - /* not two_methods (and fill!) here else we get stuff like: - * (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa" - */ - wrong_type_error_nr(sc, caller, 1, x, sc->type_names[T_VECTOR]); - } - if (is_immutable_vector(x)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, x)); - - fill = cadr(args); - - if ((is_typed_vector(x)) && - (typed_vector_typer_call(sc, x, set_plist_1(sc, fill)) == sc->F)) - { - const char *tstr = make_type_name(sc, typed_vector_typer_name(sc, x), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, wrap_string(sc, "vector fill!", 12), 2, fill, wrap_string(sc, tstr, safe_strlen(tstr))); - } - if (is_float_vector(x)) - { - if (!is_real(fill)) /* possibly a bignum */ - return(method_or_bust(sc, fill, caller, args, sc->type_names[T_REAL], 2)); - } - else - if ((is_int_vector(x)) || (is_byte_vector(x))) - { - if (!s7_is_integer(fill)) - return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2)); - if ((is_byte_vector(x)) && - ((s7_integer_clamped_if_gmp(sc, fill) < 0) || (s7_integer_clamped_if_gmp(sc, fill) > 255))) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~S second argument, ~S, should fit in an unsigned byte", 54), caller, fill)); - } - end = vector_length(x); - if (!is_null(cddr(args))) - { - s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(fill); - } - if (end == 0) return(fill); - - if ((start == 0) && (end == vector_length(x))) - s7_vector_fill(sc, x, fill); - else - if (is_normal_vector(x)) - for (s7_int i = start; i < end; i++) vector_element(x, i) = fill; - else - if (is_int_vector(x)) - { - s7_int k = s7_integer_clamped_if_gmp(sc, fill); - if (k == 0) - memclr((void *)(int_vector_ints(x) + start), (end - start) * sizeof(s7_int)); - else for (s7_int i = start; i < end; i++) int_vector(x, i) = k; - } - else - if (is_float_vector(x)) - { - s7_double y = s7_real(fill); - if (y == 0.0) - memclr((void *)(float_vector_floats(x) + start), (end - start) * sizeof(s7_double)); - else - { - s7_double *orig = float_vector_floats(x); - s7_int left = end - 8; - s7_int i = start; - while (i <= left) - LOOP_8(orig[i++] = y); - for (; i < end; i++) - orig[i] = y; - }} - else - if (is_byte_vector(x)) - { - uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill); - if (k == 0) - memclr((void *)(byte_vector_bytes(x) + start), end - start); - else local_memset((void *)(byte_vector_bytes(x) + start), k, end - start); - } - return(fill); -} - -#if (!WITH_PURE_S7) -/* -------------------------------- vector-fill! -------------------------------- */ -static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val" - #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol) - return(g_vector_fill_1(sc, sc->vector_fill_symbol, args)); -} - -/* -------------------------------- vector-append -------------------------------- */ -static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller); -static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer caller, s7_pointer source, s7_pointer args); - -static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args) -{ - /* returns a one-dimensional vector. To handle multidimensional vectors, we'd need to - * ensure all the dimensional data matches (rank, size of each dimension except the last etc), - * which is too much trouble. - */ - #define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments." - #define Q_vector_append sc->pcl_v - - s7_pointer p = args; - if (is_null(args)) - return(make_simple_vector(sc, 0)); - - if ((is_null(cdr(args))) && - (is_any_vector(car(args)))) - return(copy_source_no_dest(sc, sc->vector_append_symbol, car(args), args)); - - for (int32_t i = 0; is_pair(p); p = cdr(p), i++) - { - s7_pointer x = car(p); - if (!is_any_vector(x)) - { - if (has_active_methods(sc, x)) - { - s7_pointer func = find_method_with_let(sc, x, sc->vector_append_symbol); - if (func != sc->undefined) - { - int32_t k; - s7_pointer v, y; - if (i == 0) - return(s7_apply_function(sc, func, args)); - sc->temp9 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */ - for (k = 0, y = args, v = sc->temp9; k < i; k++, y = cdr(y), v = cdr(v)) - set_car(v, car(y)); - v = g_vector_append(sc, sc->temp9); - y = s7_apply_function(sc, func, set_ulist_1(sc, v, p)); - sc->temp9 = sc->unused; - return(y); - }} - wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, x, sc->type_names[T_VECTOR]); - }} - return(vector_append(sc, args, type(car(args)), sc->vector_append_symbol)); -} - -static s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - s7_pointer val; - sc->temp7 = list_2(sc, p1, p2); /* ideally this list would be stack_protected, avoiding temp7 (method call above) */ - val = g_vector_append(sc, sc->temp7); - sc->temp7 = sc->unused; - return(val); -} - -static s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - s7_pointer val; - sc->temp7 = list_3(sc, p1, p2, p3); - val = g_vector_append(sc, sc->temp7); - sc->temp7 = sc->unused; - return(val); -} -#endif - - -/* -------------------------------- vector-ref|set! -------------------------------- */ -s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index) -{ - if (index >= vector_length(vec)) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - return(vector_getter(vec)(sc, vec, index)); -} - -s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a) -{ - if (index >= vector_length(vec)) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, a)); - vector_setter(vec)(sc, vec, index, T_Ext(a)); - return(a); -} - -s7_pointer *s7_vector_elements(s7_pointer vec) {return(vector_elements(vec));} - -/* these are for s7.h */ -s7_int *s7_int_vector_elements(s7_pointer vec) {return(int_vector_ints(vec));} -s7_int s7_int_vector_ref(s7_pointer vec, s7_int index) {return(int_vector(vec, index));} -s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value) {int_vector(vec, index) = value; return(value);} - -uint8_t *s7_byte_vector_elements(s7_pointer vec) {return(byte_vector_bytes(vec));} -uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index) {return(byte_vector(vec, index));} -uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value) {byte_vector(vec, index) = value; return(value);} - -s7_double *s7_float_vector_elements(s7_pointer vec) {return(float_vector_floats(vec));} -s7_double s7_float_vector_ref(s7_pointer vec, s7_int index) {return(float_vector(vec, index));} -s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value) {float_vector(vec, index) = value; return(value);} - -s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size) -{ - if (dims_size <= 0) return(0); - if (vector_dimension_info(vec)) - { - s7_int lim = vector_ndims(vec); - if (lim > dims_size) lim = dims_size; - for (s7_int i = 0; i < lim; i++) dims[i] = vector_dimension(vec, i); - return(lim); - } - dims[0] = vector_length(vec); - return(1); -} - -s7_int s7_vector_dimension(s7_pointer vec, s7_int dim) -{ - if (vector_dimension_info(vec)) - return(vector_dimension(vec, dim)); - return((dim == 0) ? vector_length(vec) : -1); -} - -s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size) -{ - if (offs_size <= 0) return(0); - if (vector_dimension_info(vec)) - { - s7_int lim = vector_ndims(vec); - if (lim > offs_size) lim = offs_size; - for (s7_int i = 0; i < lim; i++) offs[i] = vector_offset(vec, i); - return(lim); - } - offs[0] = 1; - return(1); -} - - -static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_int indices, va_list ap) -{ - s7_int index, rank = vector_rank(vector); - if (rank != indices) - { - va_end(ap); - wrong_number_of_args_error_nr(sc, "s7_vector_ref_n: wrong number of indices: ~A", wrap_integer(sc, indices)); - } - if (rank == 1) - index = va_arg(ap, s7_int); - else - { - s7_int i; - s7_int *dimensions = vector_dimensions(vector); - s7_int *offsets = vector_offsets(vector); - for (i = 0, index = 0; i < indices; i++) - { - s7_int ind = va_arg(ap, s7_int); - if ((ind < 0) || (ind >= dimensions[i])) - { - va_end(ap); - out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i), wrap_integer(sc, ind), (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(-1); - } - index += (ind * offsets[i]); - }} - va_end(ap); - return(index); -} - -s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...) -{ - s7_int index; - va_list ap; - va_start(ap, indices); - index = flatten_multivector_indices(sc, vector, indices, ap); - return(vector_getter(vector)(sc, vector, index)); -} - -s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...) -{ - s7_int index; - va_list ap; - va_start(ap, indices); - index = flatten_multivector_indices(sc, vector, indices, ap); - if (is_typed_vector(vector)) - return(typed_vector_setter(sc, vector, index, value)); - return(vector_setter(vector)(sc, vector, index, value)); -} - - -/* -------------------------------- vector->list -------------------------------- */ -s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect) -{ - s7_int len = vector_length(vect); - s7_pointer result; - if (len == 0) return(sc->nil); - init_temp(sc->y, sc->nil); - gc_protect_via_stack(sc, vect); - switch (type(vect)) - { - case T_VECTOR: - check_free_heap_size(sc, len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, vector_element(vect, i), sc->y); - break; - case T_BYTE_VECTOR: - check_free_heap_size(sc, len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, small_int(byte_vector(vect, i)), sc->y); - break; - case T_INT_VECTOR: - check_free_heap_size(sc, 2 * len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, make_integer_unchecked(sc, int_vector(vect, i)), sc->y); - break; - case T_FLOAT_VECTOR: - check_free_heap_size(sc, 2 * len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, make_real_unchecked(sc, float_vector(vect, i)), sc->y); - break; - } - unstack(sc); - result = sc->y; - sc->y = sc->unused; - return(result); -} - -s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array) -{ - s7_pointer result; - if (num_values == 0) return(sc->nil); - init_temp(sc->y, sc->nil); - check_free_heap_size(sc, num_values); - for (s7_int i = num_values - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, array[i], sc->y); - result = sc->y; - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_array_to_list", result); - sc->y = sc->unused; - return(result); -} - -#if (!WITH_PURE_S7) -static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_to_list "(vector->list v (start 0) end) returns the elements of the vector v as a list; (map values v)" - #define Q_vector_to_list s7_make_signature(sc, 4, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol) - - s7_int i, start = 0, end; - s7_pointer p, vec = car(args); - if (!is_any_vector(vec)) - return(sole_arg_method_or_bust(sc, vec, sc->vector_to_list_symbol, args, sc->type_names[T_VECTOR])); - - end = vector_length(vec); - if (!is_null(cdr(args))) - { - p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, cdr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(sc->nil); - } - if ((end - start) > sc->max_list_length) - out_of_range_error_nr(sc, sc->vector_to_list_symbol, int_one, car(args), it_is_too_large_string); - - check_free_heap_size(sc, end - start); - sc->w = sc->nil; - gc_protect_via_stack(sc, vec); - if (is_normal_vector(vec)) - for (i = end - 1; i >= start; i--) sc->w = cons_unchecked(sc, vector_element(vec, i), sc->w); - else for (i = end - 1; i >= start; i--) sc->w = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->w); - unstack(sc); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_any_vector(p)) - return(method_or_bust_p(sc, p, sc->vector_to_list_symbol, sc->type_names[T_VECTOR])); - return(s7_vector_to_list(sc, p)); -} -#endif - - -/* -------------------------------- string->byte-vector -------------------------------- */ -static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector." - #define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol) - s7_pointer str = car(args); - if (!is_string(str)) - return(method_or_bust_p(sc, str, sc->string_to_byte_vector_symbol, sc->type_names[T_STRING])); - return(s7_copy_1(sc, sc->string_to_byte_vector_symbol, set_plist_2(sc, str, make_simple_byte_vector(sc, string_length(str))))); -} - - -/* -------------------------------- byte-vector->string -------------------------------- */ -static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector_to_string "(byte-vector->string obj) turns a byte-vector into a string." - #define Q_byte_vector_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_byte_vector_symbol) - s7_pointer v = car(args); - if (!is_byte_vector(v)) - return(method_or_bust_p(sc, v, sc->byte_vector_to_string_symbol, sc->type_names[T_BYTE_VECTOR])); - return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, v, make_empty_string(sc, byte_vector_length(v), 0)))); -} - - -/* -------------------------------- vector -------------------------------- */ -static s7_pointer g_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_vector "(vector ...) returns a vector whose elements are the arguments" - #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T) - - s7_pointer vec, b; - s7_int len = proper_list_length_with_end(args, &b); - if (!is_null(b)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "vector constant data is not a proper list", 41))); - vec = make_simple_vector(sc, len); - if (len > 0) - { - s7_pointer x = args; - for (s7_int i = 0; is_pair(x); x = cdr(x), i++) - vector_element(vec, i) = car(x); - } - return(vec); -} - -static inline s7_pointer vector_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - s7_pointer vec = make_simple_vector(sc, 2); - vector_element(vec, 0) = p1; - vector_element(vec, 1) = p2; - return(vec); -} - -static s7_pointer g_vector_2(s7_scheme *sc, s7_pointer args) {return(vector_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_vector_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer vec = make_simple_vector(sc, 3); - vector_element(vec, 0) = car(args); args = cdr(args); - vector_element(vec, 1) = car(args); - vector_element(vec, 2) = cadr(args); - return(vec); -} - -static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 2) return(sc->vector_2); - return((args == 3) ? sc->vector_3 : f); -} - - -/* -------------------------------- float-vector? -------------------------------- */ -static s7_pointer g_is_float_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector" - #define Q_is_float_vector sc->pl_bt - check_boolean_method(sc, s7_is_float_vector, sc->is_float_vector_symbol, args); -} - - -/* -------------------------------- float-vector -------------------------------- */ -static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments" - #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol) - - s7_pointer vec, b; - s7_int len = proper_list_length_with_end(args, &b); - if (!is_null(b)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "float-vector constant data is not a proper list", 47))); - - vec = make_simple_float_vector(sc, len); - if (len > 0) - { - s7_int i = 0; - for (s7_pointer x = args; is_pair(x); x = cdr(x), i++) - { /* this used to gc protect vec via sc->w? was that due to very old bignum code in s7_real? */ - s7_pointer p = car(x); - if (is_t_real(p)) - float_vector(vec, i) = real(p); - else - if (is_real(p)) /* bignum is ok here */ - float_vector(vec, i) = s7_real(p); - else return(method_or_bust(sc, p, sc->float_vector_symbol, args, sc->type_names[T_REAL], i + 1)); - }} - return(vec); -} - -static s7_pointer float_vector_p_d(s7_scheme *sc, s7_double x) -{ - s7_pointer vec = make_simple_float_vector(sc, 1); - float_vector(vec, 0) = x; - return(vec); -} - - -/* -------------------------------- int-vector? -------------------------------- */ -static s7_pointer g_is_int_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous s7_int vector" - #define Q_is_int_vector sc->pl_bt - check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, args); -} - - -/* -------------------------------- int-vector -------------------------------- */ -static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_int_vector "(int-vector ...) returns an homogeneous s7_int vector whose elements are the arguments" - #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol) - - s7_int i = 0; - s7_pointer vec, b; - s7_int len = proper_list_length_with_end(args, &b); - if (!is_null(b)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "int-vector constant data is not a proper list", 45))); - - vec = make_simple_int_vector(sc, len); - if (len == 0) return(vec); - for (s7_pointer x = args; is_pair(x); x = cdr(x), i++) - { - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->int_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); - int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, p); - } - return(vec); -} - -static s7_pointer int_vector_p_i(s7_scheme *sc, s7_int x) -{ - s7_pointer vec = make_simple_int_vector(sc, 1); - int_vector(vec, 0) = x; - return(vec); -} - - -/* -------------------------------- byte-vector? -------------------------------- */ -static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" - #define Q_is_byte_vector sc->pl_bt - check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol, args); -} - - -/* -------------------------------- byte-vector -------------------------------- */ -static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments" - #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_byte_symbol) - - s7_int i = 0; - s7_pointer vec, end; - uint8_t *str; - s7_int len = proper_list_length_with_end(args, &end); - if (!is_null(end)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "byte-vector constant data is not a proper list", 46))); - - vec = make_simple_byte_vector(sc, len); - str = byte_vector_bytes(vec); - for (s7_pointer x = args; is_pair(x); i++, x = cdr(x)) - { - s7_pointer byte = car(x); - s7_int b; - if (is_t_integer(byte)) - b = integer(byte); - else -#if WITH_GMP - if (is_t_big_integer(byte)) - b = big_integer_to_s7_int(sc, big_integer(byte)); - else -#endif - return(method_or_bust(sc, byte, sc->byte_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); - if ((b < 0) || (b > 255)) - wrong_type_error_nr(sc, sc->byte_vector_symbol, i + 1, byte, an_unsigned_byte_string); - str[i] = (uint8_t)b; - } - return(vec); -} - - -#if (!WITH_PURE_S7) -/* -------------------------------- list->vector -------------------------------- */ -static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)" - #define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol) - - s7_pointer p = car(args); - if (is_null(p)) - return(make_simple_vector(sc, 0)); /* was s7_make_vector */ - sc->temp3 = p; - if (!s7_is_proper_list(sc, p)) - return(sole_arg_method_or_bust_p(sc, p, sc->list_to_vector_symbol, a_proper_list_string)); - p = g_vector(sc, p); - sc->temp3 = sc->unused; - return(p); -} - -/* -------------------------------- vector-length -------------------------------- */ -static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_length "(vector-length v) returns the length of vector v" - #define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol) - - s7_pointer vec = car(args); - if (!is_any_vector(vec)) - return(sole_arg_method_or_bust(sc, vec, sc->vector_length_symbol, args, sc->type_names[T_VECTOR])); - return(make_integer(sc, vector_length(vec))); -} - -static s7_int vector_length_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_any_vector(p)) - return(integer(method_or_bust_p(sc, p, sc->vector_length_symbol, sc->type_names[T_VECTOR]))); - return(vector_length(p)); -} - -static s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec) -{ - if (!is_any_vector(vec)) - return(method_or_bust_p(sc, vec, sc->vector_length_symbol, sc->type_names[T_VECTOR])); - return(make_integer(sc, vector_length(vec))); -} -#endif - - -/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */ -static bool s7_is_subvector(s7_pointer g) {return((is_any_vector(g)) && (is_subvector(g)));} - -static s7_pointer g_is_subvector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" - #define Q_is_subvector sc->pl_bt - check_boolean_method(sc, s7_is_subvector, sc->is_subvector_symbol, args); -} - -static s7_pointer g_subvector_position(s7_scheme *sc, s7_pointer args) -{ - #define H_subvector_position "(subvector-position obj) returns obj's offset" - #define Q_subvector_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_subvector_symbol) - - s7_pointer sv = car(args); - if (s7_is_subvector(sv)) - { - /* we can't use vector_elements(sv) - vector_elements(subvector_vector(sv)) because that assumes we're looking at s7_pointer*, - * so a subvector of a byte_vector gets a bogus position (0 if position is less than 8 etc). - * Since we currently let the user reset s7_int and s7_double, all four cases have to be handled explicitly. - */ - switch (type(sv)) - { - case T_VECTOR: return(make_integer(sc, (s7_int)(vector_elements(sv) - vector_elements(subvector_vector(sv))))); - case T_INT_VECTOR: return(make_integer(sc, (s7_int)(int_vector_ints(sv) - int_vector_ints(subvector_vector(sv))))); - case T_FLOAT_VECTOR: return(make_integer(sc, (s7_int)(float_vector_floats(sv) - float_vector_floats(subvector_vector(sv))))); - case T_BYTE_VECTOR: return(make_integer(sc, (s7_int)(byte_vector_bytes(sv) - byte_vector_bytes(subvector_vector(sv))))); - }} - return(sole_arg_method_or_bust(sc, sv, sc->subvector_position_symbol, args, sc->type_names[T_VECTOR])); -} - -static s7_pointer g_subvector_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_subvector_vector "(subvector-vector obj) returns the vector underlying the subvector obj" - #define Q_subvector_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_subvector_symbol) - - if (s7_is_subvector(car(args))) - return(subvector_vector(car(args))); - return(sole_arg_method_or_bust(sc, car(args), sc->subvector_vector_symbol, args, sc->type_names[T_VECTOR])); -} - -static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7_int index) -{ - s7_int dims = vector_ndims(vect) - skip_dims; - s7_pointer x; - new_cell(sc, x, (full_type(vect) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); - vector_length(x) = 0; - vector_block(x) = mallocate_empty_block(sc); - any_vector_elements(x) = NULL; - vector_getter(x) = vector_getter(vect); - vector_setter(x) = vector_setter(vect); - if (dims > 1) - { - vdims_t *v = (vdims_t *)mallocate_block(sc); - vdims_rank(v) = dims; - vdims_dims(v) = (s7_int *)(vector_dimensions(vect) + skip_dims); - vdims_offsets(v) = (s7_int *)(vector_offsets(vect) + skip_dims); - vdims_original(v) = vect; - vector_elements_should_be_freed(v) = false; - vector_set_dimension_info(x, v); - } - else - { - vector_set_dimension_info(x, NULL); - subvector_set_vector(x, vect); - } - if (is_normal_vector(vect)) - mark_function[T_VECTOR] = mark_vector_possibly_shared; - else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared; - - vector_length(x) = (skip_dims > 0) ? vector_offset(vect, skip_dims - 1) : vector_length(vect); - if (is_int_vector(vect)) - int_vector_ints(x) = (s7_int *)(int_vector_ints(vect) + index); - else - if (is_float_vector(vect)) - float_vector_floats(x) = (s7_double *)(float_vector_floats(vect) + index); - else - if (is_normal_vector(vect)) - vector_elements(x) = (s7_pointer *)(vector_elements(vect) + index); - else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(vect) + index); - add_multivector(sc, x); - return(x); -} - -static inline vdims_t *list_to_dims(s7_scheme *sc, s7_pointer x) -{ - s7_int i, offset; - s7_pointer y; - s7_int *ds, *os; - s7_int len = proper_list_length(x); - vdims_t *v = (vdims_t *)inline_mallocate(sc, len * 2 * sizeof(s7_int)); - vdims_rank(v) = len; - vdims_offsets(v) = (s7_int *)(vdims_dims(v) + len); - vector_elements_should_be_freed(v) = false; - ds = vdims_dims(v); - os = vdims_offsets(v); - - for (i = 0, y = x; is_not_null(y); i++, y = cdr(y)) - ds[i] = s7_integer_clamped_if_gmp(sc, car(y)); - - for (i = len - 1, offset = 1; i >= 0; i--) - { - os[i] = offset; - offset *= ds[i]; - } - return(v); -} - -static s7_pointer g_subvector(s7_scheme *sc, s7_pointer args) -{ - #define H_subvector "(subvector original-vector (start 0) (end original-vector-len) new-dimensions) returns \ -a vector that points to the same elements as the original-vector but with different starting point, end point, and dimensional info." - #define Q_subvector s7_make_signature(sc, 5, sc->is_subvector_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_pair_symbol) - - /* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (subvector v1 0 6))) v2)) -> #(1 2 3 4 5 6) - * (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (subvector v1 0 6 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6)) - */ - s7_pointer orig = car(args), x; - vdims_t *v = NULL; - s7_int new_len, orig_len, offset = 0; - - if (!is_any_vector(orig)) - return(method_or_bust(sc, orig, sc->subvector_symbol, args, sc->type_names[T_VECTOR], 1)); - - orig_len = vector_length(orig); - new_len = orig_len; - - if (is_pair(cdr(args))) /* get start point in vector */ - { - s7_pointer start = cadr(args); - if (!s7_is_integer(start)) - return(method_or_bust(sc, start, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 2)); - offset = s7_integer_clamped_if_gmp(sc, start); - if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, offset == 9223372036854775807 */ - out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, (offset < 0) ? it_is_negative_string : it_is_too_large_string); - new_len -= offset; - - if (is_pair(cddr(args))) /* get end point in vector */ - { - s7_pointer end = caddr(args); - s7_int new_end; - if (!s7_is_integer(end)) - return(method_or_bust(sc, end, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 3)); - new_end = s7_integer_clamped_if_gmp(sc, end); - if ((new_end < 0) || (new_end > orig_len)) - out_of_range_error_nr(sc, sc->subvector_symbol, int_three, end, (new_end < 0) ? it_is_negative_string : it_is_too_large_string); - if (offset > new_end) - out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, wrap_string(sc, "start point > end point", 23)); - new_len = new_end - offset; - - if (is_pair(cdddr(args))) - { - s7_pointer dims = cadddr(args); - if ((is_null(dims)) || - (!s7_is_proper_list(sc, dims))) - return(method_or_bust(sc, dims, sc->subvector_symbol, args, sc->type_names[T_PAIR], 4)); - - for (s7_pointer y = dims; is_pair(y); y = cdr(y)) - if ((!s7_is_integer(car(y))) || /* (subvector v '((1 2) (3 4))) */ - (s7_integer_clamped_if_gmp(sc, car(y)) > orig_len) || - (s7_integer_clamped_if_gmp(sc, car(y)) < 0)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43))); - - v = list_to_dims(sc, dims); - new_len = vdims_dims(v)[0]; - for (s7_int i = 1; i < vdims_rank(v); i++) new_len *= vdims_dims(v)[i]; - if (new_len != new_end - offset) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "subvector dimensional length, ~S, does not match the start and end positions: ~S to ~S~%", 88), - wrap_integer(sc, new_len), start, end)); - vdims_original(v) = orig; - }}} - - if (is_normal_vector(orig)) - mark_function[T_VECTOR] = mark_vector_possibly_shared; - else mark_function[type(orig)] = mark_int_or_float_vector_possibly_shared; /* I think this works for byte-vectors also */ - - new_cell(sc, x, (full_type(orig) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); - vector_block(x) = mallocate_empty_block(sc); - vector_set_dimension_info(x, v); - if (!v) subvector_set_vector(x, orig); - vector_length(x) = new_len; /* might be less than original length */ - if ((new_len == 0) && (is_normal_vector(orig))) set_has_simple_elements(x); - vector_getter(x) = vector_getter(orig); - vector_setter(x) = vector_setter(orig); - - if (is_int_vector(orig)) - int_vector_ints(x) = (s7_int *)(int_vector_ints(orig) + offset); - else - if (is_float_vector(orig)) - float_vector_floats(x) = (s7_double *)(float_vector_floats(orig) + offset); - else - if (is_normal_vector(x)) - vector_elements(x) = (s7_pointer *)(vector_elements(orig) + offset); - else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(orig) + offset); - add_multivector(sc, x); - return(x); -} - - -/* -------------------------------- vector-ref -------------------------------- */ -static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indices) -{ - s7_int index = 0; - if (vector_length(vect) == 0) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_one, vect, it_is_too_large_string); - - if (vector_rank(vect) > 1) - { - s7_int i; - s7_pointer x; - for (x = indices, i = 0; (is_not_null(x)) && (i < vector_ndims(vect)); x = cdr(x), i++) - { - s7_int n; - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, p); - if ((n < 0) || (n >= vector_dimension(vect, i))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); - - index += n * vector_offset(vect, i); - } - if (is_not_null(x)) - { - s7_pointer nv; - if (!is_normal_vector(vect)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); - nv = vector_element(vect, index); - return(implicit_index(sc, nv, x)); - } - /* if not enough indices, return a subvector covering whatever is left */ - if (i < vector_ndims(vect)) - return(subvector(sc, vect, i, index)); - } - else - { - s7_pointer p = car(indices); - /* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */ - - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, p); - - if ((index < 0) || (index >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - if (is_not_null(cdr(indices))) /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */ - { - s7_pointer nv; - if (!is_normal_vector(vect)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); - nv = vector_element(vect, index); - return(implicit_pair_index_checked(sc, vect, nv, indices)); - }} - return((vector_getter(vect))(sc, vect, index)); -} - -static s7_pointer g_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_ref "(vector-ref v ... i) returns the i-th element of vector v." - #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol) - - s7_pointer vec = car(args); - if (!is_any_vector(vec)) - return(method_or_bust(sc, vec, sc->vector_ref_symbol, args, sc->type_names[T_VECTOR], 1)); - return(vector_ref_1(sc, vec, cdr(args))); /* 19-Jan-19 */ -} - -static s7_pointer vector_ref_p_pi(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((!is_normal_vector(v)) || - (vector_rank(v) > 1) || - (i < 0) || (i >= vector_length(v))) - return(g_vector_ref(sc, set_plist_2(sc, v, make_integer(sc, i)))); - return(vector_element(v, i)); -} - -static s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i >= 0) && (i < vector_length(v))) - return(vector_getter(v)(sc, v, i)); - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(v); -} - -static s7_pointer normal_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i >= 0) && (i < vector_length(v))) - return(vector_element(v, i)); - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(v); -} - -static s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((!is_any_vector(v)) || - (vector_rank(v) != 2) || - (i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_ref(sc, set_plist_3(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2)))); - return(vector_getter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_ref(sc, set_plist_3(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2)))); - return(vector_element(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer normal_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i) {return(vector_element(v, i));} - -static inline s7_pointer vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer ind) -{ - s7_int index; - if ((!is_normal_vector(vec)) || - (vector_rank(vec) != 1) || - (!s7_is_integer(ind))) - return(g_vector_ref(sc, set_plist_2(sc, vec, ind))); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); - return(vector_element(vec, index)); -} - -static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args) {return(vector_ref_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_vector_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer vec = car(args), i1, i2; - s7_int ix, iy; - - if (!is_any_vector(vec)) - return(g_vector_ref(sc, args)); - if (vector_rank(vec) != 2) - return(g_vector_ref(sc, args)); - - i1 = cadr(args); - if (!s7_is_integer(i1)) - return(g_vector_ref(sc, args)); - i2 = caddr(args); - if (!s7_is_integer(i2)) - return(g_vector_ref(sc, args)); - ix = s7_integer_clamped_if_gmp(sc, i1); - iy = s7_integer_clamped_if_gmp(sc, i2); - if ((ix >= 0) && (iy >= 0) && - (ix < vector_dimension(vec, 0)) && (iy < vector_dimension(vec, 1))) - { - s7_int index = (ix * vector_offset(vec, 0)) + iy; /* vector_offset(vec, 1) == 1 */ - return(vector_getter(vec)(sc, vec, index)); - } - return(g_vector_ref(sc, args)); -} - -static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 2) - return(sc->vector_ref_2); - return((args == 3) ? sc->vector_ref_3 : f); -} - - -/* -------------------------------- vector-set! -------------------------------- */ -static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value." - #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol) - - s7_pointer vec = car(args), val; - s7_int index; - - if (!is_any_vector(vec)) - return(method_or_bust(sc, vec, sc->vector_set_symbol, args, sc->type_names[T_VECTOR], 1)); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); - if (vector_length(vec) == 0) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_one, vec, it_is_too_large_string); - - if (vector_rank(vec) > 1) - { - s7_int i; - s7_pointer x; - index = 0; - for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++) - { - s7_int n; - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, p); - if ((n < 0) || (n >= vector_dimension(vec, i))) - out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); - - index += n * vector_offset(vec, i); - } - if (is_not_null(cdr(x))) - wrong_number_of_args_error_nr(sc, "too many arguments for vector-set!: ~S", args); - if (i != vector_ndims(vec)) - wrong_number_of_args_error_nr(sc, "not enough arguments for vector-set!: ~S", args); - - /* since vector-ref can return a subvector (if not passed enough args), it might be interesting to - * also set a complete subvector via set!, but would that introduce ambiguity? Only copy the vector - * if at least one index is missing, and the value fits. It also makes error detection harder, - * but so does the current vector-ref handling. Can't decide... - * (define v (make-vector '(2 3) 0)) (vector-set! v 0 #(1 2 3)) -> error, but (vector-ref v 0) -> #(0 0 0) - * Other possible additions: complex-vector and string-vector. - */ - val = car(x); - } - else - { - s7_pointer p = cadr(args); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, p); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - if (is_not_null(cdddr(args))) - { - s7_pointer v = vector_getter(vec)(sc, vec, index); - if (!is_any_vector(v)) - wrong_number_of_args_error_nr(sc, "too many arguments for vector-set!: ~S", args); - return(g_vector_set(sc, set_ulist_1(sc, v, cddr(args)))); - } - val = caddr(args); - } - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, val)); - if (is_normal_vector(vec)) - vector_element(vec, index) = val; - else vector_setter(vec)(sc, vec, index, val); - return(val); -} - -static s7_pointer vector_set_p_pip(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - if ((!is_any_vector(v)) || - (vector_rank(v) > 1) || - (i < 0) || (i >= vector_length(v))) - return(g_vector_set(sc, set_plist_3(sc, v, make_integer(sc, i), p))); - - if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i, p)); - if (is_normal_vector(v)) - vector_element(v, i) = p; - else vector_setter(v)(sc, v, i, p); - return(p); -} - -static s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - if ((i >= 0) && (i < vector_length(v))) - vector_element(v, i) = p; - else out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(p); -} - -static s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p) -{ - if ((!is_any_vector(v)) || - (vector_rank(v) != 2) || - (i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, set_elist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p))); /* someday these should use plist_4 */ - - if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p)); - - if (is_normal_vector(v)) - vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p; - else vector_setter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)), p); - return(p); -} - -static s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p) -{ - /* normal untyped vector, rank == 2 */ - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, set_elist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p))); - vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p; - return(p); -} - -static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - if ((i >= 0) && (i < vector_length(v))) - typed_vector_setter(sc, v, i, p); - else out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(p); -} - -static s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p) -{ - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, set_elist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p))); - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p)); -} - -static s7_pointer normal_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_pointer p) {vector_element(v, i) = p; return(p);} - -static s7_pointer typed_normal_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - typed_vector_setter(sc, v, i, p); - return(p); -} - -static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args) -{ - /* (vector-set! vector index value) */ - s7_pointer ind, vec = car(args), val; - s7_int index; - - if (!is_any_vector(vec)) - return(g_vector_set(sc, args)); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); - if (vector_rank(vec) > 1) - return(g_vector_set(sc, args)); - - ind = cadr(args); - if (!s7_is_integer(ind)) - return(g_vector_set(sc, args)); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - val = caddr(args); - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, val)); - if (is_normal_vector(vec)) - vector_element(vec, index) = val; - else vector_setter(vec)(sc, vec, index, val); - return(val); -} - -static s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val) -{ - s7_int index; - - if ((!is_normal_vector(vec)) || (vector_rank(vec) > 1)) - return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); - if (!s7_is_integer(ind)) - return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, val)); - vector_element(vec, index) = val; - return(val); -} - -static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), ip1 = cadr(args), ip2 = caddr(args), val; - s7_int i1, i2; - if ((!is_any_vector(v)) || - (vector_rank(v) != 2) || - (is_immutable(v)) || - (!s7_is_integer(ip1)) || - (!s7_is_integer(ip2))) - return(g_vector_set(sc, args)); - i1 = s7_integer_clamped_if_gmp(sc, ip1); - i2 = s7_integer_clamped_if_gmp(sc, ip2); - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, args)); - val = cadddr(args); - if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), val)); - if (is_normal_vector(v)) - vector_element(v, i2 + (i1 * vector_offset(v, 0))) = val; - else vector_setter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)), val); - return(val); -} - -static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 3) return(sc->vector_set_3); - return((args == 4) ? sc->vector_set_4 : f); -} - - -/* -------------------------------- make-vector -------------------------------- */ -static s7_int multivector_length(s7_scheme *sc, s7_pointer x, s7_pointer caller) -{ - s7_pointer y; - s7_int len, dims = s7_list_length(sc, x); - if (dims <= 0) /* 0 if circular, negative if dotted */ - wrong_type_error_nr(sc, caller, 1, x, a_proper_list_string); - if (dims > sc->max_vector_dimensions) - out_of_range_error_nr(sc, caller, int_one, x, it_is_too_large_string); - - for (y = x, len = 1; is_pair(y); y = cdr(y)) - { - if (!s7_is_integer(car(y))) - wrong_type_error_nr(sc, caller, position_of(y, x), car(y), sc->type_names[T_INTEGER]); -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(len, s7_integer_clamped_if_gmp(sc, car(y)), &len)) /* or better perhaps len > sc->max_vector_length */ - out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(y, x)), car(y), it_is_too_large_string); -#else - len *= s7_integer_clamped_if_gmp(sc, car(y)); -#endif - if (len < 0) - wrong_type_error_nr(sc, caller, position_of(y, x), car(y), a_non_negative_integer_string); - } - return(len); -} - -static void check_vector_typer_c_function(s7_scheme *sc, s7_pointer caller, s7_pointer typf) -{ - s7_pointer sig = c_function_signature(typf); - if ((sig != sc->pl_bt) && - (is_pair(sig)) && - ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) - wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a boolean procedure", 19)); - if (!c_function_name(typf)) - wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a named function", 16)); - if (!c_function_marker(typf)) - c_function_set_marker(typf, mark_vector_1); - if (!c_function_symbol(typf)) - c_function_symbol(typf) = make_symbol(sc, c_function_name(typf), c_function_name_length(typf)); -} - -static inline s7_pointer make_multivector(s7_scheme *sc, s7_pointer vec, s7_pointer x) -{ - vdims_t *v = list_to_dims(sc, x); - vdims_original(v) = sc->F; - vector_set_dimension_info(vec, v); - add_multivector(sc, vec); - return(vec); -} - -static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - s7_int len; - s7_pointer x = car(args), fill = sc->unspecified, vec, typf = sc->T; - int32_t result_type = T_VECTOR; - - if (s7_is_integer(x)) - { - len = s7_integer_clamped_if_gmp(sc, x); - if (len < 0) - wrong_type_error_nr(sc, caller, 1, x, a_non_negative_integer_string); - } - else - { - if (!(is_pair(x))) - return(method_or_bust(sc, x, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - - if (!s7_is_integer(car(x))) - wrong_type_error_nr(sc, caller, 1, car(x), sc->type_names[T_INTEGER]); - len = (is_null(cdr(x))) ? s7_integer_clamped_if_gmp(sc, car(x)) : multivector_length(sc, x, caller); - } - - if (is_pair(cdr(args))) - { - fill = cadr(args); - if (caller == sc->make_int_vector_symbol) - result_type = T_INT_VECTOR; - else - if (caller == sc->make_float_vector_symbol) - result_type = T_FLOAT_VECTOR; - else - if (caller == sc->make_byte_vector_symbol) - result_type = T_BYTE_VECTOR; - if (is_pair(cddr(args))) - { - typf = caddr(args); - if ((!is_c_function(typf)) && - (!is_any_closure(typf)) && - (typf != sc->T)) /* default value */ - wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); - if (is_any_closure(typf)) - { - if (!is_symbol(find_closure(sc, typf, closure_let(typf)))) - wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! third argument, ..., is a ... but should be a <...>" */ - } - else - if (is_c_function(typf)) - { - if (typf == global_value(sc->is_float_symbol)) - { - if (!is_real(fill)) wrong_type_error_nr(sc, caller, 3, fill, sc->type_names[T_REAL]); - result_type = T_FLOAT_VECTOR; - } - else - if (typf == global_value(sc->is_integer_symbol)) - { - if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 3, fill, sc->type_names[T_INTEGER]); - result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR; - } - else - if (typf == global_value(sc->is_byte_symbol)) - { - if (!is_byte(fill)) wrong_type_error_nr(sc, caller, 2, fill, an_unsigned_byte_string); - result_type = T_BYTE_VECTOR; - } - else check_vector_typer_c_function(sc, caller, typf); - }}} - /* before making the new vector, if fill is specified and the vector is typed, we have to check for a type error. - * otherwise we can end up with a vector whose elements are NULL, causing a segfault in the gc. - */ - if ((result_type == T_VECTOR) && - (typf != sc->T) && /* default value */ - (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F)) - { - const char *tstr = make_type_name(sc, (is_c_function(typf)) ? c_function_name(typf) : symbol_name(find_closure(sc, typf, closure_let(typf))), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->make_vector_symbol, 3, fill, wrap_string(sc, tstr, safe_strlen(tstr))); - } - - vec = make_vector_1(sc, len, NOT_FILLED, result_type); - if ((result_type == T_VECTOR) && - (typf != sc->T)) /* default value */ - { - set_typed_vector(vec); - typed_vector_set_typer(vec, typf); - - if ((is_c_function(typf)) && - (c_function_has_simple_elements(typf))) - set_has_simple_elements(vec); - } - s7_vector_fill(sc, vec, fill); - if ((is_pair(x)) && - (is_pair(cdr(x)))) - return(make_multivector(sc, vec, x)); - add_vector(sc, vec); - return(vec); -} - -static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_vector "(make-vector len (value #) type) returns a vector of len elements initialized to value. \ -To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \ -(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \ -returns a 2 dimensional vector of 6 total elements, all initialized to 1.0." - #define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol)) - return(g_make_vector_1(sc, args, sc->make_vector_symbol)); -} - - -/* -------------------------------- make-float-vector -------------------------------- */ -static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector." - #define Q_make_float_vector s7_make_signature(sc, 3, \ - sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol) - s7_int len; - s7_pointer x, p = car(args); - block_t *arr; - - if ((is_pair(cdr(args))) || (!s7_is_integer(p))) - { - s7_pointer init; - if (is_pair(cdr(args))) - { - init = cadr(args); - if (!is_real(init)) - return(method_or_bust(sc, init, sc->make_float_vector_symbol, args, sc->type_names[T_REAL], 2)); -#if WITH_GMP - if (s7_is_bignum(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, s7_real(init))), sc->make_float_vector_symbol)); -#endif - if (is_rational(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); - } - else init = real_zero; - if (s7_is_integer(p)) - len = s7_integer_clamped_if_gmp(sc, p); - else - { - if (!is_pair(p)) - return(method_or_bust(sc, p, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - len = multivector_length(sc, p, sc->make_float_vector_symbol); - } - x = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); - float_vector_fill(x, s7_real(init)); - if (!s7_is_integer(p)) - return(make_multivector(sc, x, p)); - add_vector(sc, x); - return(x); - } - - len = s7_integer_clamped_if_gmp(sc, p); - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_float_vector_symbol, int_one, p, (len < 0) ? it_is_negative_string : it_is_too_large_string); - - arr = mallocate_vector(sc, len * sizeof(s7_double)); - new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = arr; - float_vector_floats(x) = (s7_double *)block_data(arr); - if (len > 0) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); - } - vector_set_dimension_info(x, NULL); - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - - add_vector(sc, x); - return(x); -} - -static s7_pointer make_float_vector_p_pp(s7_scheme *sc, s7_pointer len, s7_pointer fill) -{ - if ((is_t_integer(len)) && (is_t_real(fill)) && - (integer(len)>= 0) && (integer(len) < sc->max_vector_length)) - { - s7_pointer fv = make_simple_float_vector(sc, integer(len)); - float_vector_fill(fv, real(fill)); - return(fv); - } - return(g_make_float_vector(sc, set_plist_2(sc, len, fill))); -} - - -/* -------------------------------- make-int-vector -------------------------------- */ -static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_int_vector "(make-int-vector len (init 0)) returns an int-vector." - #define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol) - s7_int len; - s7_pointer x, p = car(args); - block_t *arr; - - if ((is_pair(cdr(args))) || - (!s7_is_integer(p))) - { - s7_pointer init; - if (is_pair(cdr(args))) - { - init = cadr(args); - if (!s7_is_integer(init)) - return(method_or_bust(sc, init, sc->make_int_vector_symbol, args, sc->type_names[T_INTEGER], 2)); - } - else init = int_zero; - if (s7_is_integer(p)) - len = s7_integer_clamped_if_gmp(sc, p); - else - { - if (!is_pair(p)) - return(method_or_bust(sc, p, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - len = multivector_length(sc, p, sc->make_int_vector_symbol); - } - x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); - int_vector_fill(x, s7_integer_clamped_if_gmp(sc, init)); - if (!s7_is_integer(p)) - return(make_multivector(sc, x, p)); - add_vector(sc, x); - return(x); - } - - len = s7_integer_clamped_if_gmp(sc, p); - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_int_vector_symbol, int_one, p, (len < 0) ? it_is_negative_string : it_is_too_large_string); - - arr = mallocate_vector(sc, len * sizeof(s7_int)); - new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = arr; - int_vector_ints(x) = (s7_int *)block_data(arr); - if (len > 0) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); - } - vector_set_dimension_info(x, NULL); - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - - add_vector(sc, x); - return(x); -} - -static s7_pointer make_int_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) -{ - s7_pointer x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); - int_vector_fill(x, init); - add_vector(sc, x); - return(x); -} - - -/* -------------------------------- make-byte-vector -------------------------------- */ -static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte." - #define Q_make_byte_vector s7_make_signature(sc, 3, sc->is_byte_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_byte_symbol) - s7_int len = 0, ib = 0; - s7_pointer p = car(args), init; - - if (!is_pair(p)) - { - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1)); - len = s7_integer_clamped_if_gmp(sc, p); - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, p, (len < 0) ? it_is_negative_string : it_is_too_large_string); - } - if (is_pair(cdr(args))) - { - init = cadr(args); - if (!s7_is_integer(init)) - return(method_or_bust(sc, init, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 2)); - ib = s7_integer_clamped_if_gmp(sc, init); - if ((ib < 0) || (ib > 255)) - wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, init, an_unsigned_byte_string); - } - else init = int_zero; - - if (!s7_is_integer(p)) - return(g_make_vector_1(sc, set_plist_2(sc, p, init), sc->make_byte_vector_symbol)); - - p = make_simple_byte_vector(sc, len); - if ((len > 0) && (is_pair(cdr(args)))) - local_memset((void *)(byte_vector_bytes(p)), ib, len); - return(p); -} - -static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) -{ - s7_pointer p; - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, wrap_integer(sc, len), (len < 0) ? it_is_negative_string : it_is_too_large_string); - if ((init < 0) || (init > 255)) - wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, wrap_integer(sc, init), an_unsigned_byte_string); - p = make_simple_byte_vector(sc, len); - if (len > 0) - local_memset((void *)(byte_vector_bytes(p)), init, len); - return(p); -} - - -/* -------------------------------- vector? -------------------------------- */ -static s7_pointer g_is_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_vector "(vector? obj) returns #t if obj is a vector" - #define Q_is_vector sc->pl_bt - check_boolean_method(sc, is_any_vector, sc->is_vector_symbol, args); -} - - -/* -------------------------------- vector-rank -------------------------------- */ -s7_int s7_vector_rank(s7_pointer vect) {return((s7_int)(vector_rank(vect)));} - -static s7_pointer g_vector_rank(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_rank "(vector-rank vect) returns the number of dimensions in vect" - #define Q_vector_rank s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol) - s7_pointer x = car(args); - if (!is_any_vector(x)) - return(sole_arg_method_or_bust(sc, x, sc->vector_rank_symbol, args, sc->type_names[T_VECTOR])); - return(make_integer(sc, vector_rank(x))); -} - - -/* -------------------------------- vector-dimension -------------------------------- */ -static s7_pointer g_vector_dimension(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_dimension "(vector-dimension vect n) returns the size of the n-th dimension (n is 0-based)" - #define Q_vector_dimension s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_vector_symbol, sc->is_integer_symbol) - s7_pointer v = car(args); - s7_pointer np = cadr(args); - s7_int n; - if (!is_any_vector(v)) - return(method_or_bust(sc, v, sc->vector_dimension_symbol, args, sc->type_names[T_VECTOR], 1)); - if (!s7_is_integer(np)) - return(method_or_bust(sc, v, sc->vector_dimension_symbol, args, sc->type_names[T_INTEGER], 2)); - n = s7_integer_clamped_if_gmp(sc, np); - if (n < 0) - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "vector-dimension second argument is negative: ~S", 48), np)); - if (n >= vector_rank(v)) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "vector-dimension second argument, ~S, should be less than the vector rank, ~S", 77), - np, wrap_integer(sc, vector_rank(v)))); - if (vector_has_dimension_info(v)) - return(make_integer(sc, vector_dimension(v, n))); - return(make_integer(sc, vector_length(v))); -} - - -/* -------------------------------- vector-dimensions -------------------------------- */ -static s7_pointer g_vector_dimensions(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions" - #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol) - - s7_pointer x = car(args); - if (!is_any_vector(x)) - return(sole_arg_method_or_bust(sc, x, sc->vector_dimensions_symbol, args, sc->type_names[T_VECTOR])); - if (vector_rank(x) == 1) - return(list_1(sc, make_integer(sc, vector_length(x)))); - - sc->w = sc->nil; - for (s7_int i = vector_ndims(x) - 1; i >= 0; i--) - sc->w = cons(sc, make_integer(sc, vector_dimension(x, i)), sc->w); - x = sc->w; - sc->w = sc->unused; - return(x); -} - - -/* -------------------------------- vector-typer -------------------------------- */ -static s7_pointer g_vector_typer(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_typer "(vector-typer vect) returns the vector's element type checking function" - #define Q_vector_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_vector_symbol) - - s7_pointer v = car(args); - if (!is_any_vector(v)) - return(sole_arg_method_or_bust(sc, v, sc->vector_typer_symbol, args, sc->type_names[T_VECTOR])); - - if (is_typed_vector(v)) return(typed_vector_typer(v)); - if (is_float_vector(v)) return(global_value(sc->is_float_symbol)); - if (is_int_vector(v)) return(global_value(sc->is_integer_symbol)); - if (is_byte_vector(v)) return(global_value(sc->is_byte_symbol)); - return(sc->F); -} - -static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), typer = cadr(args); - if (!is_any_vector(v)) - wrong_type_error_nr(sc, wrap_string(sc, "set! vector-typer", 17), 1, v, sc->type_names[T_VECTOR]); - if (!is_normal_vector(v)) - { - if (((is_int_vector(v)) && (typer != global_value(sc->is_integer_symbol))) || - ((is_float_vector(v)) && (typer != global_value(sc->is_float_symbol))) || - ((is_byte_vector(v)) && (typer != global_value(sc->is_byte_symbol)))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "vector-typer can't set ~S typer to ~S", 37), v, typer)); - return(typer); - } - if (is_boolean(typer)) - { - if (is_typed_vector(v)) - { - typed_vector_set_typer(v, sc->F); - clear_typed_vector(v); - }} - else - { - if (is_c_function(typer)) - check_vector_typer_c_function(sc, sc->vector_typer_symbol, typer); - else - { - if (!is_any_closure(typer)) - wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41)); - if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) - wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! second argument, ..., is a ... but should be a <...>" */ - } - set_typed_vector(v); - typed_vector_set_typer(v, typer); - if ((is_c_function(typer)) && - (c_function_has_simple_elements(typer))) - set_has_simple_elements(v); - } - return(typer); -} - - -/* -------------------------------- multivector -------------------------------- */ -#define MULTIVECTOR_TOO_MANY_ELEMENTS -1 -#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2 - -static int32_t traverse_vector_data(s7_scheme *sc, s7_pointer vec, s7_int flat_ref, s7_int dimension, s7_int dimensions, s7_int *sizes, s7_pointer lst) -{ - /* we're filling vec, we're currently looking for element flat_ref, - * we're at ref in dimension of dimensions, where sizes gives the bounds, and lst is our data - * #3D(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12))) - */ - s7_pointer x = lst; - for (s7_int i = 0; i < sizes[dimension]; i++, x = cdr(x)) - { - if (!is_pair(x)) - return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS); - if (dimension == (dimensions - 1)) - vector_setter(vec)(sc, vec, flat_ref++, car(x)); - else - { - flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(x)); - if (flat_ref < 0) return(flat_ref); - }} - return((is_null(x)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS); -} - -static s7_pointer reverse_in_place_unchecked(s7_scheme *sc, s7_pointer term, s7_pointer list) -{ - s7_pointer p = list, result = term; - while (true) - { - s7_pointer q; - LOOP_4(if (is_null(p)) return(result); q = cdr(p); set_cdr(p, result); result = p; p = q); /* return, not break because LOOP_4 is itself a do loop */ - } - return(result); -} - -static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list) -{ - return(reverse_in_place_unchecked(sc, sc->nil, list)); -} - -static noreturn void multivector_error_nr(s7_scheme *sc, const char *message, s7_pointer data) -{ - error_nr(sc, sc->read_error_symbol, - set_elist_3(sc, wrap_string(sc, "reading constant vector, ~A: ~A", 31), - s7_make_string_wrapper(sc, message), data)); -} - -static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* get the dimension bounds from data, make the new vector, fill it from data - * dims needs to be s7_int so we can at least give correct error messages. - */ - s7_pointer vec, x = data; - s7_int err, vec_loc; - s7_int *sizes; - - /* (#2d((1 2 3) (4 5 6)) 0 0) -> 1 - * (#2d((1 2 3) (4 5 6)) 1 1) -> 5 - * (#3d(((1 2) (3 4)) ((5 6) (7 8))) 1 1 0) -> 7 - * #3d(((1 2) (3 4)) ((5 6) (7))) -> error, #3d(((1 2) (3 4)) ((5 6) (7 8 9))), #3d(((1 2) (3 4)) (5 (7 8 9))) etc - * but a special case: #nd() is an n-dimensional empty vector - */ - - if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */ - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), wrap_integer(sc, dims))); - - if (dims > sc->max_vector_dimensions) /* probably can't happen -- caught in read_sharp? */ - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be less that (*s7* 'max-vector-dimensions): ~A", 78), - wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); - sc->w = sc->nil; - if (is_null(data)) /* dims are already 0 (calloc above) */ - return(g_make_vector(sc, set_plist_1(sc, make_list(sc, dims, int_zero)))); - - sizes = (s7_int *)Calloc(dims, sizeof(s7_int)); - for (s7_int i = 0; i < dims; i++) - { - sizes[i] = proper_list_length(x); - sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w); - x = car(x); - if ((i < (dims - 1)) && - (!is_pair(x))) - { - free(sizes); - multivector_error_nr(sc, "we need a list that fully specifies the vector's elements", data); - }} - - vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w))); - vec_loc = gc_protect_1(sc, vec); - sc->w = sc->unused; - - /* now fill the vector checking that all the lists match */ - err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data); - - free(sizes); - s7_gc_unprotect_at(sc, vec_loc); - if (err < 0) - multivector_error_nr(sc, (err == MULTIVECTOR_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data); - return(vec); -} - -static s7_pointer g_int_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* dims > 1, sc->value is a pair (not null) */ - s7_pointer *src; - s7_int len; - sc->value = g_multivector(sc, dims, data); - src = (s7_pointer *)vector_elements(sc->value); - len = vector_length(sc->value); - for (s7_int i = 0; i < len; i++) - if (!is_t_integer(src[i])) - wrong_type_error_nr(sc, wrap_string(sc, "#i(...)", 7), i + 1, src[i], sc->type_names[T_INTEGER]); - sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), int_zero), sc->make_int_vector_symbol); - return(s7_copy_1(sc, sc->int_vector_symbol, set_plist_2(sc, sc->value, sc->args))); -} - -static s7_pointer g_byte_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* dims > 1, sc->value is a pair (not null) */ - s7_pointer *src; - s7_int len; - sc->value = g_multivector(sc, dims, data); - src = (s7_pointer *)vector_elements(sc->value); - len = vector_length(sc->value); - for (s7_int i = 0; i < len; i++) - if (!is_byte(src[i])) - wrong_type_error_nr(sc, wrap_string(sc, "#u(...)", 7), i + 1, src[i], wrap_string(sc, "a byte", 6)); - sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), int_zero), sc->make_byte_vector_symbol); - return(s7_copy_1(sc, sc->byte_vector_symbol, set_plist_2(sc, sc->value, sc->args))); -} - -static s7_pointer g_float_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* dims > 1, sc->value is a pair (not null) */ - s7_pointer *src; - s7_int len; - sc->value = g_multivector(sc, dims, data); - src = (s7_pointer *)vector_elements(sc->value); - len = vector_length(sc->value); - for (s7_int i = 0; i < len; i++) - if (!is_real(src[i])) - wrong_type_error_nr(sc, wrap_string(sc, "#r(...)", 7), i + 1, src[i], sc->type_names[T_REAL]); - sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), real_zero), sc->make_float_vector_symbol); - return(s7_copy_1(sc, sc->float_vector_symbol, set_plist_2(sc, sc->value, sc->args))); -} - -static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect) -{ - s7_int len = vector_length(old_vect); - s7_pointer new_vect; - - if (is_normal_vector(old_vect)) - { - s7_pointer *src = (s7_pointer *)vector_elements(old_vect), *dst; - if ((is_typed_vector(old_vect)) && (len > 0)) /* preserve the type info as well */ - { - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), - vector_element(old_vect, 0), typed_vector_typer(old_vect))); - else new_vect = g_make_vector(sc, set_plist_3(sc, make_integer(sc, len), - vector_element(old_vect, 0), typed_vector_typer(old_vect))); - } - else - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)))); - else new_vect = make_simple_vector(sc, len); - /* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_proper_list also) */ - dst = (s7_pointer *)vector_elements(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; - return(new_vect); - } - - if (is_float_vector(old_vect)) - { - const s7_double *src = (s7_double *)float_vector_floats(old_vect); - s7_double *dst; - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), real_zero), sc->make_float_vector_symbol); - else new_vect = make_simple_float_vector(sc, len); - dst = (s7_double *)float_vector_floats(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ - return(new_vect); - } - - if (is_int_vector(old_vect)) - { - const s7_int *src = (s7_int *)int_vector_ints(old_vect); - s7_int *dst; - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_int_vector_symbol); - else new_vect = make_simple_int_vector(sc, len); - dst = (s7_int *)int_vector_ints(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; - return(new_vect); - } - - if (is_byte_vector(old_vect)) - { - const uint8_t *src = (const uint8_t *)byte_vector_bytes(old_vect); - uint8_t *dst; - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_byte_vector_symbol); - else new_vect = make_simple_byte_vector(sc, len); - dst = (uint8_t *)byte_vector_bytes(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; - return(new_vect); - } - return(NULL); -} - -s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect) {return(s7_vector_copy_1(sc, old_vect));} /* repeated for Vectorized */ - -static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) -{ - s7_pointer v = car(args), index; - s7_int ind; - - if (type(v) != typ) - return(method_or_bust(sc, v, caller, args, sc->type_names[typ], 1)); - - if (vector_rank(v) == 1) - { - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - sole_arg_out_of_range_error_nr(sc, caller, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - if (!is_null(cddr(args))) - out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); - } - else - { - s7_int i; - s7_pointer x; - ind = 0; - for (x = cdr(args), i = 0; (is_not_null(x)) && (i < vector_ndims(v)); x = cdr(x), i++) - { - s7_int n; - index = car(x); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, index); - if ((n < 0) || (n >= vector_dimension(v, i))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); - ind += n * vector_offset(v, i); - } - if (is_not_null(x)) - out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); - - /* if not enough indices, return a subvector covering whatever is left */ - if (i < vector_ndims(v)) - return(subvector(sc, v, i, ind)); - } - if (typ == T_FLOAT_VECTOR) - return(make_real(sc, float_vector(v, ind))); - return((typ == T_INT_VECTOR) ? make_integer(sc, int_vector(v, ind)) : small_int(byte_vector(v, ind))); -} - -static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) -{ - s7_pointer vec = car(args), val, index; - s7_int ind; - - if (type(vec) != typ) - return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1)); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, vec)); - - if (vector_rank(vec) > 1) - { - s7_int i; - s7_pointer x; - ind = 0; - for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++) - { - s7_int n; - index = car(x); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, index); - if ((n < 0) || (n >= vector_dimension(vec, i))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); - ind += n * vector_offset(vec, i); - } - if (is_not_null(cdr(x))) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); - if (i != vector_ndims(vec)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); - val = car(x); - } - else - { - s7_pointer p = cdr(args); - if (is_null(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); - /* from (set! (v) val) after optimization into op_set_opsq_a which is completely confused -- set! gets v's setter (float-vector-set!) */ - index = car(p); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(vec))) - out_of_range_error_nr(sc, caller, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - if (is_not_null(cddr(p))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); - val = cadr(p); - } - - if (typ == T_FLOAT_VECTOR) - { - if (!is_real(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_REAL], 3)); - float_vector(vec, ind) = s7_real(val); - } - else - if (typ == T_INT_VECTOR) - { - if (!s7_is_integer(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, val); - } - else - { - if (!is_byte(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - byte_vector(vec, ind) = (uint8_t)s7_integer_clamped_if_gmp(sc, val); - } - return(val); -} - - -/* -------------------------------- float-vector-ref -------------------------------- */ -static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v." - #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_float_symbol, sc->is_float_vector_symbol), \ - sc->is_float_vector_symbol, sc->is_integer_symbol) - return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); -} - -static inline s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_pointer index) -{ - s7_int ind; - if (!is_float_vector(v)) - return(method_or_bust_pp(sc, v, sc->float_vector_ref_symbol, v, index, sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_ref(sc, set_plist_2(sc, v, index), sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); - if (!s7_is_integer(index)) - return(method_or_bust_pp(sc, index, sc->float_vector_ref_symbol, v, index, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_real(sc, float_vector(v, ind))); -} - -static s7_pointer g_fv_ref_2(s7_scheme *sc, s7_pointer args) {return(float_vector_ref_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_fv_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer fv = car(args), index; - s7_int ind1, ind2; - if (!is_float_vector(fv)) - return(method_or_bust(sc, fv, sc->float_vector_ref_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank(fv) != 2) - return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind1 = s7_integer_clamped_if_gmp(sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); - index = caddr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); - ind2 = s7_integer_clamped_if_gmp(sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); - ind1 = ind1 * vector_offset(fv, 0) + ind2; - return(make_real(sc, float_vector(fv, ind1))); -} - -static inline s7_int ref_check_index(s7_scheme *sc, s7_pointer v, s7_int i) -{ - /* according to callgrind, it is faster to split out the bounds check */ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(i); -} - -static inline s7_double float_vector_ref_d_7pi(s7_scheme *sc, s7_pointer v, s7_int i) {return(float_vector(v, ref_check_index(sc, v, i)));} -static s7_pointer float_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(make_real(sc, float_vector(v, i)));} - -static inline s7_double float_vector_ref_d_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return(float_vector(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - return(float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : f)); -} - - -/* -------------------------------- float-vector-set! -------------------------------- */ -static s7_pointer g_float_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value." - #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, \ - sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol) - return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); -} - -static s7_pointer g_fv_set_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer fv = car(args), index, value; - s7_int ind; - if (!is_float_vector(fv)) - return(method_or_bust(sc, fv, sc->float_vector_set_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank(fv) != 1) - return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); - if (is_immutable_vector(fv)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(fv))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = caddr(args); - if (!is_real(value)) - return(method_or_bust(sc, value, sc->float_vector_set_symbol, args, sc->type_names[T_REAL], 3)); - float_vector(fv, ind) = s7_real(value); - return(value); -} - -static s7_pointer g_fv_set_unchecked(s7_scheme *sc, s7_pointer args) -{ - s7_pointer fv, value = caddr(args); - s7_int ind; - if (!is_real(value)) - wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, value, sc->type_names[T_REAL]); - fv = car(args); - if (is_immutable_vector(fv)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv)); - ind = s7_integer_clamped_if_gmp(sc, cadr(args)); - float_vector(fv, ind) = s7_real(value); - return(value); -} - -static bool find_matching_ref(s7_scheme *sc, s7_pointer getter, s7_pointer expr) -{ - /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */ - s7_pointer v = cadr(expr), ind = caddr(expr); - if ((is_symbol(v)) && (!is_pair(ind))) - { - s7_pointer val = cadddr(expr); - if (is_optimized(val)) /* includes is_pair */ - for (s7_pointer p = val; is_pair(p); p = cdr(p)) - if (is_pair(car(p))) - { - s7_pointer ref = car(p); - if (((car(ref) == getter) && /* (getter v ind) */ - (is_proper_list_2(sc, cdr(ref))) && - (cadr(ref) == v) && - (caddr(ref) == ind)) || - ((car(ref) == v) && /* (v ind) */ - (is_proper_list_1(sc, cdr(ref))) && - (cadr(ref) == ind))) - return(true); - }} - return(false); -} - -static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 3) - return((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) ? sc->fv_set_unchecked : sc->fv_set_3); - return(f); -} - -static s7_double float_vector_set_d_7pid_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_double x) {float_vector(v, i) = x; return(x);} - -static s7_int set_check_index(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(i); -} - -static s7_double float_vector_set_d_7pid(s7_scheme *sc, s7_pointer v, s7_int i, s7_double x) {float_vector(v, (set_check_index(sc, v, i))) = x; return(x);} - -static s7_double float_vector_set_d_7piid(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_double x) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - float_vector(v, i2 + (i1 * vector_offset(v, 0))) = x; - return(x); -} - -static s7_double float_vector_set_d_7piiid(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3, s7_double x) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0))) = x; - return(x); -} - -static s7_pointer float_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - float_vector(v, i) = real_to_double(sc, p, "float-vector-set!"); - return(p); -} - - -/* -------------------------------- int-vector-ref -------------------------------- */ -static s7_pointer g_int_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v." - #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_int_vector_symbol), \ - sc->is_int_vector_symbol, sc->is_integer_symbol) - return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); -} - -static s7_int int_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i) {return(int_vector(v, i));} -static s7_pointer int_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(make_integer(sc, int_vector(v, i)));} - -static s7_int int_vector_ref_i_7pi(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(int_vector(v, i)); -} - -static s7_int int_vector_ref_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return(int_vector(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_int int_vector_ref_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - return(int_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0)))); -} - -static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_pointer index) -{ - s7_int ind; - if (!is_int_vector(v)) - return(method_or_bust_pp(sc, v, sc->int_vector_ref_symbol, v, index, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_ref(sc, set_plist_2(sc, v, index), sc->int_vector_ref_symbol, T_INT_VECTOR)); - if (!s7_is_integer(index)) - return(method_or_bust_pp(sc, index, sc->int_vector_ref_symbol, v, index, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_integer(sc, int_vector(v, ind))); -} - -static s7_pointer g_iv_ref_2(s7_scheme *sc, s7_pointer args) {return(int_vector_ref_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_iv_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer iv = car(args), index; - s7_int ind1, ind2; - if (!is_int_vector(iv)) - return(method_or_bust(sc, iv, sc->int_vector_ref_symbol, args, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(iv) != 2) - return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind1 = s7_integer_clamped_if_gmp(sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); - index = caddr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); - ind2 = s7_integer_clamped_if_gmp(sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); - ind1 = ind1 * vector_offset(iv, 0) + ind2; - return(make_integer(sc, int_vector(iv, ind1))); -} - -static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : f)); -} - - -/* -------------------------------- int-vector-set! -------------------------------- */ -static s7_pointer g_int_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value." - #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol) - return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); -} - -static s7_int int_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_int x) {int_vector(v, i) = x; return(x);} - -static s7_pointer int_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - int_vector(v, i) = s7_integer_clamped_if_gmp(sc, p); - return(p); -} - -static s7_int int_vector_set_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i, s7_int x) -{ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = x; - return(x); -} - -static s7_int int_vector_set_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3; - return(i3); -} - -static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer index, s7_pointer val) -{ - if ((is_int_vector(v)) && (vector_rank(v) == 1) && (!is_immutable_vector(v)) && - (is_t_integer(index)) && (is_t_integer(val))) - { - s7_int i = integer(index); - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = integer(val); - } - else - { - if (!is_int_vector(v)) - return(method_or_bust_ppp(sc, v, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_set(sc, set_plist_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); - if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v)); - if (!s7_is_integer(index)) - return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 2)); - if (!s7_is_integer(val)) - return(method_or_bust_ppp(sc, val, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 3)); -#if WITH_GMP - { - s7_int i = s7_integer_clamped_if_gmp(sc, index); - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = s7_integer_clamped_if_gmp(sc, val); - } -#else - if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); -#endif - } - return(val); -} - -static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), index, value; - s7_int ind; - if (!is_int_vector(v)) - return(method_or_bust(sc, v, sc->int_vector_set_symbol, args, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); - if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = caddr(args); - if (!s7_is_integer(value)) - return(method_or_bust(sc, value, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 3)); - int_vector(v, ind) = s7_integer_clamped_if_gmp(sc, value); - return(value); -} - -static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 3) ? sc->iv_set_3 : f); -} - - -/* -------------------------------- byte-vector-ref -------------------------------- */ -static s7_pointer g_byte_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector_ref "(byte-vector-ref vect index) returns the byte at the index-th element of the byte-vector vect" - #define Q_byte_vector_ref s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_byte_vector_symbol), \ - sc->is_byte_vector_symbol, sc->is_integer_symbol) - return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); -} - -static s7_int byte_vector_ref_i_7pi(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if ((i1 < 0) || (i1 >= byte_vector_length(p1))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return((s7_int)((byte_vector(p1, i1)))); -} - -static s7_int byte_vector_ref_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return((s7_int)byte_vector(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(small_int((byte_vector(p1, i1))));} -static s7_int byte_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(byte_vector(p1, i1));} - -static s7_pointer g_bv_ref_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), index; - s7_int ind; - if (!is_byte_vector(v)) - return(method_or_bust(sc, v, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(small_int(byte_vector(v, ind))); -} - -static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer iv = car(args), index; - s7_int ind1, ind2; - if (!is_byte_vector(iv)) - return(method_or_bust(sc, iv, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank(iv) != 2) - return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind1 = s7_integer_clamped_if_gmp(sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); - index = caddr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); - ind2 = s7_integer_clamped_if_gmp(sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); - ind1 = ind1 * vector_offset(iv, 0) + ind2; - return(small_int(byte_vector(iv, ind1))); -} - -static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : f)); -} - - -/* -------------------------------- byte-vector-set -------------------------------- */ -static s7_pointer g_byte_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector_set "(byte-vector-set! vect index byte) sets the index-th element of the byte-vector vect to the integer byte" - #define Q_byte_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol) - return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); -} - -static s7_int byte_vector_set_i_7pii(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2) -{ - if (!is_byte_vector(p1)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 1, p1, a_byte_vector_string); - if ((i2 < 0) || (i2 > 255)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, wrap_integer(sc, i2), an_unsigned_byte_string); - if ((i1 < 0) || (i1 >= byte_vector_length(p1))) - out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - byte_vector(p1, i1) = (uint8_t)i2; - return(i2); -} - -static s7_int byte_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_int i2) -{ - byte_vector(p1, i1) = (uint8_t)i2; return(i2); -} - -static s7_pointer byte_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - byte_vector(p1, i1) = (uint8_t)s7_integer(p2); return(p2); -} - -static s7_int byte_vector_set_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i3 < 0) || (i3 > 255)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 4, wrap_integer(sc, i3), an_unsigned_byte_string); - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - byte_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3; - return(i3); -} - -static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), index, value; - s7_int ind, uval; - if (!is_byte_vector(v)) - return(method_or_bust(sc, v, sc->byte_vector_set_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); - if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->byte_vector_set_symbol, v)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = caddr(args); - if (!s7_is_integer(value)) - return(method_or_bust(sc, value, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 3)); - uval = s7_integer_clamped_if_gmp(sc, value); - if ((uval < 0) || (uval > 255)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, value, an_unsigned_byte_string); - byte_vector(v, ind) = (uint8_t)uval; - return(value); -} - -static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 3) ? sc->bv_set_3 : f); -} - - -/* -------------------------------------------------------------------------------- */ -static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) -{ - s7_pointer p = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */ - if ((p == opt1_cfunc(x)) || - ((p) && (is_any_c_function(p)) && (c_function_class(p) == c_function_class(opt1_cfunc(x))) && (set_opt1_cfunc(x, p)))) - return(true); - sc->last_function = p; - return(false); -} - -static bool cl_function_is_ok(s7_scheme *sc, s7_pointer x) -{ - sc->last_function = lookup_unexamined(sc, car(x)); - return(sc->last_function == opt1_cfunc(x)); -} - -static bool arglist_has_rest(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p; - for (p = args; is_pair(p); p = cdr(p)) - if (car(p) == sc->rest_keyword) - return(true); - return(!is_null(p)); -} - - -/* -------------------------------- sort! -------------------------------- */ -static bool bool_optimize(s7_scheme *sc, s7_pointer expr); -static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr); -static bool cell_optimize(s7_scheme *sc, s7_pointer expr); -static void pc_fallback(s7_scheme *sc, int32_t new_pc) {sc->pc = new_pc;} - -static int32_t dbl_less(const void *f1, const void *f2) -{ - if ((*((s7_double *)f1)) < (*((s7_double *)f2))) return(-1); - return(((*((s7_double *)f1)) > (*((s7_double *)f2))) ? 1 : 0); -} - -static int32_t int_less(const void *f1, const void *f2) -{ - if ((*((s7_int *)f1)) < (*((s7_int *)f2))) return(-1); - return(((*((s7_int *)f1)) > (*((s7_int *)f2))) ? 1 : 0); -} - -static int32_t dbl_greater(const void *f1, const void *f2) {return(-dbl_less(f1, f2));} -static int32_t int_greater(const void *f1, const void *f2) {return(-int_less(f1, f2));} - -static int32_t byte_less(const void *f1, const void *f2) -{ - if ((*((const uint8_t *)f1)) < (*((const uint8_t *)f2))) return(-1); - return(((*((const uint8_t *)f1)) > (*((const uint8_t *)f2))) ? 1 : 0); -} - -static int32_t byte_greater(const void *f1, const void *f2) {return(-byte_less(f1, f2));} - -static int32_t dbl_less_2(const void *f1, const void *f2) -{ - s7_double p1 = real(*((s7_pointer *)f1)); - s7_double p2 = real(*((s7_pointer *)f2)); - if (p1 < p2) return(-1); - return((p1 > p2) ? 1 : 0); -} - -static int32_t int_less_2(const void *f1, const void *f2) -{ - s7_int p1 = integer(*((s7_pointer *)f1)); - s7_int p2 = integer(*((s7_pointer *)f2)); - if (p1 < p2) return(-1); - return((p1 > p2) ? 1 : 0); -} - -static int32_t dbl_greater_2(const void *f1, const void *f2) {return(-dbl_less_2(f1, f2));} -static int32_t int_greater_2(const void *f1, const void *f2) {return(-int_less_2(f1, f2));} - -static int32_t str_less_2(const void *f1, const void *f2) -{ - s7_pointer p1 = (*((s7_pointer *)f1)); - s7_pointer p2 = (*((s7_pointer *)f2)); - return(scheme_strcmp(p1, p2)); -} - -static int32_t str_greater_2(const void *f1, const void *f2) {return(-str_less_2(f1, f2));} - -static int32_t chr_less_2(const void *f1, const void *f2) -{ - uint8_t p1 = character(*((s7_pointer *)f1)); - uint8_t p2 = character(*((s7_pointer *)f2)); - if (p1 < p2) return(-1); - return((p1 > p2) ? 1 : 0); -} - -static int32_t chr_greater_2(const void *f1, const void *f2) {return(-chr_less_2(f1, f2));} - -#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__) -struct sort_r_data {void *arg; int32_t (*compar)(const void *a1, const void *a2, void *aarg);}; - -static int32_t sort_r_arg_swap(void *s, const void *aa, const void *bb) -{ - struct sort_r_data *ss = (struct sort_r_data*)s; - return (ss->compar)(aa, bb, ss->arg); -} -#endif - -/* qsort_r in Linux requires _GNU_SOURCE and is different from q_sort_r in FreeBSD, neither matches qsort_s in Windows - * this code tested only in Linux and the mac -- my virtualbox freebsd died, netbsd and openbsd run using fallback code. - */ -static void local_qsort_r(void *base, size_t nmemb, size_t size, int32_t (*compar)(const void *, const void *, void *), void *arg) -{ -#if (defined(__linux__)) && (defined(__GLIBC__)) /* __GLIBC__ because musl does not have qsort_r and has no way to detect it */ - qsort_r(base, nmemb, size, compar, arg); -#else -#if defined(__APPLE__) || defined(__FreeBSD__) /* not in OpenBSD or NetBSD as far as I can tell */ - struct sort_r_data tmp = {arg, compar}; - qsort_r(base, nmemb, size, &tmp, &sort_r_arg_swap); -#else -#if MS_WINDOWS - struct sort_r_data tmp = {arg, compar}; - qsort_s(base, nmemb, size, sort_r_arg_swap, &tmp); -#else - /* from the Net somewhere, by "Pete", about 25 times slower than libc's qsort_r in this context */ - if (nmemb > 1) - { - uint8_t *array = (uint8_t *)base; - uint8_t *after = (uint8_t *)(nmemb * size + array); - size_t h, t; - nmemb /= 4; - h = nmemb + 1; - for (t = 1; nmemb != 0; nmemb /= 4) - t *= 2; - do { - size_t bytes = h * size; - uint8_t *i = (uint8_t *)(array + bytes); - uint8_t *k; - do { - uint8_t *j = (uint8_t *)(i - bytes); - if (compar(j, i, arg) > 0) - { - k = i; - do { - uint8_t *p1 = j, *p2 = k; - uint8_t *end = (uint8_t *)(p2 + size); - do { - uint8_t swap = *p1; - *p1++ = *p2; - *p2++ = swap; - } while (p2 != end); - if (bytes + array > j) - break; - k = j; - j -= bytes; - } while (compar(j, k, arg) > 0); - } - i += size; - } while (i != after); - t /= 2; - h = t * t - t * 3 / 2 + 1; - } while (t != 0); - } -#endif -#endif -#endif -} - -static int32_t vector_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - return(((*(sc->sort_f))(sc, (*(s7_pointer *)v1), (*(s7_pointer *)v2))) ? -1 : 1); -} - -static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) /* for qsort_r */ -{ - s7_pointer s1 = (*(s7_pointer *)v1); - s7_pointer s2 = (*(s7_pointer *)v2); - if ((is_t_integer(s1)) && (is_t_integer(s2))) - return((integer(s1) < integer(s2)) ? -1 : 1); - return((lt_b_7pp((s7_scheme *)arg, s1, s2)) ? -1 : 1); -} - -static int32_t vector_car_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - s7_pointer a = (*(s7_pointer *)v1); - s7_pointer b = (*(s7_pointer *)v2); - a = (is_pair(a)) ? car(a) : g_car(sc, set_plist_1(sc, a)); - b = (is_pair(b)) ? car(b) : g_car(sc, set_plist_1(sc, b)); - return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1); -} - -static int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - s7_pointer a = (*(s7_pointer *)v1); - s7_pointer b = (*(s7_pointer *)v2); - a = (is_pair(a)) ? cdr(a) : g_cdr(sc, set_plist_1(sc, a)); - b = (is_pair(b)) ? cdr(b) : g_cdr(sc, set_plist_1(sc, b)); - return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1); -} - -static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); /* first slot in curlet */ - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); /* second slot in curlet */ - return((sc->sort_fb(sc->sort_o)) ? -1 : 1); -} - -static int32_t opt_bool_sort_0(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); /* first slot in curlet */ - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); /* second slot in curlet */ - return((sc->sort_fb(sc->sort_o)) ? -1 : 1); -} - -static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - return((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1); -} - -#define SORT_O1 1 -static inline int32_t begin_bool_sort_bp(s7_scheme *sc, const void *v1, const void *v2, bool int_expr) -{ - s7_int i; - opt_info *top = sc->opts[0], *o; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - for (i = 0; i < sc->sort_body_len - 1; i++) - { - o = top->v[SORT_O1 + i].o1; - o->v[0].fp(o); - } - o = top->v[SORT_O1 + i].o1; - if (int_expr) - return((o->v[0].fb(o)) ? -1 : 1); - return((o->v[0].fp(o) != sc->F) ? -1 : 1); -} - -static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg) {return(begin_bool_sort_bp((s7_scheme *)arg, v1, v2, true));} -static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg) {return(begin_bool_sort_bp((s7_scheme *)arg, v1, v2, false));} - -static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - opt_info *top = sc->opts[0], *o; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - o = top->v[SORT_O1].o1; - o->v[0].fp(o); - o = top->v[SORT_O1 + 1].o1; - return((o->v[0].fb(o)) ? -1 : 1); -} - -static int32_t closure_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code); - sc->code = sc->sort_body; /* this should be ok because we checked in advance that it is a safe closure (no sort! for example) */ - eval(sc, sc->sort_op); - return((sc->value != sc->F) ? -1 : 1); -} - -static int32_t closure_sort_begin(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code); - push_stack_no_args(sc, OP_BEGIN_NO_HOOK, T_Pair(sc->sort_begin)); - sc->code = sc->sort_body; - eval(sc, sc->sort_op); - return((sc->value != sc->F) ? -1 : 1); -} - -static s7_b_7pp_t s7_b_7pp_function(s7_pointer f); -static opt_info *alloc_opt_info(s7_scheme *sc); - -static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) -{ - #define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements." - #define Q_sort s7_make_signature(sc, 3, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_procedure_symbol) - - s7_pointer data = car(args), lessp, lx; - s7_int len = 0, n, k; - int32_t (*sort_func)(const void *v1, const void *v2, void *arg); - s7_pointer *elements; - - /* both the intermediate vector (if any) and the current args pointer need GC protection, - * but it is a real bother to unprotect args at every return statement, so I'll use temp3 - */ - sc->temp3 = args; /* this is needed but maybe insufficient... if sort is semisafe, we should protect the args, not the list: use OP_GC_PROTECT? */ - if (is_null(data)) - { - /* (apply sort! () #f) should be an error I think */ - lessp = cadr(args); - if (type(lessp) < T_CONTINUATION) - return(method_or_bust(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2)); - if (!s7_is_aritable(sc, lessp, 2)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); - return(sc->nil); - } - - if (!is_sequence(data)) /* precede immutable because #f (for example) is immutable: "can't sort #f because it is immutable" is a joke */ - wrong_type_error_nr(sc, sc->sort_symbol, 1, data, a_sequence_string); - if (is_immutable(data)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); - - lessp = cadr(args); - if (type(lessp) <= T_GOTO) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, a_normal_procedure_string); - if (!s7_is_aritable(sc, lessp, 2)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); - if ((is_any_macro(lessp)) && (!is_c_macro(lessp))) clear_all_optimizations(sc, closure_body(lessp)); - - sort_func = NULL; - sc->sort_f = NULL; - - if (is_safe_c_function(lessp)) /* (sort! a <) */ - { - s7_pointer sig = c_function_signature(lessp); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_boolean_symbol)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, - wrap_string(sc, "sort! function should return a boolean", 38)); - sc->sort_f = s7_b_7pp_function(lessp); - if (sc->sort_f) sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; - } - else - { - if (is_closure(lessp)) - { - s7_pointer expr = car(closure_body(lessp)); - s7_pointer largs = closure_args(lessp); - - if ((is_pair(largs)) && /* closure args not a symbol, etc */ - (!arglist_has_rest(sc, largs))) - { - if ((is_null(cdr(closure_body(lessp)))) && - (is_optimized(expr)) && - (is_safe_c_op(optimize_op(expr))) && - /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in - * optimize in this case, for some arcane reason), the optimized expression won't be hop_safe, - * but that is irrelevant at this point -- if c_function_is_ok, we're good to go. - */ - ((op_has_hop(expr)) || - ((is_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ - (c_function_is_ok(sc, expr))))) - { - int32_t orig_data = optimize_op(expr); - set_optimize_op(expr, optimize_op(expr) | 1); - if ((optimize_op(expr) == HOP_SAFE_C_SS) && - (car(largs) == cadr(expr)) && - (cadr(largs) == caddr(expr))) - { - s7_pointer lp = lookup(sc, car(expr)); - sc->sort_f = s7_b_7pp_function(lp); - if (sc->sort_f) - { - sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; - lessp = lp; - }} - else - if ((optimize_op(expr) == HOP_SAFE_C_opSq_opSq) && - ((caadr(expr) == sc->car_symbol) || (caadr(expr) == sc->cdr_symbol)) && - (caadr(expr) == caaddr(expr)) && - (car(largs) == cadadr(expr)) && - (cadr(largs) == cadaddr(expr))) - { - s7_pointer lp = lookup(sc, car(expr)); - sc->sort_f = s7_b_7pp_function(lp); - if (sc->sort_f) - { - sort_func = ((caadr(expr) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort); - lessp = lp; - }} - set_optimize_op(expr, orig_data); - } - - if (!sort_func) - { - s7_pointer init_val, old_e = sc->curlet; - if (is_float_vector(data)) - init_val = real_zero; - else init_val = ((is_int_vector(data)) || (is_byte_vector(data))) ? int_zero : sc->F; - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(lessp), car(largs), init_val, cadr(largs), init_val); - sc->sort_body = expr; - sc->sort_v1 = let_slots(sc->curlet); - sc->sort_v2 = next_slot(let_slots(sc->curlet)); - if (is_null(cdr(closure_body(lessp)))) - { - if (!no_bool_opt(closure_body(lessp))) - { - s7_pfunc sf1 = s7_bool_optimize(sc, closure_body(lessp)); - if (sf1) - { - if (sc->opts[0]->v[0].fb == p_to_b) - sort_func = opt_bool_sort_p; - else - { - sc->sort_o = sc->opts[0]; - sc->sort_fb = sc->sort_o->v[0].fb; - sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; - }} - else set_no_bool_opt(closure_body(lessp)); - }} - else - { - sc->sort_body_len = s7_list_length(sc, closure_body(lessp)); - if (sc->sort_body_len < (NUM_VUNIONS - SORT_O1)) - { - s7_pointer p; - int32_t ctr; - opt_info *top; - sc->pc = 0; - top = alloc_opt_info(sc); - for (ctr = SORT_O1, p = closure_body(lessp); is_pair(cdr(p)); ctr++, p = cdr(p)) - { - top->v[ctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(cdr(p))) - { - int32_t start = sc->pc; - top->v[ctr].o1 = sc->opts[start]; - if (bool_optimize_nw(sc, p)) - sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b; - else - { - pc_fallback(sc, start); - if (cell_optimize(sc, p)) - sort_func = opt_begin_bool_sort_p; - }}}} - if (!sort_func) - set_curlet(sc, old_e); - } - if ((!sort_func) && - (is_safe_closure(lessp))) /* no embedded sort! or call/cc, etc */ - { - sc->curlet = make_let_with_two_slots(sc, closure_let(lessp), car(largs), sc->F, cadr(largs), sc->F); - sc->sort_body = car(closure_body(lessp)); - sc->sort_begin = cdr(closure_body(lessp)); - sort_func = (is_null(sc->sort_begin)) ? closure_sort : closure_sort_begin; - sc->sort_op = (is_syntactic_pair(sc->sort_body)) ? (opcode_t)optimize_op(sc->sort_body) : (opcode_t)OP_EVAL; - sc->sort_v1 = let_slots(sc->curlet); - sc->sort_v2 = next_slot(let_slots(sc->curlet)); - }}}} - - switch (type(data)) - { - case T_PAIR: - len = s7_list_length(sc, data); /* 0 here == infinite */ - if (len <= 0) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "sort! first argument should be a proper list: ~S", 48), data)); - if (len < 2) - return(data); - if (sort_func) - { - s7_int i = 0; - s7_pointer vec = g_vector(sc, data); - gc_protect_2_via_stack(sc, vec, data); - elements = s7_vector_elements(vec); - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - for (s7_pointer p = data; i < len; i++, p = cdr(p)) - { - if (is_immutable(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); - set_car(p, elements[i]); - } - unstack(sc); /* not pop_stack! */ - return(data); - } - push_stack(sc, OP_SORT_PAIR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original list and func */ - set_car(args, g_vector(sc, data)); - break; - - case T_BYTE_VECTOR: - case T_STRING: - { - s7_int i; - s7_pointer vec; - uint8_t *chrs; - if (is_string(data)) - { - len = string_length(data); - chrs = (uint8_t *)string_value(data); - } - else - { - len = byte_vector_length(data); - chrs = byte_vector_bytes(data); - } - if (len < 2) return(data); - if (is_c_function(lessp)) - { - if (((is_string(data)) && (sc->sort_f == char_lt_b_7pp)) || - ((is_byte_vector(data)) && (sc->sort_f == lt_b_7pp))) - { - qsort((void *)chrs, len, sizeof(uint8_t), byte_less); - return(data); - } - if (((is_string(data)) && (sc->sort_f == char_gt_b_7pp)) || - ((is_byte_vector(data)) && (sc->sort_f == gt_b_7pp))) - { - qsort((void *)chrs, len, sizeof(uint8_t), byte_greater); - return(data); - }} - vec = make_simple_vector(sc, len); - gc_protect_2_via_stack(sc, vec, data); - elements = s7_vector_elements(vec); - if (is_byte_vector(data)) - for (i = 0; i < len; i++) elements[i] = small_int(chrs[i]); - else for (i = 0; i < len; i++) elements[i] = chars[chrs[i]]; - if (sort_func) - { - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - if (is_byte_vector(data)) - for (i = 0; i < len; i++) chrs[i] = (char)integer(elements[i]); - else for (i = 0; i < len; i++) chrs[i] = character(elements[i]); - unstack(sc); /* not pop_stack! */ - return(data); - } - unstack(sc); /* not pop_stack! */ - push_stack(sc, OP_SORT_STRING_END, cons_unchecked(sc, data, lessp), sc->code); - set_car(args, vec); - } - break; - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - { - s7_int i; - s7_pointer vec; - len = vector_length(data); - if (len < 2) - return(data); - if (is_c_function(lessp)) - { - if (sc->sort_f == lt_b_7pp) - { - if (is_float_vector(data)) - qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_less); - else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_less); - return(data); - } - if (sc->sort_f == gt_b_7pp) - { - if (is_float_vector(data)) - qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_greater); - else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_greater); - return(data); - }} - /* currently we have to make the ordinary vector here even if not sf1 - * because the sorter uses vector_element to access sort args (see SORT_DATA in eval). - * This is probably better than passing down getter/setter (fewer allocations). - * get/set macro in eval is SORT_DATA(k) then s7_vector_to_list if pair at start (sort_*_end) - */ - vec = make_vector_1(sc, len, FILLED, T_VECTOR); - gc_protect_2_via_stack(sc, vec, data); - /* we need this vector prefilled because make_real|integer below can cause a GC at any time during that loop, - * and the GC mark process expects the vector to have an s7_pointer at every element. - */ - add_vector(sc, vec); - elements = s7_vector_elements(vec); - check_free_heap_size(sc, len); - if (is_float_vector(data)) - for (i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i)); - else for (i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i)); - if (sort_func) - { - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - if (is_float_vector(data)) - for (i = 0; i < len; i++) float_vector(data, i) = real(elements[i]); - else for (i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]); - unstack(sc); - return(data); - } - set_car(args, vec); - init_temp(sc->y, cons(sc, data, lessp)); - unstack(sc); - push_stack(sc, OP_SORT_VECTOR_END, sc->y, sc->code); /* save and gc protect the original homogeneous vector and func */ - sc->y = sc->unused; - } - break; - - case T_VECTOR: - len = vector_length(data); - if (len < 2) - return(data); - if (sort_func) - { - s7_pointer *els = s7_vector_elements(data); - int32_t typ = type(els[0]); - if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || (typ == T_CHARACTER)) - for (s7_int i = 1; i < len; i++) - if (type(els[i]) != typ) - { - typ = T_FREE; - break; - } - if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp)) - { - if (typ == T_INTEGER) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? int_less_2 : int_greater_2)); - return(data); - } - if (typ == T_REAL) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? dbl_less_2 : dbl_greater_2)); - return(data); - }} - if ((typ == T_STRING) && - ((sc->sort_f == string_lt_b_7pp) || (sc->sort_f == string_gt_b_7pp))) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == string_lt_b_7pp) ? str_less_2 : str_greater_2)); - return(data); - } - if ((typ == T_CHARACTER) && - ((sc->sort_f == char_lt_b_7pp) || (sc->sort_f == char_gt_b_7pp))) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == char_lt_b_7pp) ? chr_less_2 : chr_greater_2)); - return(data); - } - local_qsort_r((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func, (void *)sc); - return(data); - } - break; - - default: - return(method_or_bust(sc, data, sc->sort_symbol, args, wrap_string(sc, "a sortable sequence", 19), 1)); - } - - n = len - 1; - k = (n / 2) + 1; - lx = make_simple_vector(sc, (sc->safety <= NO_SAFETY) ? 4 : 6); - normal_vector_fill(lx, sc->nil); /* make_mutable_integer below can trigger GC, so all elements of lx must be legit */ - init_temp(sc->y, lx); - vector_element(lx, 0) = make_mutable_integer(sc, n); - vector_element(lx, 1) = make_mutable_integer(sc, k); - vector_element(lx, 2) = make_mutable_integer(sc, 0); - vector_element(lx, 3) = make_mutable_integer(sc, 0); - if (sc->safety > NO_SAFETY) - { - vector_element(lx, 4) = make_mutable_integer(sc, 0); - vector_element(lx, 5) = make_integer_unchecked(sc, n * n); - } - push_stack(sc, OP_SORT, args, lx); - sc->y = sc->unused; - return(sc->F); - /* if the comparison function waffles, sort! can hang: (sort! '(1 2 3) (lambda (a b) (= a b))) - * set 'safety to 1 to add a check for this loop, but the "safe" procedures are direct, so unchecked. - */ -} - -/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */ -static s7_pointer vector_into_list(s7_scheme *sc, s7_pointer vect, s7_pointer lst) -{ - s7_pointer *elements = vector_elements(vect); - s7_int i = 0, len = vector_length(vect); - for (s7_pointer p = lst; i < len; i++, p = cdr(p)) - { - if (is_immutable(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, lst)); - set_car(p, elements[i]); - } - return(lst); -} - -static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest) -{ - s7_pointer *elements = vector_elements(source); - s7_int len = vector_length(source); - if (is_float_vector(dest)) - { - s7_double *flts = float_vector_floats(dest); - for (s7_int i = 0; i < len; i++) flts[i] = real(elements[i]); - } - else - { - s7_int *ints = int_vector_ints(dest); - for (s7_int i = 0; i < len; i++) ints[i] = integer(elements[i]); - } - return(dest); -} - -static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest) -{ - s7_pointer *elements = vector_elements(vect); - s7_int len = vector_length(vect); - if (is_byte_vector(dest)) - { - uint8_t *str = (uint8_t *)byte_vector_bytes(dest); - for (s7_int i = 0; i < len; i++) str[i] = (uint8_t)integer(elements[i]); - } - else - { - uint8_t *str = (uint8_t *)string_value(dest); - for (s7_int i = 0; i < len; i++) str[i] = character(elements[i]); - } - return(dest); -} - -#define SORT_N integer(vector_element(sc->code, 0)) -#define SORT_K integer(vector_element(sc->code, 1)) -#define SORT_J integer(vector_element(sc->code, 2)) -#define SORT_K1 integer(vector_element(sc->code, 3)) -#define SORT_CALLS integer(vector_element(sc->code, 4)) -#define SORT_STOP integer(vector_element(sc->code, 5)) -#define SORT_DATA(K) vector_element(car(sc->args), K) -#define SORT_LESSP cadr(sc->args) - -static s7_pointer op_heapsort(s7_scheme *sc) -{ - s7_int n = SORT_N, j, k = SORT_K1; - - if ((n == k) || (k > ((s7_int)(n / 2)))) /* k == n == 0 is the first case */ - return(sc->code); - if (sc->safety > NO_SAFETY) - { - SORT_CALLS++; - if (SORT_CALLS > SORT_STOP) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "sort! is caught in an infinite loop, comparison: ~S", 51), SORT_LESSP)); - } - j = 2 * k; - SORT_J = j; - if (j < n) - { - s7_pointer lx = SORT_LESSP; /* cadr of sc->args */ - push_stack_direct(sc, OP_SORT1); - if (needs_copied_args(lx)) - sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); - else sc->args = with_list_t2(SORT_DATA(j), SORT_DATA(j + 1)); - sc->code = lx; - sc->value = sc->T; /* for eval */ - } - else sc->value = sc->F; - return(NULL); -} - -static bool op_sort1(s7_scheme *sc) -{ - s7_int j = SORT_J, k = SORT_K1; - s7_pointer lx = SORT_LESSP; - if (is_true(sc, sc->value)) - { - j = j + 1; - SORT_J = j; - } - push_stack_direct(sc, OP_SORT2); - if (needs_copied_args(lx)) - sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j)); - else sc->args = with_list_t2(SORT_DATA(k), SORT_DATA(j)); - sc->code = lx; - return(false); -} - -static bool op_sort2(s7_scheme *sc) -{ - s7_int j = SORT_J, k = SORT_K1; - if (is_true(sc, sc->value)) - { - s7_pointer lx = SORT_DATA(j); - SORT_DATA(j) = SORT_DATA(k); - SORT_DATA(k) = lx; - } - else return(true); - SORT_K1 = SORT_J; - return(false); -} - -static bool op_sort(s7_scheme *sc) -{ - /* coming in sc->args is sort args (data less?), sc->code = #(n k 0 ...) - * here we call the inner loop until k <= 0 [the local k! -- this is tricky because scheme passes args by value] - */ - s7_int k = SORT_K; - if (k > 0) - { - SORT_K = k - 1; - SORT_K1 = k - 1; - push_stack_direct(sc, OP_SORT); - return(false); - } - return(true); -} - -static bool op_sort3(s7_scheme *sc) -{ - s7_int n = SORT_N; - s7_pointer lx; - if (n <= 0) - { - sc->value = car(sc->args); - return(true); - } - lx = SORT_DATA(0); - SORT_DATA(0) = SORT_DATA(n); - SORT_DATA(n) = lx; - SORT_N = n - 1; - SORT_K1 = 0; - push_stack_direct(sc, OP_SORT3); - return(false); -} - - -/* -------- hash tables -------- */ - -static void free_hash_table(s7_scheme *sc, s7_pointer table) -{ - if (hash_table_entries(table) > 0) - { - hash_entry_t **entries = hash_table_elements(table); - s7_int len = hash_table_mask(table) + 1; - for (s7_int i = 0; i < len; i++) - { - hash_entry_t *n; - for (hash_entry_t *p = entries[i++]; p; p = n) - { - n = hash_entry_next(p); - liberate_block(sc, p); - } - for (hash_entry_t *p = entries[i]; p; p = n) - { - n = hash_entry_next(p); - liberate_block(sc, p); - }}} - liberate(sc, hash_table_block(table)); -} - -static hash_entry_t *make_hash_entry(s7_scheme *sc, s7_pointer key, s7_pointer value, s7_int raw_hash) -{ - hash_entry_t *p = (hash_entry_t *)mallocate_block(sc); - hash_entry_key(p) = key; - hash_entry_set_value(p, value); - hash_entry_set_raw_hash(p, raw_hash); - return(p); -} - - -/* -------------------------------- hash-table? -------------------------------- */ -bool s7_is_hash_table(s7_pointer p) {return(is_hash_table(p));} - -static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" - #define Q_is_hash_table sc->pl_bt - check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, args); -} - - -/* -------------------------------- hash-table-entries -------------------------------- */ -static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj" - #define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) - - if (!is_hash_table(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->hash_table_entries_symbol, args, sc->type_names[T_HASH_TABLE])); - return(make_integer(sc, hash_table_entries(car(args)))); -} - -static s7_int hash_table_entries_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_hash_table(p)) - return(integer(method_or_bust_p(sc, p, sc->hash_table_entries_symbol, sc->type_names[T_HASH_TABLE]))); - return(hash_table_entries(p)); -} - - -/* -------------------------------- hash-table-key|value-typer -------------------------------- */ -static s7_pointer g_hash_table_key_typer(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_key_typer "(hash-table-key-typer hash) returns the hash-table's key type checking function" - #define Q_hash_table_key_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol) - - s7_pointer h = car(args); - if (!is_hash_table(h)) return(sole_arg_method_or_bust(sc, h, sc->hash_table_key_typer_symbol, args, sc->type_names[T_HASH_TABLE])); - if (is_typed_hash_table(h)) return(hash_table_key_typer(h)); - return(sc->F); -} - -static s7_pointer g_hash_table_value_typer(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_value_typer "(hash-table-value-typer hash) returns the hash-table's value type checking function" - #define Q_hash_table_value_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol) - - s7_pointer h = car(args); - if (!is_hash_table(h)) return(sole_arg_method_or_bust(sc, h, sc->hash_table_value_typer_symbol, args, sc->type_names[T_HASH_TABLE])); - if (is_typed_hash_table(h)) return(hash_table_value_typer(h)); - return(sc->F); -} - -static s7_pointer make_hash_table_procedures(s7_scheme *sc) -{ - s7_pointer x = cons(sc, sc->T, sc->T); /* checker, mapped */ - set_opt1_any(x, sc->T); /* key */ - set_opt2_any(x, sc->T); /* value */ - return(x); -} - -static s7_pointer copy_hash_table_procedures(s7_scheme *sc, s7_pointer table) -{ - if (is_pair(hash_table_procedures(table))) - { - s7_pointer x = cons(sc, hash_table_procedures_checker(table), hash_table_procedures_mapper(table)); - set_opt1_any(x, hash_table_key_typer(table)); - set_opt2_any(x, hash_table_value_typer(table)); - return(x); - } - return(sc->nil); -} - -static void check_hash_table_typer(s7_scheme *sc, s7_pointer caller, s7_pointer h, s7_pointer typer) -{ - if (is_c_function(typer)) - { - s7_pointer sig = c_function_signature(typer); - if ((sig != sc->pl_bt) && - (is_pair(sig)) && - ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a boolean procedure", 19)); - if (!c_function_name(typer)) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); - } - else - { - if (!is_any_closure(typer)) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); - if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); - } - if (!s7_is_aritable(sc, typer, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: the second argument, ~S, (the type checker) should accept one argument", 74), caller, typer)); - if (is_c_function(typer)) - { - if (!c_function_symbol(typer)) - c_function_symbol(typer) = make_symbol(sc, c_function_name(typer), c_function_name_length(typer)); - if (c_function_has_simple_elements(typer)) - { - if (caller == sc->hash_table_value_typer_symbol) - set_has_simple_values(h); - else - { - set_has_simple_keys(h); - if (symbol_type(c_function_symbol(typer)) != T_FREE) - set_has_hash_key_type(h); - }}} - if (is_null(hash_table_procedures(h))) - hash_table_set_procedures(h, make_hash_table_procedures(sc)); - set_is_typed_hash_table(h); -} - -static s7_pointer g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args) -{ - s7_pointer h = car(args), typer = cadr(args); - if (!is_hash_table(h)) - wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-key-typer", 25), 1, h, sc->type_names[T_HASH_TABLE]); - - if (is_boolean(typer)) /* remove current typer, if any */ - { - if (is_typed_hash_table(h)) - { - hash_table_set_key_typer(h, sc->T); - if (hash_table_value_typer(h) == sc->T) - { - /* clear_is_typed_hash_table(h); */ - clear_has_simple_keys(h); - /* clear_has_hash_key_type?? looks redundant */ - }}} - else - { - check_hash_table_typer(sc, sc->hash_table_key_typer_symbol, h, typer); - hash_table_set_key_typer(h, typer); - } - return(typer); -} - -static s7_pointer g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args) -{ - s7_pointer h = car(args), typer = cadr(args); - if (!is_hash_table(h)) - wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-value-typer", 27), 1, h, sc->type_names[T_HASH_TABLE]); - - if (is_boolean(typer)) /* remove current typer, if any */ - { - if (is_typed_hash_table(h)) - { - hash_table_set_value_typer(h, sc->T); - if (hash_table_key_typer(h) == sc->T) - { - /* clear_is_typed_hash_table(h); */ - clear_has_simple_values(h); - }}} - else - { - check_hash_table_typer(sc, sc->hash_table_value_typer_symbol, h, typer); - hash_table_set_value_typer(h, typer); - } - return(typer); -} - - -/* ---------------- hash map and equality tables ---------------- */ -/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? string-ci=? char=? char-ci=? (default=equal?) */ -#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key) - -static hash_map_t eq_hash_map[NUM_TYPES]; -static hash_map_t string_eq_hash_map[NUM_TYPES]; -static hash_map_t char_eq_hash_map[NUM_TYPES]; -static hash_map_t closure_hash_map[NUM_TYPES]; -static hash_map_t equivalent_hash_map[NUM_TYPES]; -static hash_map_t c_function_hash_map[NUM_TYPES]; -#if (!WITH_PURE_S7) -static hash_map_t string_ci_eq_hash_map[NUM_TYPES]; -static hash_map_t char_ci_eq_hash_map[NUM_TYPES]; -#endif -/* also default_hash_map */ - - -/* ---------------- hash-code ---------------- */ -/* eqfunc handling which will require other dummy tables */ - -static s7_pointer make_dummy_hash_table(s7_scheme *sc) /* make the absolute minimal hash-table that can support hash-code */ -{ - s7_pointer table = alloc_pointer(sc); - set_type_bit(table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP); - hash_table_mapper(table) = default_hash_map; - return(table); -} - -s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer eqfunc) -{ - return(default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj)); -} - -static s7_pointer g_hash_code(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_code "(hash-code obj (eqfunc)) returns an integer suitable for use as a hash code for obj." - #define Q_hash_code s7_make_signature(sc, 3, sc->is_integer_symbol, sc->T, sc->T) - s7_pointer obj = car(args); - if ((is_pair(cdr(args))) && - (!is_procedure(cadr(args)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "hash-code second argument (currently ignored) should be a function: ~S", 70), cadr(args))); - return(make_integer(sc, default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj))); -} - - -static bool (*equals[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); -static bool (*equivalents[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); - -static hash_entry_t *(*default_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key); -static hash_entry_t *(*equal_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key); - - -/* ---------------- hash empty ---------------- */ -static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(sc->unentry);} - -/* ---------------- hash syntax ---------------- */ -static s7_int hash_map_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(syntax_symbol(key)));} - -static hash_entry_t *hash_equal_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc = hash_loc(sc, table, key) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((is_syntax(hash_entry_key(x))) && - (syntax_symbol(hash_entry_key(x)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ - return(x); - return(sc->unentry); -} - -/* ---------------- hash symbols ---------------- */ -static s7_int hash_map_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));} - -static hash_entry_t *hash_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - for (hash_entry_t *x = hash_table_element(table, pointer_map(key) & hash_table_mask(table)); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); - return(sc->unentry); -} - - -/* ---------------- hash numbers ---------------- */ -static s7_int hash_float_location(s7_double x) {return(((is_NaN(x)) || (is_inf(x))) ? 0 : (s7_int)floor(fabs(x)));} - -static s7_int hash_map_int(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(s7_int_abs(integer(key)));} -static s7_int hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(hash_float_location(real(key)));} -static s7_int hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(hash_float_location(real_part(key)));} - -static s7_int hash_map_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* if numerator is -9223372036854775808, s7_int_abs overflows -- need to divide, then abs: -9223372036854775808/3: -3074457345618258602 3074457345618258602 - * (s7_int)floorl(fabsl(fraction(key))) is no good here, 3441313796169221281/1720656898084610641: 1 2 (in valgrind), - * floor ratio is 1: (- (* 2 1720656898084610641) 3441313796169221281) -> 1 - * or (gmp:) 1.999999999999999999418826611445214136431E0, so the floorl(fabsl) version is wrong - */ - return(s7_int_abs(numerator(key) / denominator(key))); -} - -#if WITH_GMP -static s7_int hash_map_big_int(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* may need to use quotient here */ - mpz_abs(sc->mpz_1, big_integer(key)); - return(mpz_get_si(sc->mpz_1)); /* returns the bits that fit */ -} - -static s7_int hash_map_big_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - mpq_abs(sc->mpq_1, big_ratio(key)); - mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_1), mpq_denref(sc->mpq_1)); - return(mpz_get_si(sc->mpz_1)); -} - -static s7_int hash_map_big_real_1(s7_scheme *sc, s7_pointer table, mpfr_t key) -{ - if ((mpfr_nan_p(key)) || (mpfr_inf_p(key))) return(0); - mpfr_abs(sc->mpfr_1, key, MPFR_RNDN); - /* mpfr_get_si returns most-positive-int if > 2^63! luckily there aren't any more of these */ - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); /* floor not round */ - return(mpz_get_si(sc->mpz_1)); -} - -static s7_int hash_map_big_real(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return(hash_map_big_real_1(sc, table, big_real(key))); -} - -static s7_int hash_map_big_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return(hash_map_big_real_1(sc, table, mpc_realref(big_complex(key)))); -} -#endif - -static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_pointer key) -{ - s7_double old_eps = sc->equivalent_float_epsilon; - bool (*equiv)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equivalents[type(key)]; - sc->equivalent_float_epsilon = sc->hash_table_float_epsilon; - for (; bin; bin = hash_entry_next(bin)) - if (equiv(sc, key, hash_entry_key(bin), NULL)) - { - sc->equivalent_float_epsilon = old_eps; - return(bin); - } - sc->equivalent_float_epsilon = old_eps; - return(NULL); -} - -static hash_entry_t *hash_number_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* for equivalent? and =, kind of complicated because two bins can be involved if the key is close to an integer */ -#if WITH_GMP - /* first try loc from hash_loc, then get key-floor(key) [with abs], and check against - * epsilon: diff < eps call find big in bin-1, diff > 1.0-eps call same in bin+1 - */ - s7_int loc1, hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key); - s7_int hash_loc = loc & hash_mask; - hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); - if (i1) return(i1); - - if (is_real(key)) - { - s7_pointer res = any_real_to_mpfr(sc, key, sc->mpfr_1); - if (res) return(sc->unentry); - } - else - if (is_t_complex(key)) - mpfr_set_d(sc->mpfr_1, real_part(key), MPFR_RNDN); - else mpfr_set(sc->mpfr_1, mpc_realref(big_complex(key)), MPFR_RNDN); - - /* mpfr_1 is big_real, so we can use hash_loc of big_real (and can ignore NaN's): */ - mpfr_abs(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - mpfr_add_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD); - loc1 = mpz_get_si(sc->mpz_1); - if (loc1 != loc) - { - if (loc1 == hash_table_mask(table)) loc1 = 0; - hash_loc = loc1 & hash_mask; - i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); - return((i1) ? i1 : sc->unentry); - } - mpfr_sub_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD); - loc1 = mpz_get_si(sc->mpz_1); - if (loc1 != loc) - { - if (loc1 < 0) loc1 = hash_table_mask(table); - hash_loc = loc1 & hash_mask; - i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); - if (i1) return(i1); - } - return(sc->unentry); -#else - s7_double keyval = (is_real(key)) ? s7_real(key) : real_part(key); - s7_double fprobe = fabs(keyval); - s7_int iprobe = (s7_int)floor(fprobe); - s7_double bin_dist = fprobe - iprobe; - s7_int loc = iprobe & hash_table_mask(table); - hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, loc), key); - if (i1) return(i1); - - if (bin_dist <= sc->hash_table_float_epsilon) /* maybe closest is below iprobe, key+eps>iprobe but key maps to iprobe-1 */ - i1 = find_number_in_bin(sc, hash_table_element(table, (loc > 0) ? loc - 1 : hash_table_mask(table)), key); - else - if (bin_dist >= (1.0 - sc->hash_table_float_epsilon)) - i1 = find_number_in_bin(sc, hash_table_element(table, (loc < hash_table_mask(table)) ? loc + 1 : 0), key); - return((i1) ? i1 : sc->unentry); -#endif -} - -static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ -#if WITH_GMP - if ((is_t_integer(key)) || (is_t_big_integer(key))) -#else - if (is_t_integer(key)) -#endif - { - s7_int hash_mask = hash_table_mask(table); - hash_entry_t *x; -#if WITH_GMP - s7_int kv = (is_t_integer(key)) ? integer(key) : mpz_get_si(big_integer(key)); -#else - s7_int kv = integer(key); -#endif - s7_int loc = s7_int_abs(kv) & hash_mask; - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) -#if WITH_GMP - if (is_t_integer(hash_entry_key(x))) - { - if (integer(hash_entry_key(x)) == kv) - return(x); - } - else - if ((is_t_big_integer(hash_entry_key(x))) && - (mpz_get_si(big_integer(hash_entry_key(x))) == kv)) - return(x); -#else - if (integer(hash_entry_key(x)) == kv) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* if a hash-table has only t_real keys, its checker is hash_float, but we might use a t_big_real key */ -#if WITH_GMP - if ((is_t_real(key)) || (is_t_big_real(key))) -#else - if (is_t_real(key)) -#endif - { - s7_double keyval; - s7_int loc, hash_mask; -#if WITH_GMP - if (is_t_real(key)) - { - keyval = real(key); - if (is_NaN(keyval)) return(sc->unentry); - } - else - { - if (mpfr_nan_p(big_real(key))) return(sc->unentry); - keyval = mpfr_get_d(big_real(key), MPFR_RNDN); - } -#else - keyval = real(key); - if (is_NaN(keyval)) return(sc->unentry); -#endif - hash_mask = hash_table_mask(table); - loc = hash_float_location(keyval) & hash_mask; - - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_real(hash_entry_key(x))) && - (keyval == real(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_real(hash_entry_key(x))) && - (mpfr_cmp_d(big_real(hash_entry_key(x)), keyval) == 0) && - (!mpfr_nan_p(big_real(hash_entry_key(x))))) - return(x); -#endif - }} - return(sc->unentry); -} - -static hash_entry_t *hash_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (num_eq_b_7pp(sc, key, hash_entry_key(x))) - return(x); - return(sc->unentry); -} - -static hash_entry_t *hash_real_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ -#if WITH_GMP - if ((is_t_real(key)) && (is_NaN(real(key)))) return(sc->unentry); - if ((is_t_big_real(key)) && (mpfr_nan_p(big_real(key)))) return(sc->unentry); - return(hash_num_eq(sc, table, key)); -#else - return((is_NaN(s7_real(key))) ? sc->unentry : hash_num_eq(sc, table, key)); -#endif -} - -static hash_entry_t *hash_complex_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ -#if WITH_GMP - if ((is_t_complex(key)) && ((is_NaN(real_part(key))) || (is_NaN(imag_part(key))))) return(sc->unentry); - if ((is_t_big_complex(key)) && ((mpfr_nan_p(mpc_realref(big_complex(key)))) || (mpfr_nan_p(mpc_imagref(big_complex(key)))))) return(sc->unentry); - return(hash_num_eq(sc, table, key)); -#else - return(((is_NaN(real_part(key))) || (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc, table, key)); -#endif -} - -static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_number(key)) - { -#if (!WITH_GMP) - s7_int hash_mask = hash_table_mask(table); - hash_map_t map = hash_table_mapper(table)[type(key)]; - if (hash_table_checker(table) == hash_int) /* surely by far the most common case? only ints */ - { - s7_int keyi = integer(key); - s7_int loc = map(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (keyi == integer(hash_entry_key(x))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ - return(x); - } - else -#endif - return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key)); - } - return(sc->unentry); -} - - -/* ---------------- hash characters ---------------- */ -static s7_int hash_map_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(character(key));} - -static hash_entry_t *hash_char(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_character(key)) - { - /* return(hash_eq(sc, table, key)); - * but I think if we get here at all, we have to be using default_hash_checks|maps -- see hash_symbol above. - */ - s7_int loc = character(key) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); - } - return(sc->unentry); -} - -#if (!WITH_PURE_S7) -static s7_int hash_map_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(upper_character(key));} - -static hash_entry_t *hash_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_character(key)) - { - s7_int hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (upper_character(key) == upper_character(hash_entry_key(x))) - return(x); - } - return(sc->unentry); -} -#endif - - -/* ---------------- hash strings ---------------- */ -static s7_int hash_map_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (string_hash(key) == 0) - string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); - return(string_hash(key)); -} - -static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_string(key)) - { - hash_entry_t *x; - s7_int key_len = string_length(key), hash_mask = hash_table_mask(table); - uint64_t hash; - const char *key_str = string_value(key); - - if (string_hash(key) == 0) - string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); - hash = string_hash(key); - if (key_len <= 8) - { - for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if ((hash == string_hash(hash_entry_key(x))) && - (key_len == string_length(hash_entry_key(x)))) - return(x); - } - else - for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if ((hash == string_hash(hash_entry_key(x))) && - (key_len == string_length(hash_entry_key(x))) && /* these are scheme strings, so we can't assume 0=end of string */ - (strings_are_equal_with_length(key_str, string_value(hash_entry_key(x)), key_len))) - return(x); - } - return(sc->unentry); -} - -#if (!WITH_PURE_S7) -static s7_int hash_map_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int len = string_length(key); - return((len == 0) ? 0 : (len + (uppers[(int32_t)(string_value(key)[0])] << 4))); -} - -static hash_entry_t *hash_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_string(key)) - { - s7_int hash_mask = hash_table_mask(table); - s7_int hash = hash_map_ci_string(sc, table, key); - for (hash_entry_t *x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if (scheme_strequal_ci(key, hash_entry_key(x))) - return(x); - } - return(sc->unentry); -} -#endif - - -/* ---------------- hash eq? ---------------- */ -static s7_int hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(type(key));} - -static s7_int hash_map_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));} - -static hash_entry_t *hash_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* explicit eq? as hash equality func or (for example) symbols as keys */ - s7_int hash_mask = hash_table_mask(table); - s7_int loc = pointer_map(key) & hash_mask; /* hash_map_eq */ - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); - return(sc->unentry); -} - -/* ---------------- hash eqv? ---------------- */ -static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - hash_entry_t *x; - s7_int hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key) & hash_mask; - if (is_number(key)) - { -#if WITH_GMP - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (numbers_are_eqv(sc, key, hash_entry_key(x))) - return(x); -#else - uint8_t key_type = type(key); - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((key_type == type(hash_entry_key(x))) && - (numbers_are_eqv(sc, key, hash_entry_key(x)))) - return(x); -#endif - } - else - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (s7_is_eqv(sc, key, hash_entry_key(x))) - return(x); - return(sc->unentry); -} - -/* ---------------- hash equal? ---------------- */ -static s7_int hash_map_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* hash-tables are equal if key/values match independent of table size and entry order. - * if not using equivalent?, hash_table_checker|mapper must also be the same. - * Keys are supposed to be constant while keys, so a hash-table shouldn't be a key of itself. - */ - return(hash_table_entries(key)); -} - -static s7_int hash_map_int_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (vector_length(key) == 0) - return(0); - if (vector_length(key) == 1) - return(s7_int_abs(int_vector(key, 0))); - return(vector_length(key) + s7_int_abs(int_vector(key, 0)) + s7_int_abs(int_vector(key, 1))); /* overflow is ok here (in + or abs), as long as it's consistent */ -} - -static s7_int hash_map_byte_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (byte_vector_length(key) == 0) - return(0); - if (byte_vector_length(key) == 1) - return((s7_int)byte_vector(key, 0)); - return(byte_vector_length(key) + byte_vector(key, 0) + byte_vector(key, 1)); -} - -static s7_int hash_map_float_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (vector_length(key) == 0) - return(0); - if (vector_length(key) == 1) - return(hash_float_location(float_vector(key, 0))); - return(vector_length(key) + hash_float_location(float_vector(key, 0)) + hash_float_location(float_vector(key, 1))); -} - -static s7_int hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if ((vector_length(key) == 0) || - (is_sequence(vector_element(key, 0)))) - return(vector_length(key)); - if ((vector_length(key) == 1) || - (is_sequence(vector_element(key, 1)))) - return(hash_loc(sc, table, vector_element(key, 0))); - return(vector_length(key) + hash_loc(sc, table, vector_element(key, 0)) + hash_loc(sc, table, vector_element(key, 1))); /* see above */ -} - - -static s7_int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_pointer f = hash_table_procedures_mapper(table); - if (f == sc->unused) - error_nr(sc, make_symbol(sc, "hash-map-recursion", 18), - set_elist_1(sc, wrap_string(sc, "hash-table map function called recursively", 42))); - /* check_stack_size(sc); -- perhaps clear typers as well here or save/restore hash-table-procedures */ - gc_protect_via_stack(sc, f); - hash_table_set_procedures_mapper(table, sc->unused); - sc->value = s7_call(sc, f, set_plist_1(sc, key)); - unstack(sc); - hash_table_set_procedures_mapper(table, f); - if (!s7_is_integer(sc->value)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "hash-table map function should return an integer: ~S", 52), sc->value)); - return(integer(sc->value)); -} - -static s7_int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* lets are equal if same symbol/value pairs, independent of order, taking into account shadowing - * (length (inlet 'a 1 'a 2)) = 2 - * but this counts as just one entry from equal?'s point of view, so if more than one entry, we have a problem. - * (equal? (inlet 'a 1) (inlet 'a 3 'a 2 'a 1)) = #t - * also currently equal? follows outlet, but that is ridiculous here, so in this case hash equal? - * is not the same as equal? Surely anyone using lets as keys wants eq? - */ - s7_pointer slot; - s7_int slots; - - if ((key == sc->rootlet) || - (!tis_slot(let_slots(key)))) - return(0); - slot = let_slots(key); - if (!tis_slot(next_slot(slot))) - { - if (is_sequence(slot_value(slot))) /* avoid loop if cycles */ - return(pointer_map(slot_symbol(slot))); - return(pointer_map(slot_symbol(slot)) + hash_loc(sc, table, slot_value(slot))); - } - slots = 0; - for (; tis_slot(slot); slot = next_slot(slot)) - if (!is_matched_symbol(slot_symbol(slot))) - { - set_match_symbol(slot_symbol(slot)); - slots++; - } - for (slot = let_slots(key); tis_slot(slot); slot = next_slot(slot)) - clear_match_symbol(slot_symbol(slot)); - - if (slots != 1) - return(slots); - slot = let_slots(key); - if (is_sequence(slot_value(slot))) /* avoid loop if cycles */ - return(pointer_map(slot_symbol(slot))); - return(pointer_map(slot_symbol(slot)) + hash_loc(sc, table, slot_value(slot))); -} - -static hash_entry_t *hash_equal_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc = hash_loc(sc, table, key) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_key(x) == key) - return(x); - return(sc->unentry); -} - -static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int keyint = integer(key); - s7_int loc = s7_int_abs(keyint) & hash_table_mask(table); /* hash_loc -> hash_map_integer */ - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_integer(hash_entry_key(x))) && - (keyint == integer(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_integer(hash_entry_key(x))) && - (mpz_cmp_si(big_integer(hash_entry_key(x)), keyint) == 0)) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int keynum = numerator(key), keyden = denominator(key); - s7_int loc = s7_int_abs(keynum / keyden) & hash_table_mask(table); /* hash_loc -> hash_map_ratio */ - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_ratio(hash_entry_key(x))) && - (keynum == numerator(hash_entry_key(x))) && - (keyden == denominator(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_ratio(hash_entry_key(x))) && - (keynum == mpz_get_si(mpq_numref(big_ratio(hash_entry_key(x))))) && - (keyden == mpz_get_si(mpq_denref(big_ratio(hash_entry_key(x)))))) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc; - s7_double keydbl = real(key); - if (is_NaN(keydbl)) return(sc->unentry); - loc = hash_float_location(keydbl) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_real(hash_entry_key(x))) && - (keydbl == real(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_real(hash_entry_key(x))) && - (mpfr_cmp_d(big_real(hash_entry_key(x)), keydbl) == 0) && - (!mpfr_nan_p(big_real(hash_entry_key(x))))) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc; - s7_double keyrl = real_part(key); - s7_double keyim = imag_part(key); -#if WITH_GMP - if ((is_NaN(keyrl)) || (is_NaN(keyim))) return(sc->unentry); -#endif - loc = hash_float_location(keyrl) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_complex(hash_entry_key(x))) && - (keyrl == real_part(hash_entry_key(x))) && - (keyim == imag_part(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_complex(hash_entry_key(x))) && - (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(x))), keyrl) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(x))), keyim) == 0) && - (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(x))))) && - (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(x)))))) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - bool (*equal)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equals[type(key)]; - s7_int hash = hash_loc(sc, table, key); - s7_int loc = hash & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - if (equal(sc, key, hash_entry_key(x), NULL)) - return(x); - return(sc->unentry); -} - - -/* ---------------- hash c_functions ---------------- */ -static s7_int hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_function f = c_function_call(hash_table_procedures_mapper(table)); - return(integer(f(sc, with_list_t1(key)))); -} - -static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key); - -static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_pair(hash_table_procedures(table))) - { - s7_int hash_mask = hash_table_mask(table); - s7_function f = c_function_call(hash_table_procedures_checker(table)); - s7_int hash = hash_loc(sc, table, key); - s7_int loc = hash & hash_mask; - set_car(sc->t2_1, key); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - { - set_car(sc->t2_2, hash_entry_key(x)); - if (is_true(sc, f(sc, sc->t2_1))) - return(x); - } - return(sc->unentry); - } - return(hash_equal(sc, table, key)); -} - -static int32_t len_upto_8(s7_pointer p) -{ - int32_t i = 0; /* unrolling this loop saves 10-15% */ - for (s7_pointer x = p; (is_pair(x)) && (i < 8); i++, x = cdr(x)); - return(i); -} - -static s7_int hash_map_pair(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* len+loc(car) is not horrible, but it means (for example) every list '(set! ...) is hashed to the same location, - * so at least we need to take cadr into account if possible. Better would combine the list_length - * with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs. - */ - s7_pointer p1 = cdr(key); - s7_int loc = 0; - - if (!is_sequence(car(key))) - loc = hash_loc(sc, table, car(key)) + 1; - else - if ((is_pair(car(key))) && - (!is_sequence(caar(key)))) - loc = hash_loc(sc, table, caar(key)) + 1; - if (is_pair(p1)) - { - if (!is_sequence(car(p1))) - loc += hash_loc(sc, table, car(p1)) + 1; - else - if ((is_pair(car(p1))) && - (!is_sequence(caar(p1)))) - loc += hash_loc(sc, table, caar(p1)) + 1; - } - loc = (loc << 3) | len_upto_8(key); - return(loc); -} - -static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_pair(hash_table_procedures(table))) - { - s7_int hash_mask = hash_table_mask(table); - s7_pointer f = hash_table_procedures_checker(table); - s7_int hash = hash_loc(sc, table, key); - s7_int loc = hash & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - if (is_true(sc, s7_call(sc, f, set_plist_2(sc, key, hash_entry_key(x))))) - return(x); - return(sc->unentry); - } - return(hash_equal(sc, table, key)); -} - -static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return((*(equal_hash_checks[type(key)]))(sc, table, key)); -} - -/* ---------------- hash equivalent? ---------------- */ -static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - hash_entry_t *x; - s7_int hash, loc; - - if (is_number(key)) - { -#if WITH_GMP - if (!is_nan_b_7p(sc, key)) - return(hash_number_equivalent(sc, table, key)); -#else - x = hash_number_equivalent(sc, table, key); - if ((x != sc->unentry) || (!is_nan_b_7p(sc, key))) - return(x); -#endif - for (x = hash_table_element(table, 0); x; x = hash_entry_next(x)) /* NaN is mapped to 0 */ - if (is_nan_b_7p(sc, hash_entry_key(x))) /* all NaN's are the same to equivalent? */ - return(x); - return(sc->unentry); - } - hash = hash_loc(sc, table, key); - loc = hash & hash_table_mask(table); - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_key(x) == key) - return(x); - - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((hash_entry_raw_hash(x) == hash) && - (s7_is_equivalent(sc, hash_entry_key(x), key))) - return(x); - return(sc->unentry); -} - -static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash) -{ - return((is_null(hash_table_procedures(hash))) && - (hash_table_mapper(hash) == default_hash_map) && - (hash_table_checker(hash) != hash_equal) && - (hash_table_checker(hash) != hash_equivalent) && - (hash_table_checker(hash) != hash_closure) && - (hash_table_checker(hash) != hash_c_function)); -} - - -/* -------------------------------- make-hash-table -------------------------------- */ -s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size) -{ - s7_pointer table; - block_t *els; - /* size is rounded up to the next power of 2 */ - - if (size < 2) - size = 2; - else - if ((size & (size - 1)) != 0) /* already 2^n ? */ - { - if ((size & (size + 1)) != 0) /* already 2^n - 1 ? */ - { - size--; - size |= (size >> 1); - size |= (size >> 2); - size |= (size >> 4); - size |= (size >> 8); - size |= (size >> 16); - size |= (size >> 32); - } - size++; - } - els = (block_t *)callocate(sc, size * sizeof(hash_entry_t *)); - new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE); - hash_table_mask(table) = size - 1; - hash_table_set_block(table, els); - hash_table_elements(table) = (hash_entry_t **)(block_data(els)); - hash_table_checker(table) = hash_empty; - hash_table_mapper(table) = default_hash_map; - hash_table_entries(table) = 0; - hash_table_set_procedures(table, sc->nil); - add_hash_table(sc, table); - return(table); -} - -static bool compatible_types(s7_scheme *sc, s7_pointer eq_type, s7_pointer value_type) -{ - if (eq_type == sc->T) return(true); - if (eq_type == value_type) return(true); - if (eq_type == sc->is_number_symbol) /* only = among built-ins, so other cases aren't needed */ - return((value_type == sc->is_integer_symbol) || - (value_type == sc->is_real_symbol) || - (value_type == sc->is_complex_symbol) || - (value_type == sc->is_rational_symbol)); - return(false); -} - -static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args); -static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args); - -static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - #define H_make_hash_table "(make-hash-table (size 8) eq-func typer) returns a new hash table. eq-func is the function \ -used to check equality of keys; it usually defaults to equal?. typer sets the types of the keys and values that are allowed \ -in the table; it is a cons, defaulting to (cons #t #t) which means any types are allowed.\n" - #define Q_make_hash_table s7_make_signature(sc, 4, sc->is_hash_table_symbol, sc->is_integer_symbol, \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) - s7_int size = sc->default_hash_table_length; - - if (is_not_null(args)) - { - s7_pointer p = car(args); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, caller, args, sc->type_names[T_INTEGER], 1)); - size = s7_integer_clamped_if_gmp(sc, p); - if (size <= 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */ - out_of_range_error_nr(sc, caller, int_one, p, wrap_string(sc, "it should be a positive integer", 31)); - if ((size > sc->max_vector_length) || - (size >= (1LL << 32LL))) - out_of_range_error_nr(sc, caller, int_one, p, it_is_too_large_string); - - if (is_not_null(cdr(args))) - { - s7_pointer proc; - s7_pointer ht = s7_make_hash_table(sc, size); - /* check for typers */ - if (is_pair(cddr(args))) - { - s7_pointer typers = caddr(args); - if (is_pair(typers)) - { - s7_pointer keyp = car(typers), valp = cdr(typers); - if ((keyp != sc->T) || (valp != sc->T)) /* one of them is a type checker */ - { - if (((keyp != sc->T) && (!is_c_function(keyp)) && (!is_any_closure(keyp))) || - ((valp != sc->T) && (!is_c_function(valp)) && (!is_any_closure(valp)))) - wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23)); - - if ((keyp != sc->T) && - (!s7_is_aritable(sc, keyp, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), - caller, typers)); - hash_table_set_procedures(ht, make_hash_table_procedures(sc)); - hash_table_set_key_typer(ht, keyp); - hash_table_set_value_typer(ht, valp); - if (is_c_function(keyp)) - { - if (!c_function_name(keyp)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), - caller, typers)); - if (c_function_has_simple_elements(keyp)) - set_has_simple_keys(ht); - if (!c_function_symbol(keyp)) - c_function_symbol(keyp) = make_symbol(sc, c_function_name(keyp), c_function_name_length(keyp)); - if (symbol_type(c_function_symbol(keyp)) != T_FREE) - set_has_hash_key_type(ht); - /* c_function_marker is not currently used in this context */ - - /* now a consistency check for eq-func and key type */ - proc = cadr(args); - if (is_c_function(proc)) - { - s7_pointer eq_sig = c_function_signature(proc); - if ((eq_sig) && - (is_pair(eq_sig)) && - (is_pair(cdr(eq_sig))) && - (!compatible_types(sc, cadr(eq_sig), c_function_symbol(keyp)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, the key type function is not compatible with the equality function: ~S", 97), - caller, typers)); - }} - else - if ((is_any_closure(keyp)) && - (!is_symbol(find_closure(sc, keyp, closure_let(keyp))))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), - caller, typers)); - if ((valp != sc->T) && - (!s7_is_aritable(sc, valp, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), - caller, typers)); - if (is_c_function(valp)) - { - if (!c_function_name(valp)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), - caller, typers)); - if (c_function_has_simple_elements(valp)) - set_has_simple_values(ht); - if (!c_function_symbol(valp)) - c_function_symbol(valp) = make_symbol(sc, c_function_name(valp), c_function_name_length(valp)); - if (symbol_type(c_function_symbol(valp)) != T_FREE) - set_has_hash_value_type(ht); - } - else - if ((is_any_closure(valp)) && - (!is_symbol(find_closure(sc, valp, closure_let(valp))))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), - caller, typers)); - set_is_typed_hash_table(ht); - }} - else - if (typers != sc->F) - wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "either #f or (cons key-type-check value-type-check)", 51)); - } - - /* check eq_func */ - proc = cadr(args); - - if (is_c_function(proc)) - { - hash_set_chosen(ht); - - if (!s7_is_aritable(sc, proc, 2)) - wrong_type_error_nr(sc, caller, 2, proc, an_eq_func_string); - - if (c_function_call(proc) == g_is_equal) - { - hash_table_checker(ht) = hash_equal; - return(ht); - } - if (c_function_call(proc) == g_is_equivalent) - { - hash_table_checker(ht) = hash_equivalent; - hash_table_mapper(ht) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ - return(ht); - } - if (c_function_call(proc) == g_is_eq) - { - hash_table_checker(ht) = hash_eq; - hash_table_mapper(ht) = eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_strings_are_equal) - { - hash_table_checker(ht) = hash_string; - hash_table_mapper(ht) = string_eq_hash_map; - return(ht); - } -#if (!WITH_PURE_S7) - if (c_function_call(proc) == g_strings_are_ci_equal) - { - hash_table_checker(ht) = hash_ci_string; - hash_table_mapper(ht) = string_ci_eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_chars_are_ci_equal) - { - hash_table_checker(ht) = hash_ci_char; - hash_table_mapper(ht) = char_ci_eq_hash_map; - return(ht); - } -#endif - if (c_function_call(proc) == g_chars_are_equal) - { - hash_table_checker(ht) = hash_char; - hash_table_mapper(ht) = char_eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_num_eq) - { - if ((is_typed_hash_table(ht)) && - (hash_table_key_typer(ht) == global_value(sc->is_integer_symbol))) - hash_table_checker(ht) = hash_int; - else hash_table_checker(ht) = hash_number_num_eq; - return(ht); - } - if (c_function_call(proc) == g_is_eqv) - { - hash_table_checker(ht) = hash_eqv; - return(ht); - } - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~A second argument, ~S, is not a built-in function it can handle", 64), caller, proc)); - } - /* proc not c_function */ - else - { - if (is_pair(proc)) - { - s7_pointer checker = car(proc), mapper = cdr(proc); - - hash_set_chosen(ht); - if (!((is_any_c_function(checker)) || - (is_any_closure(checker)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: first entry of type info, ~A, is ~A, but should be a function", 65), - caller, checker, type_name_string(sc, checker))); - if (!((is_any_c_function(mapper)) || - (is_any_closure(mapper)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: second entry of type info, ~A, is ~A, but should be a function", 66), - caller, mapper, type_name_string(sc, mapper))); - - if (!(s7_is_aritable(sc, checker, 2))) - wrong_type_error_nr(sc, caller, 2, checker, wrap_string(sc, "a function of two arguments", 27)); - if (!(s7_is_aritable(sc, mapper, 1))) - wrong_type_error_nr(sc, caller, 2, mapper, wrap_string(sc, "a function of one argument", 26)); - - if (is_any_c_function(checker)) - { - s7_pointer sig = c_function_signature(checker); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_boolean_symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A checker function, ~S, should return a boolean value", 54), caller, checker)); - hash_table_checker(ht) = hash_c_function; - } - else hash_table_checker(ht) = hash_closure; - - if (is_any_c_function(mapper)) - { - s7_pointer sig = c_function_signature(mapper); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_integer_symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A mapper function, ~S, should return an integer", 48), caller, mapper)); - hash_table_mapper(ht) = c_function_hash_map; - } - else hash_table_mapper(ht) = closure_hash_map; - - if (is_null(hash_table_procedures(ht))) - hash_table_set_procedures(ht, make_hash_table_procedures(sc)); - hash_table_set_procedures_checker(ht, car(proc)); /* proc = cadr(args) */ - hash_table_set_procedures_mapper(ht, cdr(proc)); - return(ht); - } - if (proc != sc->F) wrong_type_error_nr(sc, caller, 2, proc, wrap_string(sc, "a cons of two functions", 23)); - return(ht); - }}} - return(s7_make_hash_table(sc, size)); -} - -static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args) -{ - return(g_make_hash_table_1(sc, args, sc->make_hash_table_symbol)); -} - - -/* -------------------------------- make-weak-hash-table -------------------------------- */ -static s7_pointer g_make_weak_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_make_weak_hash_table "(make-weak-hash-table (size 8) eq-func typers) returns a new weak hash table" - #define Q_make_weak_hash_table s7_make_signature(sc, 4, sc->is_weak_hash_table_symbol, sc->is_integer_symbol, \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) - s7_pointer table = g_make_hash_table_1(sc, args, sc->make_weak_hash_table_symbol); - set_weak_hash_table(table); - weak_hash_iters(table) = 0; - return(table); -} - -static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht) -{ - if (hash_table_checker(ht) == hash_equal) return("equal?"); - if (hash_table_checker(ht) == hash_equivalent) return("equivalent?"); - if (hash_table_checker(ht) == hash_eq) return("eq?"); - if (hash_table_checker(ht) == hash_eqv) return("eqv?"); - if (hash_table_checker(ht) == hash_string) return("string=?"); -#if (!WITH_PURE_S7) - if (hash_table_checker(ht) == hash_ci_string) return("string-ci=?"); - if (hash_table_checker(ht) == hash_ci_char) return("char-ci=?"); -#endif - if (hash_table_checker(ht) == hash_char) return("char=?"); - if (hash_table_checker(ht) == hash_number_num_eq) return("="); - return("#f"); -} - - -/* -------------------------------- weak-hash-table? -------------------------------- */ -static s7_pointer g_is_weak_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_is_weak_hash_table "(weak-hash-table? obj) returns #t if obj is a weak hash-table" - #define Q_is_weak_hash_table sc->pl_bt - #define is_weak_hash(p) ((is_hash_table(p)) && (is_weak_hash_table(p))) - check_boolean_method(sc, is_weak_hash, sc->is_weak_hash_table_symbol, args); -} - -static void init_hash_maps(void) -{ - for (int32_t i = 0; i < NUM_TYPES; i++) - { - default_hash_map[i] = hash_map_nil; - string_eq_hash_map[i] = hash_map_nil; - char_eq_hash_map[i] = hash_map_nil; -#if (!WITH_PURE_S7) - string_ci_eq_hash_map[i] = hash_map_nil; - char_ci_eq_hash_map[i] = hash_map_nil; -#endif - closure_hash_map[i] = hash_map_closure; - c_function_hash_map[i] = hash_map_c_function; - eq_hash_map[i] = hash_map_eq; - - equal_hash_checks[i] = hash_equal_any; - default_hash_checks[i] = hash_equal; - } - default_hash_map[T_CHARACTER] = hash_map_char; - default_hash_map[T_SYMBOL] = hash_map_symbol; - default_hash_map[T_SYNTAX] = hash_map_syntax; - default_hash_map[T_STRING] = hash_map_string; - default_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector; - default_hash_map[T_HASH_TABLE] = hash_map_hash_table; - default_hash_map[T_VECTOR] = hash_map_vector; - default_hash_map[T_INT_VECTOR] = hash_map_int_vector; - default_hash_map[T_FLOAT_VECTOR] = hash_map_float_vector; - default_hash_map[T_LET] = hash_map_let; - default_hash_map[T_PAIR] = hash_map_pair; - - default_hash_map[T_INTEGER] = hash_map_int; - default_hash_map[T_RATIO] = hash_map_ratio; - default_hash_map[T_REAL] = hash_map_real; - default_hash_map[T_COMPLEX] = hash_map_complex; -#if WITH_GMP - default_hash_map[T_BIG_INTEGER] = hash_map_big_int; - default_hash_map[T_BIG_RATIO] = hash_map_big_ratio; - default_hash_map[T_BIG_REAL] = hash_map_big_real; - default_hash_map[T_BIG_COMPLEX] = hash_map_big_complex; -#endif - - string_eq_hash_map[T_STRING] = hash_map_string; - string_eq_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector; - char_eq_hash_map[T_CHARACTER] = hash_map_char; -#if (!WITH_PURE_S7) - string_ci_eq_hash_map[T_STRING] = hash_map_ci_string; - char_ci_eq_hash_map[T_CHARACTER] = hash_map_ci_char; -#endif - - for (int32_t i = 0; i < NUM_TYPES; i++) equivalent_hash_map[i] = default_hash_map[i]; - - equal_hash_checks[T_SYNTAX] = hash_equal_syntax; - equal_hash_checks[T_SYMBOL] = hash_equal_eq; - equal_hash_checks[T_CHARACTER] = hash_equal_eq; - equal_hash_checks[T_INTEGER] = hash_equal_integer; - equal_hash_checks[T_RATIO] = hash_equal_ratio; - equal_hash_checks[T_REAL] = hash_equal_real; - equal_hash_checks[T_COMPLEX] = hash_equal_complex; - - default_hash_checks[T_STRING] = hash_string; - default_hash_checks[T_INTEGER] = hash_int; - default_hash_checks[T_REAL] = hash_float; - default_hash_checks[T_SYMBOL] = hash_symbol; - default_hash_checks[T_CHARACTER] = hash_char; -} - -static void resize_hash_table(s7_scheme *sc, s7_pointer table) -{ - s7_int entries = hash_table_entries(table); - hash_entry_t **old_els = hash_table_elements(table); - s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */ - s7_int old_size = hash_table_mask(table) + 1; - s7_int new_size = old_size * 4; - s7_int hash_mask = new_size - 1; - block_t *np = (block_t *)callocate(sc, new_size * sizeof(hash_entry_t *)); - hash_entry_t **new_els = (hash_entry_t **)(block_data(np)); - - for (s7_int i = 0; i < old_size; i++) - { - hash_entry_t *n; - for (hash_entry_t *x = old_els[i]; x; x = n) - { - s7_int loc = hash_entry_raw_hash(x) & hash_mask; - n = hash_entry_next(x); - hash_entry_next(x) = new_els[loc]; - new_els[loc] = x; - }} - liberate(sc, hash_table_block(table)); - hash_table_set_block(table, np); - hash_table_elements(table) = new_els; - hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */ - hash_table_set_procedures(table, dproc); - hash_table_entries(table) = entries; -} - - -/* -------------------------------- hash-table-ref -------------------------------- */ -s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); -} - -static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table" - #define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T) - - s7_pointer table = car(args), nt; - if (!is_hash_table(table)) - return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1)); - nt = s7_hash_table_ref(sc, table, cadr(args)); - - if (is_pair(cddr(args))) - return(ref_index_checked(sc, global_value(sc->hash_table_ref_symbol), nt, args)); - return(nt); -} - -static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer table = car(args); - if (!is_hash_table(table)) - return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1)); - return(hash_entry_value((*hash_table_checker(table))(sc, table, cadr(args)))); -} - -static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (!is_hash_table(table)) - return(method_or_bust(sc, table, sc->hash_table_ref_symbol, set_plist_2(sc, table, key), sc->type_names[T_HASH_TABLE], 1)); - return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); -} - -static bool op_implicit_hash_table_ref_a(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_hash_table(s)) {sc->last_function = s; return(false);} - sc->value = s7_hash_table_ref(sc, s, fx_call(sc, cdr(sc->code))); - return(true); -} - -static bool op_implicit_hash_table_ref_aa(s7_scheme *sc) -{ - s7_pointer in_obj, out_key; - s7_pointer table = lookup_checked(sc, car(sc->code)); - if (!is_hash_table(table)) {sc->last_function = table; return(false);} - out_key = fx_call(sc, cdr(sc->code)); - in_obj = s7_hash_table_ref(sc, table, out_key); - if (is_hash_table(in_obj)) - sc->value = s7_hash_table_ref(sc, in_obj, fx_call(sc, cddr(sc->code))); - else sc->value = implicit_pair_index_checked(sc, table, in_obj, set_plist_2(sc, out_key, fx_call(sc, cddr(sc->code)))); /* -> implicit_index */ - return(true); -} - -static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 2) - { - s7_pointer key = caddr(expr); - if ((is_pair(key)) && (car(key) == sc->substring_symbol) && (is_global(sc->substring_symbol))) - set_c_function(key, sc->substring_uncopied); - return(sc->hash_table_ref_2); - } - return(f); -} - - -/* -------------------------------- hash-table-set! -------------------------------- */ -static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, hash_entry_t *p) -{ - hash_entry_t *x; - s7_int hash_mask, loc; - - if (p == sc->unentry) return(sc->F); - hash_mask = hash_table_mask(table); - loc = hash_entry_raw_hash(p) & hash_mask; - x = hash_table_element(table, loc); - if (x == p) - hash_table_element(table, loc) = hash_entry_next(x); - else - { - hash_entry_t *y; - for (y = x, x = hash_entry_next(x); x; y = x, x = hash_entry_next(x)) - if (x == p) - { - hash_entry_next(y) = hash_entry_next(x); - break; - }} - hash_table_entries(table)--; - if ((hash_table_entries(table) == 0) && - (hash_table_mapper(table) == default_hash_map)) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - liberate_block(sc, x); - return(sc->F); -} - -static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table) -{ - s7_int len = hash_table_mask(table) + 1; - hash_entry_t **entries = hash_table_elements(table); - for (s7_int i = 0; i < len; i++) - { - hash_entry_t *nxp, *lxp = entries[i]; - for (hash_entry_t *xp = entries[i]; xp; xp = nxp) - { - nxp = hash_entry_next(xp); - if (is_free_and_clear(hash_entry_key(xp))) - { - if (xp == entries[i]) - { - entries[i] = nxp; - lxp = nxp; - } - else hash_entry_next(lxp) = nxp; - liberate_block(sc, xp); - hash_table_entries(table)--; - if (hash_table_entries(table) == 0) - { - if (hash_table_mapper(table) == default_hash_map) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - return; - }} - else lxp = xp; - }} -} - -static void hash_table_set_default_checker(s7_pointer table, uint8_t typ) -{ - if (hash_table_checker(table) != default_hash_checks[typ]) - { - if (hash_table_checker(table) == hash_empty) - hash_table_checker(table) = default_hash_checks[typ]; - else - { - hash_table_checker(table) = hash_equal; - hash_set_chosen(table); - }} -} - -static s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer) -{ - if (typer == sc->T) - return(sc->T); - return((is_c_function(typer)) ? c_function_symbol(typer) : find_closure(sc, typer, closure_let(typer))); -} - -static void check_hash_types(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) -{ - if (has_hash_key_type(table)) /* symbol_type and c_function_symbol exist and symbol_type is not T_FREE */ - { - if ((uint8_t)symbol_type(c_function_symbol(hash_table_key_typer(table))) != type(key)) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_key_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, wrap_string(sc, "hash-table-set! key", 19), 2, key, wrap_string(sc, tstr, safe_strlen(tstr))); - }} - else - { - s7_pointer kf = hash_table_key_typer(table); - if (kf != sc->T) - { - s7_pointer type_ok; - if (is_c_function(kf)) - type_ok = c_function_call(kf)(sc, set_plist_1(sc, key)); - else type_ok = s7_apply_function(sc, kf, set_plist_1(sc, key)); - if (type_ok == sc->F) - { - const char *descr = hash_table_typer_name(sc, hash_table_key_typer(table)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! second argument ~$, is ~A, but the hash-table's key type checker, ~A, rejects it", 96), - key, type_name_string(sc, key), wrap_string(sc, descr, safe_strlen(descr)))); - }}} - if (has_hash_value_type(table)) - { - if ((uint8_t)symbol_type(c_function_symbol(hash_table_value_typer(table))) != type(value)) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->hash_table_set_symbol, 3, value, wrap_string(sc, tstr, safe_strlen(tstr))); - }} - else - { - s7_pointer vf = hash_table_value_typer(table); - if (vf != sc->T) - { - s7_pointer type_ok; - if (is_c_function(vf)) - type_ok = c_function_call(vf)(sc, set_plist_1(sc, value)); - else type_ok = s7_apply_function(sc, vf, set_plist_1(sc, value)); - if (type_ok == sc->F) - { - const char *descr = hash_table_typer_name(sc, hash_table_value_typer(table)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! third argument ~$, is ~A, but the hash-table's value type checker, ~A, rejects it", 97), - value, type_name_string(sc, value), wrap_string(sc, descr, safe_strlen(descr)))); - }}} -} - -static void check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* check type -- raise error if incompatible with eq func set by make-hash-table */ - if (hash_table_checker(table) == hash_number_num_eq) - { - if (!is_number(key)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is =", 69), - key, type_name_string(sc, key))); - } - else - if (hash_table_checker(table) == hash_eq) - { - if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?", 71), - key, type_name_string(sc, key))); - } - else -#if WITH_PURE_S7 - if (((hash_table_checker(table) == hash_string) && (!is_string(key))) || - ((hash_table_checker(table) == hash_char) && (!is_character(key)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), - key, type_name_string(sc, key), - (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : sc->char_eq_symbol)); -#else - if ((((hash_table_checker(table) == hash_string) || (hash_table_checker(table) == hash_ci_string)) && - (!is_string(key))) || - (((hash_table_checker(table) == hash_char) || (hash_table_checker(table) == hash_ci_char)) && - (!is_character(key)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), - key, type_name_string(sc, key), - (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : - ((hash_table_checker(table) == hash_ci_string) ? sc->string_ci_eq_symbol : - ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->char_ci_eq_symbol)))); -#endif -} - -s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) -{ - s7_int hash_mask, loc; - hash_entry_t *p, *x; - - if (value == sc->F) - return(remove_from_hash_table(sc, table, (*hash_table_checker(table))(sc, table, key))); - - if ((is_typed_hash_table(table)) && - (sc->safety >= NO_SAFETY)) - check_hash_types(sc, table, key, value); - - x = (*hash_table_checker(table))(sc, table, key); - if (x != sc->unentry) - { - hash_entry_set_value(x, T_Ext(value)); - return(value); - } - /* hash_entry_raw_hash(x) can save the hash_loc from the lookup operations, but at some added complexity in - * all the preceding code. This saves about 5% compute time best case in this function. - */ - if (!hash_chosen(table)) - hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */ - else - if (sc->safety > NO_SAFETY) - check_hash_table_checker(sc, table, key); - - p = mallocate_block(sc); - hash_entry_key(p) = key; - hash_entry_set_value(p, T_Ext(value)); - hash_entry_set_raw_hash(p, hash_loc(sc, table, key)); - hash_mask = hash_table_mask(table); - loc = hash_entry_raw_hash(p) & hash_mask; - hash_entry_next(p) = hash_table_element(table, loc); - hash_table_element(table, loc) = p; - hash_table_entries(table)++; - if (hash_table_entries(table) > hash_mask) - resize_hash_table(sc, table); - return(value); -} - -static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value" - #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T) - - s7_pointer table = car(args); - if (!is_mutable_hash_table(table)) - return(mutable_method_or_bust(sc, table, sc->hash_table_set_symbol, args, sc->type_names[T_HASH_TABLE], 1)); - return(s7_hash_table_set(sc, table, cadr(args), caddr(args))); -} - -static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */ - return(mutable_method_or_bust_ppp(sc, p1, sc->hash_table_set_symbol, p1, p2, p3, sc->type_names[T_HASH_TABLE], 1)); - return(s7_hash_table_set(sc, p1, p2, p3)); -} - -static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if ((args == 3) && (optimize_op(expr) == HOP_SAFE_C_SSA)) - { - s7_pointer val = cadddr(expr); - if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_proper_list_3(sc, val)) && - ((cadr(val) == int_one) || (caddr(val) == int_one))) - { - s7_pointer add1 = (cadr(val) == int_one) ? caddr(val) : cadr(val); - if ((is_pair(add1)) && (car(add1) == sc->or_symbol) && (is_proper_list_3(sc, add1)) && - (caddr(add1) == int_zero)) - { - s7_pointer or1 = cadr(add1); - if ((is_pair(or1)) && (car(or1) == sc->hash_table_ref_symbol) && (is_proper_list_3(sc, or1)) && - (cadr(or1) == cadr(expr)) && (caddr(or1) == caddr(expr))) - /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) */ - set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT); - }}} - return(f); -} - - -/* -------------------------------- hash-table -------------------------------- */ -static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) -{ - s7_int hash, hash_mask, loc; - hash_entry_t *p; - - if (!hash_chosen(table)) - hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */ - - hash_mask = hash_table_mask(table); - hash = hash_loc(sc, table, key); - loc = hash & hash_mask; - - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((hash_entry_raw_hash(x) == hash) && - (s7_is_equal(sc, hash_entry_key(x), key))) - return(value); - - p = mallocate_block(sc); - hash_entry_key(p) = key; - hash_entry_set_value(p, T_Ext(value)); - hash_entry_set_raw_hash(p, hash); - hash_entry_next(p) = hash_table_element(table, loc); - hash_table_element(table, loc) = p; - hash_table_entries(table)++; - if (hash_table_entries(table) > hash_mask) - resize_hash_table(sc, table); - return(value); -} - -static s7_pointer g_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - s7_pointer ht; - s7_int len = proper_list_length(args); - if (len & 1) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~A got an odd number of arguments: ~S", 37), caller, args)); - len /= 2; - ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length); - if (len > 0) - for (s7_pointer x = args, y = cdr(args); is_pair(x); x = cddr(x), y = unchecked_cdr(cdr(y))) - if (car(y) != sc->F) - hash_table_add(sc, ht, car(x), car(y)); - return(ht); -} - -static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table "(hash-table ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \ -That is, (hash-table 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled." - #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T) - return(g_hash_table_1(sc, args, sc->hash_table_symbol)); -} - -static s7_pointer g_hash_table_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer ht = s7_make_hash_table(sc, sc->default_hash_table_length); - if (cadr(args) != sc->F) - hash_table_add(sc, ht, car(args), cadr(args)); - return(ht); -} - - -/* -------------------------------- weak-hash-table -------------------------------- */ -static s7_pointer g_weak_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_weak_hash_table "(weak-hash-table ...) returns a weak-hash-table containing the symbol/value pairs passed as its arguments. \ -That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two key/value pairs preinstalled." - #define Q_weak_hash_table Q_hash_table - - s7_pointer table = g_hash_table_1(sc, args, sc->weak_hash_table_symbol); - set_weak_hash_table(table); - weak_hash_iters(table) = 0; - return(table); -} - -static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->hash_table_2 : f); -} - -static void check_old_hash(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, s7_int start, s7_int end) -{ - s7_int count = 0; - s7_int old_len = hash_table_mask(old_hash) + 1; - hash_entry_t **old_lists = hash_table_elements(old_hash); - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - return; - if (count >= start) - check_hash_types(sc, new_hash, hash_entry_key(x), hash_entry_value(x)); - } -} - -static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, s7_int start, s7_int end) -{ - s7_int old_len, new_mask, count = 0; - hash_entry_t **old_lists, **new_lists; - - if (is_typed_hash_table(new_hash)) - check_old_hash(sc, old_hash, new_hash, start, end); - - old_len = hash_table_mask(old_hash) + 1; - new_mask = hash_table_mask(new_hash); - old_lists = hash_table_elements(old_hash); - new_lists = hash_table_elements(new_hash); - - if (hash_table_entries(new_hash) == 0) - { - if ((start == 0) && - (end >= hash_table_entries(old_hash))) - { - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - } - hash_table_entries(new_hash) = hash_table_entries(old_hash); - return(new_hash); - } - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - { - hash_table_entries(new_hash) = end - start; - return(new_hash); - } - if (count >= start) - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - } - count++; - } - hash_table_entries(new_hash) = count - start; - return(new_hash); - } - - /* this can't be optimized much because we have to look for key matches (we're copying old_hash into the existing, non-empty new_hash) */ - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - return(new_hash); - if (count >= start) - { - hash_entry_t *y = (*hash_table_checker(new_hash))(sc, new_hash, hash_entry_key(x)); - if (y != sc->unentry) - hash_entry_set_value(y, hash_entry_value(x)); - else - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - hash_table_entries(new_hash)++; - if (!hash_chosen(new_hash)) - hash_table_set_default_checker(new_hash, type(hash_entry_key(x))); - }} - count++; - } - return(new_hash); -} - -static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args) -{ - s7_pointer table = car(args), val = cadr(args); - if (is_immutable(table)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, table)); - - if (hash_table_entries(table) > 0) - { - hash_entry_t **entries = hash_table_elements(table); - s7_int len = hash_table_mask(table) + 1; /* minimum len is 2 (see s7_make_hash_table) */ - if (val == sc->F) /* hash-table-ref returns #f if it can't find a key, so val == #f here means empty the table */ - { - hash_entry_t **hp = entries; - hash_entry_t **hn = (hash_entry_t **)(hp + len); - for (; hp < hn; hp++) - { - if (*hp) - { - hash_entry_t *p = *hp; - while (hash_entry_next(p)) p = hash_entry_next(p); - hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = *hp; - } - hp++; - if (*hp) - { - hash_entry_t *p = *hp; - while (hash_entry_next(p)) p = hash_entry_next(p); - hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = *hp; - }} - if (len >= 8) - memclr64(entries, len * sizeof(hash_entry_t *)); - else memclr(entries, len * sizeof(hash_entry_t *)); - if (hash_table_mapper(table) == default_hash_map) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - hash_table_entries(table) = 0; - return(val); - } - if ((is_typed_hash_table(table)) && - (((is_c_function(hash_table_value_typer(table))) && - (c_function_call(hash_table_value_typer(table))(sc, set_plist_1(sc, val)) == sc->F)) || - ((is_any_closure(hash_table_value_typer(table))) && - (s7_apply_function(sc, hash_table_value_typer(table), set_plist_1(sc, val)) == sc->F)))) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->fill_symbol, 2, val, wrap_string(sc, tstr, safe_strlen(tstr))); - } - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *x = entries[i]; x; x = hash_entry_next(x)) - hash_entry_set_value(x, val); - /* keys haven't changed, so no need to mess with hash_table_checker */ - } - return(val); -} - -static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash) -{ - s7_int len = hash_table_mask(old_hash) + 1; - hash_entry_t **old_lists = hash_table_elements(old_hash); - s7_pointer new_hash = s7_make_hash_table(sc, len); - s7_int gc_loc = gc_protect_1(sc, new_hash); - - /* old_hash checker/mapper functions don't always make sense reversed, although the key/value typers might be ok */ - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - s7_hash_table_set(sc, new_hash, hash_entry_value(x), hash_entry_key(x)); - s7_gc_unprotect_at(sc, gc_loc); - return(new_hash); -} - - -/* -------------------------------- functions -------------------------------- */ -bool s7_is_function(s7_pointer p) {return(is_c_function(p));} - -static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) {return(f);} - -static void s7_function_set_class(s7_scheme *sc, s7_pointer f, s7_pointer base_f) -{ - c_function_class(f) = c_function_class(base_f); - c_function_set_base(f, base_f); -} - -static s7_pointer make_function(s7_scheme *sc, const char *name, s7_function f, s7_int req, s7_int opt, bool rst, const char *doc, s7_pointer x, c_proc_t *ptr) -{ - uint32_t ftype = T_C_FUNCTION; - - if ((req == 0) && (rst)) - ftype = T_C_RST_NO_REQ_FUNCTION; - set_full_type(x, ftype); - - c_function_data(x) = ptr; - c_function_call(x) = f; /* f is T_App but needs cast */ - c_function_set_base(x, x); - c_function_set_setter(x, sc->F); - c_function_name(x) = name; /* (procedure-name proc) => (format #f "~A" proc) */ - c_function_name_length(x) = safe_strlen(name); - c_function_documentation(x) = (doc) ? make_semipermanent_c_string(sc, doc) : NULL; - c_function_signature(x) = sc->F; - - c_function_min_args(x) = req; - c_function_optional_args(x) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */ - c_function_max_args(x) = (rst) ? MAX_ARITY : req + opt; - - c_function_class(x) = ++sc->f_class; - c_function_chooser(x) = fallback_chooser; - c_function_opt_data(x) = NULL; - c_function_marker(x) = NULL; - c_function_symbol(x) = NULL; - return(x); -} - -static c_proc_t *alloc_semipermanent_function(s7_scheme *sc) -{ - #define ALLOC_FUNCTION_SIZE 256 - if (sc->alloc_function_k == ALLOC_FUNCTION_SIZE) - { - sc->alloc_function_cells = (c_proc_t *)Malloc(ALLOC_FUNCTION_SIZE * sizeof(c_proc_t)); - add_saved_pointer(sc, sc->alloc_function_cells); - sc->alloc_function_k = 0; - } - return(&(sc->alloc_function_cells[sc->alloc_function_k++])); -} - -s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer x = alloc_pointer(sc); - x = make_function(sc, name, f, required_args, optional_args, rest_arg, doc, x, alloc_semipermanent_function(sc)); - unheap(sc, x); - return(x); -} - -s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer p = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); - set_type_bit(p, T_SAFE_PROCEDURE); - return(p); -} - -s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature) -{ - s7_pointer func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); - set_type_bit(func, T_SAFE_PROCEDURE); - if (signature) c_function_signature(func) = signature; - return(func); -} - - -/* -------------------------------- procedure? -------------------------------- */ -bool s7_is_procedure(s7_pointer x) {return(is_procedure(x));} - -static s7_pointer g_is_procedure(s7_scheme *sc, s7_pointer args) -{ - #define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" - #define Q_is_procedure sc->pl_bt - return(make_boolean(sc, is_procedure(car(args)))); -} - - -static void s7_function_set_setter(s7_scheme *sc, s7_pointer getter, s7_pointer setter) -{ - /* this is internal, used only with c_function setters, so we don't need to worry about the GC mark choice */ - c_function_set_setter(global_value(getter), global_value(setter)); -} - -s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_body(p) : sc->nil);} -s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->nil);} -s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_args(p) : sc->nil);} - - -/* -------------------------------- procedure-source -------------------------------- */ -static s7_pointer procedure_type_to_symbol(s7_scheme *sc, int32_t type) -{ - switch (type) - { - case T_CLOSURE: return(sc->lambda_symbol); - case T_CLOSURE_STAR: return(sc->lambda_star_symbol); - case T_MACRO: return(sc->macro_symbol); - case T_MACRO_STAR: return(sc->macro_star_symbol); - case T_BACRO: return(sc->bacro_symbol); - case T_BACRO_STAR: return(sc->bacro_star_symbol); - default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); - } - return(sc->lambda_symbol); -} - -static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) -{ - #define H_procedure_source "(procedure-source func) tries to return the definition of func" - #define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - /* make it look like a scheme-level lambda */ - s7_pointer p = car(args); - - if (is_symbol(p)) - { - if ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), car(args))); - } - if ((is_c_function(p)) || (is_c_macro(p))) - return(sc->nil); - - check_method(sc, p, sc->procedure_source_symbol, set_plist_1(sc, p)); - if (has_closure_let(p)) - { - s7_pointer body = closure_body(p); - /* perhaps if this function has been removed from the heap, it would be better to use copy_body (as in s7_copy)? */ - if (is_safe_closure_body(body)) - clear_safe_closure_body(body); - return(append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(p)), closure_args(p)), body)); - } - if (!is_procedure(p)) - sole_arg_wrong_type_error_nr(sc, sc->procedure_source_symbol, p, a_procedure_or_a_macro_string); - return(sc->nil); -} - - -/* -------------------------------- *current-function* -------------------------------- */ -static s7_pointer let_to_function(s7_scheme *sc, s7_pointer e) -{ - if ((e == sc->rootlet) || (!is_let(e))) - return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) - return(sc->F); - if ((has_let_file(e)) && - (let_file(e) <= (s7_int)sc->file_names_top) && - (let_line(e) > 0)) - return(list_3(sc, funclet_function(e), sc->file_names[let_file(e)], make_integer(sc, let_line(e)))); - return(funclet_function(e)); -} - -static s7_pointer g_function(s7_scheme *sc, s7_pointer args) -{ - #define H_function "(*function* e) returns the current function in e" - #define Q_function s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) - - s7_pointer e, sym = NULL, fname, fval; - if (is_null(args)) /* (*function*) is akin to __func__ in C */ - { - for (e = sc->curlet; is_let(e); e = let_outlet(e)) - if ((is_funclet(e)) || (is_maclet(e))) - break; - return(let_to_function(sc, e)); - } - e = car(args); - if (!is_let(e)) - sole_arg_wrong_type_error_nr(sc, sc->_function__symbol, e, sc->type_names[T_LET]); - if (is_pair(cdr(args))) - { - sym = cadr(args); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->_function__symbol, 2, sym, sc->type_names[T_SYMBOL]); - } - - if (e == sc->rootlet) - return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) - e = let_outlet(e); - if (is_null(cdr(args))) - return(let_to_function(sc, e)); - - if ((e == sc->rootlet) || (!is_let(e))) - return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) - return(sc->F); - - if (is_keyword(sym)) - sym = keyword_symbol(sym); - fname = funclet_function(e); - fval = s7_symbol_local_value(sc, fname, e); - - if (sym == sc->name_symbol) return(fname); - if (sym == sc->signature_symbol) return(s7_signature(sc, fval)); - if (sym == sc->arity_symbol) return(s7_arity(sc, fval)); - if (sym == sc->documentation_symbol) return(s7_make_string(sc, s7_documentation(sc, fval))); - if (sym == sc->value_symbol) return(fval); - if ((sym == sc->line_symbol) && (has_let_file(e))) return(make_integer(sc, let_line(e))); - if ((sym == sc->file_symbol) && (has_let_file(e))) return(sc->file_names[let_file(e)]); - if (sym == make_symbol(sc, "funclet", 7)) return(e); - if (sym == make_symbol(sc, "source", 6)) return(g_procedure_source(sc, set_plist_1(sc, fval))); - if ((sym == make_symbol(sc, "arglist", 7)) && ((is_any_closure(fval)) || (is_any_macro(fval)))) return(closure_args(fval)); - return(sc->F); -} - - -/* -------------------------------- funclet -------------------------------- */ -s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->rootlet);} - -static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) -{ - #define H_funclet "(funclet func) tries to return a function's definition environment" - #define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol)) - s7_pointer p = car(args), e; - if (is_symbol(p)) - { - if ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not p here */ - } - check_method(sc, p, sc->funclet_symbol, args); - - if (!((is_any_procedure(p)) || (is_c_object(p)))) - sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, p, a_procedure_or_a_macro_string); - e = find_let(sc, p); - if ((is_null(e)) && - (!is_c_object(p))) /* rootlet is not the c_object let */ - return(sc->rootlet); - return(e); -} - - -/* -------------------------------- s7_define_function and friends -------------------------------- - * - * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...) - * but there's no way to tell in general that the let is not exported. - */ -s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - /* returns (string->symbol name), not the c_proc_t func */ - s7_pointer func = s7_make_safe_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) -{ - /* returns (string->symbol name), not the c_proc_t func */ - s7_pointer func = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - c_function_set_marker(func, NULL); - return(sym); -} - -static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int optional_args, const char *doc, s7_pointer signature, int32_t sym_to_type, - void (*marker)(s7_pointer p, s7_int top), - bool simple, s7_function bool_setter) -{ - s7_pointer bfunc; - s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - if (sym_to_type != T_FREE) - symbol_set_type(sym, sym_to_type); - c_function_symbol(func) = sym; - c_function_set_marker(func, marker); - if (simple) c_function_set_has_simple_elements(func); - c_function_set_bool_setter(func, bfunc = s7_make_safe_function(sc, name, bool_setter, 2, 0, false, NULL)); - c_function_set_has_bool_setter(func); - c_function_set_setter(bfunc, func); - set_is_bool_function(bfunc); - return(sym); -} - -s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) -{ - /* returns (string->symbol name), not the c_proc_t func */ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - if (signature) c_function_signature(func) = signature; - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) -{ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - if (signature) c_function_signature(func) = signature; - set_is_semisafe(func); - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - s7_pointer func, local_args; - char *internal_arglist; - s7_int n_args, len = safe_strlen(arglist); - s7_int gc_loc; - block_t *b = inline_mallocate(sc, len + 4); - - internal_arglist = (char *)block_data(b); - internal_arglist[0] = '\''; - internal_arglist[1] = '('; - memcpy((void *)(internal_arglist + 2), (void *)arglist, len); - internal_arglist[len + 2] = ')'; - internal_arglist[len + 3] = '\0'; - local_args = s7_eval_c_string(sc, internal_arglist); - gc_loc = gc_protect_1(sc, local_args); - liberate(sc, b); - n_args = s7_list_length(sc, local_args); - if (n_args < 0) - { - s7_warn(sc, 256, "%s rest argument is not supported in C-side define*: %s\n", name, arglist); - n_args = -n_args; - } - func = s7_make_function(sc, name, fnc, 0, n_args, false, doc); - - if (n_args > 0) - { - s7_pointer p = local_args; - s7_pointer *names = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer)); - s7_pointer *defaults = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer)); - - set_full_type(func, T_C_FUNCTION_STAR | T_UNHEAP); /* unheap from s7_make_function */ - c_function_call_args(func) = NULL; - c_function_arg_names(func) = names; - c_function_arg_defaults(func) = defaults; - c_func_set_simple_defaults(func); - /* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the only parameter: (:allow-other-keys) */ - - for (s7_int i = 0; i < n_args; p = cdr(p), i++) - { - s7_pointer arg = car(p); - if (arg == sc->allow_other_keys_keyword) - { - if (is_not_null(cdr(p))) - s7_warn(sc, 256, "%s :allow-other-keys should be the last parameter: %s\n", name, arglist); - if (p == local_args) - s7_warn(sc, 256, "%s :allow-other-keys can't be the only parameter: %s\n", name, arglist); - c_function_set_allow_other_keys(func); /* local_args is local, so it can't carry the bit */ - n_args--; - c_function_optional_args(func) = n_args; - c_function_max_args(func) = n_args; /* apparently not counting keywords */ - } - else - if (is_pair(arg)) /* there is a default */ - { - names[i] = symbol_to_keyword(sc, car(arg)); - defaults[i] = cadr(arg); - remove_from_heap(sc, cadr(arg)); - if ((is_pair(defaults[i])) || - (is_normal_symbol(defaults[i]))) - { - c_func_clear_simple_defaults(func); - mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star; - }} - else - { - if (arg == sc->rest_keyword) - s7_warn(sc, 256, "%s :rest is not supported in C-side define*: %s\n", name, arglist); - names[i] = symbol_to_keyword(sc, arg); - defaults[i] = sc->F; - }}} - else set_full_type(func, T_C_FUNCTION | T_UNHEAP); - - s7_gc_unprotect_at(sc, gc_loc); - return(func); -} - -s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - s7_pointer func = s7_make_function_star(sc, name, fnc, arglist, doc); - set_full_type(func, full_type(func) | T_SAFE_PROCEDURE); /* don't step on the c_func_has_simple_defaults flag */ - if (is_c_function_star(func)) /* thunk -> c_function */ - c_function_call_args(func) = semipermanent_list(sc, c_function_optional_args(func)); - return(func); -} - -static void define_function_star_1(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, bool safe, s7_pointer signature) -{ - s7_pointer func; - if (safe) - func = s7_make_safe_function_star(sc, name, fnc, arglist, doc); - else func = s7_make_function_star(sc, name, fnc, arglist, doc); - s7_define(sc, sc->nil, make_symbol_with_strlen(sc, name), func); - if (signature) c_function_signature(func) = signature; -} - -void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - define_function_star_1(sc, name, fnc, arglist, doc, false, NULL); -} - -void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - define_function_star_1(sc, name, fnc, arglist, doc, true, NULL); -} - -void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, s7_pointer signature) -{ - define_function_star_1(sc, name, fnc, arglist, doc, true, signature); -} - - -s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ - s7_define(sc, sc->nil, sym, func); - return(sym); -} - - -/* -------------------------------- macro? -------------------------------- */ -bool s7_is_macro(s7_scheme *sc, s7_pointer x) {return(is_any_macro(x));} -static bool is_macro_b(s7_pointer x) {return(is_any_macro(x));} - -static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args) -{ - #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" - #define Q_is_macro sc->pl_bt - check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args); -} - -static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args); - -static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args) -{ - int32_t arg_len; - if (!s7_is_proper_list(sc, args)) - return(sc->F); - - arg_len = proper_list_length(args); - if (!closure_is_aritable(sc, mac, closure_args(mac), arg_len)) - return(sc->F); - - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = mac; - sc->args = args; - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - return(sc->value); -} - - -/* -------------------------------- documentation -------------------------------- */ -const char *s7_documentation(s7_scheme *sc, s7_pointer x) -{ - s7_pointer val; - if (is_symbol(x)) - { - if (is_keyword(x)) return(NULL); - if (symbol_has_help(x)) - return(symbol_help(x)); - x = s7_symbol_value(sc, x); /* this is needed by Snd */ - } - if ((is_any_c_function(x)) || - (is_c_macro(x))) - return((char *)c_function_documentation(x)); - - if (is_syntax(x)) - return(syntax_documentation(x)); - - val = funclet_entry(sc, x, sc->local_documentation_symbol); - if ((val) && (is_string(val))) - return(string_value(val)); - - if (has_closure_let(x)) - { - val = closure_body(x); - if ((is_pair(val)) && (is_string(car(val)))) - return((char *)string_value(car(val))); - } - return(NULL); -} - -static s7_pointer g_documentation(s7_scheme *sc, s7_pointer args) -{ - #define H_documentation "(documentation obj) returns obj's documentation string" - #define Q_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->T) /* should (documentation 1) be an error? */ - - s7_pointer p = car(args); - if (is_symbol(p)) - { - if ((symbol_has_help(p)) && - (is_global(p))) - return(s7_make_string(sc, symbol_help(p))); - p = s7_symbol_value(sc, p); - } - /* (documentation func) should act like (documentation abs) -- available without (openlet (funclet func)) or (openlet func) - * so we check that case ahead of time here, rather than going through check_method which does not - * call find_let unless has_active_methods(sc, func). Adding T_HAS_METHODS to all closures causes other troubles. - */ - if (has_closure_let(p)) - { - s7_pointer func = funclet_entry(sc, p, sc->documentation_symbol); - if (func) - return(s7_apply_function(sc, func, args)); - func = closure_body(p); - if ((is_pair(func)) && (is_string(car(func)))) - return(car(func)); - } - /* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */ - check_method(sc, p, sc->documentation_symbol, args); - return(s7_make_string(sc, s7_documentation(sc, p))); -} - -const char *s7_set_documentation(s7_scheme *sc, s7_pointer sym, const char *new_doc) -{ - if (is_keyword(sym)) return(NULL); - if (is_symbol(sym)) - { - symbol_set_has_help(sym); - symbol_set_help(sym, copy_string(new_doc)); - add_saved_pointer(sc, symbol_help(sym)); - } - return(new_doc); -} - - -/* -------------------------------- help -------------------------------- */ -const char *s7_help(s7_scheme *sc, s7_pointer obj) -{ - if (is_syntax(obj)) - return(syntax_documentation(obj)); - - if (is_symbol(obj)) - { - /* here look for name */ - if (s7_documentation(sc, obj)) - return(s7_documentation(sc, obj)); - obj = s7_symbol_value(sc, obj); - } - if (is_any_procedure(obj)) - return(s7_documentation(sc, obj)); - - if (obj == sc->s7_starlet) - return("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)"); - - /* if is string, apropos? (can scan symbol table) */ - return(NULL); -} - -static s7_pointer g_help(s7_scheme *sc, s7_pointer args) -{ - #define H_help "(help obj) returns obj's documentation" - #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T) - const char *doc; - check_method(sc, car(args), sc->help_symbol, args); - doc = s7_help(sc, car(args)); - return((doc) ? s7_make_string(sc, doc) : sc->F); -} - - -/* -------------------------------- signature -------------------------------- */ -static void init_signatures(s7_scheme *sc) -{ - sc->string_signature = s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol); - sc->byte_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol); - sc->vector_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol); - sc->float_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol); - sc->int_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol); - sc->c_object_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); - sc->let_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol); - sc->hash_table_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T); - sc->pair_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol); -} - -static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) -{ - #define H_signature "(signature obj) returns obj's signature" - #define Q_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T) - - s7_pointer p = car(args); - switch (type(p)) - { - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION_STAR: case T_C_MACRO: - return((s7_pointer)c_function_signature(p)); - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - { - s7_pointer func = funclet_entry(sc, p, sc->local_signature_symbol); - if (func) return(func); - func = funclet_entry(sc, p, sc->signature_symbol); - return((func) ? s7_apply_function(sc, func, args) : sc->F); - } - - case T_VECTOR: - if (vector_length(p) == 0) return(sc->F); /* sig () is #f so sig #() should be #f */ - if (!is_typed_vector(p)) - return(sc->vector_signature); - { - s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, p), sc->is_vector_symbol, sc->is_integer_symbol); - set_cdddr(lst, cddr(lst)); - return(lst); - } - - case T_FLOAT_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->float_vector_signature); - case T_INT_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->int_vector_signature); - case T_BYTE_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->byte_vector_signature); - case T_PAIR: return(sc->pair_signature); - case T_STRING: return(sc->string_signature); - - case T_HASH_TABLE: - if (is_typed_hash_table(p)) - return(list_3(sc, - hash_table_typer_symbol(sc, hash_table_value_typer(p)), - sc->is_hash_table_symbol, - hash_table_typer_symbol(sc, hash_table_key_typer(p)))); - return(sc->hash_table_signature); - - case T_ITERATOR: - p = iterator_sequence(p); - if ((is_hash_table(p)) || (is_let(p))) /* cons returned -- would be nice to include the car/cdr types if known */ - return(list_1(sc, sc->is_pair_symbol)); - p = g_signature(sc, set_plist_1(sc, p)); - return(list_1(sc, (is_pair(p)) ? car(p) : sc->T)); - - case T_C_OBJECT: - check_method(sc, p, sc->signature_symbol, args); - return(sc->c_object_signature); - - case T_LET: - check_method(sc, p, sc->signature_symbol, args); - return(sc->let_signature); - - case T_SYMBOL: - /* this used to get the symbol's value and call g_signature on that */ - { - s7_pointer slot = lookup_slot_from(p, sc->curlet); - if ((is_slot(slot)) && (slot_has_setter(slot))) - { - s7_pointer setter = slot_setter(slot); - p = g_signature(sc, set_plist_1(sc, setter)); - if (is_pair(p)) - return(list_1(sc, car(p))); - }} - break; - - default: - break; - } - return(sc->F); -} - -s7_pointer s7_signature(s7_scheme *sc, s7_pointer func) {return(g_signature(sc, set_plist_1(sc, func)));} - - -/* -------------------------------- dynamic-wind -------------------------------- */ -static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer p) -{ - s7_pointer body; - if (!is_closure(p)) return(p); - body = closure_body(p); - if (is_pair(cdr(body))) return(p); - if (!is_pair(car(body))) return(sc->F); - return((caar(body) == sc->quote_symbol) ? sc->F : p); -} - -static s7_pointer make_baffled_closure(s7_scheme *sc, s7_pointer inp) -{ - /* for dynamic-wind to protect initial and final functions from call/cc */ - s7_pointer nclo = make_closure_unchecked(sc, sc->nil, closure_body(inp), type(inp), 0); /* always preceded by new dw cell */ - s7_pointer let = make_let(sc, closure_let(inp)); /* let_outlet(let) = closure_let(inp) */ - set_baffle_let(let); - set_let_baffle_key(let, sc->baffle_ctr++); - closure_set_let(nclo, let); - return(nclo); -} - -static bool is_dwind_thunk(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_MACRO: case T_BACRO: case T_CLOSURE: case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - return(is_null(closure_args(x))); /* this case does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */ - case T_C_FUNCTION: - return(c_function_is_aritable(x, 0)); - case T_C_FUNCTION_STAR: - return(c_function_max_args(x) >= 0); - case T_C_MACRO: - return((c_macro_min_args(x) <= 0) && (c_macro_max_args(x) >= 0)); - case T_GOTO: case T_CONTINUATION: case T_C_RST_NO_REQ_FUNCTION: - return(true); - } - return(x == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */ -} - -static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p, inp, outp; - - new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ - dynamic_wind_in(p) = closure_or_f(sc, car(args)); - dynamic_wind_body(p) = cadr(args); - dynamic_wind_out(p) = closure_or_f(sc, caddr(args)); - - inp = dynamic_wind_in(p); - if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */ - dynamic_wind_in(p) = make_baffled_closure(sc, inp); - - outp = dynamic_wind_out(p); - if ((is_any_closure(outp)) && (!is_safe_closure(outp))) - dynamic_wind_out(p) = make_baffled_closure(sc, outp); - - /* since we don't care about the in and out results, and they are thunks, if the body is not a pair, - * or is a quoted thing, we just ignore that function. - */ - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */ - if (inp != sc->F) - { - dynamic_wind_state(p) = DWIND_INIT; - push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p)); - } - else - { - dynamic_wind_state(p) = DWIND_BODY; - push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(p)); - } - return(sc->F); -} - -static s7_pointer g_dynamic_wind_init(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p, inp = closure_or_f(sc, car(args)); - new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ - dynamic_wind_in(p) = inp; - dynamic_wind_body(p) = cadr(args); - dynamic_wind_out(p) = sc->F; - if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */ - dynamic_wind_in(p) = make_baffled_closure(sc, inp); - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */ - dynamic_wind_state(p) = DWIND_INIT; - push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p)); - return(sc->F); -} - -static s7_pointer g_dynamic_wind_body(s7_scheme *sc, s7_pointer args) -{ - push_stack(sc, OP_APPLY, sc->nil, cadr(args)); - return(sc->F); -} - -static s7_pointer g_dynamic_wind(s7_scheme *sc, s7_pointer args) -{ - #define H_dynamic_wind "(dynamic-wind init body finish) calls init, then body, then finish, \ -each a function of no arguments, guaranteeing that finish is called even if body is exited" - #define Q_dynamic_wind s7_make_signature(sc, 4, sc->values_symbol, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol), \ - sc->is_procedure_symbol, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol)) - - if (!is_dwind_thunk(sc, car(args))) - return(method_or_bust(sc, car(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 1)); - if (!is_thunk(sc, cadr(args))) - return(method_or_bust(sc, cadr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 2)); - if (!is_dwind_thunk(sc, caddr(args))) - return(method_or_bust(sc, caddr(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 3)); - - /* this won't work: - (let ((final (lambda (a b c) (list a b c)))) - (dynamic-wind - (lambda () #f) - (lambda () (set! final (lambda () (display "in final")))) - final)) - * but why not? 'final' is a thunk by the time it is evaluated. catch (the error handler) is similar. - * It can't work here because we set up the dynamic_wind_out slot below and - * even if the thunk check was removed, we'd still be trying to apply the original function. - */ - return(g_dynamic_wind_unchecked(sc, args)); -} - -static bool is_lambda(s7_scheme *sc, s7_pointer sym) -{ - return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); /* do we need (!sc->in_with_let) ? */ - /* symbol_id=0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */ -} - -static int32_t is_ok_thunk(s7_scheme *sc, s7_pointer arg) /* used only in dynamic_wind_chooser */ -{ - /* 0 = not ok, 1 = ok but not simple, 2 = ok body is just #f, 3 = #f */ - if (arg == sc->F) return(3); - if ((is_pair(arg)) && - (is_lambda(sc, car(arg))) && - (is_pair(cdr(arg))) && - (is_null(cadr(arg))) && /* (lambda () ...) */ - (is_pair(cddr(arg))) && - (s7_is_proper_list(sc, cddr(arg)))) - return(((is_null(cdddr(arg))) && (caddr(arg) == sc->F)) ? 2 : 1); /* 2: (lambda () #f) */ - return(0); -} - -static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if ((args == 3) && - (is_ok_thunk(sc, caddr(expr)))) - { - int32_t init = is_ok_thunk(sc, cadr(expr)); - int32_t end = is_ok_thunk(sc, cadddr(expr)); - if ((init > 1) && (end > 1)) return(sc->dynamic_wind_body); - if ((init > 0) && (end > 1)) return(sc->dynamic_wind_init); - if ((init > 0) && (end > 0)) return(sc->dynamic_wind_unchecked); - } - return(f); -} - -s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish) -{ - /* this is essentially s7_call with a dynamic-wind wrapper around "body" */ - declare_jump_info(); - store_jump_info(sc); - set_jump_info(sc, DYNAMIC_WIND_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } - else - { - s7_pointer p; - push_stack_direct(sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */ - sc->args = sc->nil; - new_cell(sc, p, T_DYNAMIC_WIND); - dynamic_wind_in(p) = T_Ext(init); - dynamic_wind_body(p) = T_Ext(body); - dynamic_wind_out(p) = T_Ext(finish); - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); - if (init != sc->F) - { - dynamic_wind_state(p) = DWIND_INIT; - sc->code = init; - } - else - { - dynamic_wind_state(p) = DWIND_BODY; - sc->code = body; - } - eval(sc, OP_APPLY); - } - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -static void op_unwind_output(s7_scheme *sc) -{ - bool is_file = is_file_port(sc->code); - - if ((is_output_port(sc->code)) && - (!port_is_closed(sc->code))) - s7_close_output_port(sc, sc->code); /* may call fflush */ - if (((is_output_port(sc->args)) && - (!port_is_closed(sc->args))) || - (sc->args == sc->F)) - set_current_output_port(sc, sc->args); - if ((is_file) && - (is_multiple_value(sc->value))) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static void op_unwind_input(s7_scheme *sc) -{ - /* sc->code is an input port */ - if (!port_is_closed(sc->code)) - s7_close_input_port(sc, sc->code); - if ((is_input_port(sc->args)) && - (!port_is_closed(sc->args))) - set_current_input_port(sc, sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static bool op_dynamic_wind(s7_scheme *sc) -{ - if (dynamic_wind_state(sc->code) == DWIND_INIT) - { - dynamic_wind_state(sc->code) = DWIND_BODY; - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, sc->code); - sc->code = dynamic_wind_body(sc->code); - sc->args = sc->nil; - return(true); /* goto apply */ - } - if (dynamic_wind_state(sc->code) == DWIND_BODY) - { - dynamic_wind_state(sc->code) = DWIND_FINISH; - if (dynamic_wind_out(sc->code) != sc->F) - { - push_stack(sc, OP_DYNAMIC_WIND, sc->value, sc->code); - sc->code = dynamic_wind_out(sc->code); - sc->args = sc->nil; - return(true); - } - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(false); /* goto start */ - } - if (is_multiple_value(sc->args)) /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */ - sc->value = splice_in_values(sc, multiple_value(sc->args)); - else sc->value = sc->args; /* value saved above */ - return(false); -} - - -/* -------------------------------- c-object? -------------------------------- */ -bool s7_is_c_object(s7_pointer p) {return(is_c_object(p));} - -static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args) -{ - #define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." - #define Q_is_c_object sc->pl_bt - s7_pointer obj = car(args); - if (is_c_object(obj)) return(sc->T); - if (!has_active_methods(sc, obj)) return(sc->F); - return(apply_boolean_method(sc, obj, sc->is_c_object_symbol)); -} - - -/* -------------------------------- c-object-type -------------------------------- */ -static noreturn void apply_error_nr(s7_scheme *sc, s7_pointer obj, s7_pointer args) -{ - /* the operator type is needed here else the error message is confusing: - * (apply '+ (list 1 2))) -> ;attempt to apply + to (1 2)? - * but using current_code(sc) to get the context is not optimal: - * (1 (bignum 4))) -> ;attempt to apply an integer 1 to (4) in (bignum 4)? - */ - if (is_null(obj)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "attempt to apply nil to ~S in ~S?", 33), - args, current_code(sc))); - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "attempt to apply ~A ~S to ~S in ~S?", 35), - type_name_string(sc, obj), obj, args, current_code(sc))); -} - -static void fallback_free(void *value) {} -static void fallback_mark(void *value) {} - -static s7_pointer fallback_ref(s7_scheme *sc, s7_pointer args) {apply_error_nr(sc, car(args), cdr(args)); return(NULL);} -static s7_pointer fallback_set(s7_scheme *sc, s7_pointer args) {syntax_error_nr(sc, "attempt to set ~S?", 18, car(args)); return(NULL);} -static s7_pointer fallback_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);} - -s7_int s7_c_object_type(s7_pointer obj) {return((is_c_object(obj)) ? c_object_type(obj) : -1);} - -static s7_pointer g_c_object_type(s7_scheme *sc, s7_pointer args) -{ - #define H_c_object_type "(c-object-type obj) returns the c_object's type tag." - #define Q_c_object_type s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_c_object_symbol) - - s7_pointer p = car(args); - if (is_c_object(p)) - return(make_integer(sc, c_object_type(p))); /* this is the c_object_types table index = tag */ - - /* method or bust with only one arg -- sole_arg_method_or_bust? */ - if (!has_active_methods(sc, p)) - sole_arg_wrong_type_error_nr(sc, sc->c_object_type_symbol, p, sc->type_names[T_C_OBJECT]); - return(find_and_apply_method(sc, p, sc->c_object_type_symbol, args)); -} - -static s7_pointer g_c_object_set(s7_scheme *sc, s7_pointer args) /* called in c_object_set_function */ -{ - s7_pointer obj = car(args); - if (!is_c_object(obj)) /* (call/cc (setter (block))) will call c-object-set! with the continuation as the argument! */ - wrong_type_error_nr(sc, make_symbol(sc, "c-object-set!", 13), 1, obj, sc->type_names[T_C_OBJECT]); - return((*(c_object_set(sc, obj)))(sc, args)); -} - -s7_int s7_make_c_type(s7_scheme *sc, const char *name) -{ - c_object_t *c_type; - s7_int tag = sc->num_c_object_types++; - - if (tag >= sc->c_object_types_size) - { - if (sc->c_object_types_size == 0) - { - sc->c_object_types_size = 8; - sc->c_object_types = (c_object_t **)Calloc(sc->c_object_types_size, sizeof(c_object_t *)); - } - else - { - sc->c_object_types_size = tag * 2; - sc->c_object_types = (c_object_t **)Realloc((void *)(sc->c_object_types), sc->c_object_types_size * sizeof(c_object_t *)); - }} - c_type = (c_object_t *)Calloc(1, sizeof(c_object_t)); /* Malloc+field=NULL is slightly faster here */ - sc->c_object_types[tag] = c_type; - c_type->type = tag; - c_type->scheme_name = make_permanent_string(name); - c_type->getter = sc->F; - c_type->setter = sc->F; - c_type->free = fallback_free; - c_type->mark = fallback_mark; - c_type->ref = fallback_ref; - c_type->set = fallback_set; - c_type->outer_type = T_C_OBJECT; - c_type->length = fallback_length; - /* all other fields are NULL */ - return(tag); -} - -void s7_c_type_set_gc_free(s7_scheme *sc, s7_int tag, s7_pointer (*gc_free)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_free = gc_free;} -void s7_c_type_set_gc_mark(s7_scheme *sc, s7_int tag, s7_pointer (*gc_mark)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_mark = gc_mark;} -void s7_c_type_set_equal(s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2)) {sc->c_object_types[tag]->eql = equal;} -void s7_c_type_set_is_equal(s7_scheme *sc, s7_int tag, s7_pointer (*is_equal)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->equal = is_equal;} -void s7_c_type_set_copy(s7_scheme *sc, s7_int tag, s7_pointer (*copy)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->copy = copy;} -void s7_c_type_set_fill(s7_scheme *sc, s7_int tag, s7_pointer (*fill)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->fill = fill;} -void s7_c_type_set_reverse(s7_scheme *sc, s7_int tag, s7_pointer (*reverse)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->reverse = reverse;} -void s7_c_type_set_to_list(s7_scheme *sc, s7_int tag, s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_list = to_list;} -void s7_c_type_set_to_string(s7_scheme *sc, s7_int tag, s7_pointer (*to_string)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_string = to_string;} - -void s7_c_type_set_length(s7_scheme *sc, s7_int tag, s7_pointer (*length)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->length = (length) ? length : fallback_length; /* is_sequence(c_obj) is #t so we need a length method */ -} - -void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->equivalent = is_equivalent; -} - -void s7_c_type_set_free(s7_scheme *sc, s7_int tag, void (*gc_free)(void *value)) -{ - sc->c_object_types[tag]->free = (gc_free) ? gc_free : fallback_free; -} - -void s7_c_type_set_mark(s7_scheme *sc, s7_int tag, void (*mark)(void *value)) -{ - sc->c_object_types[tag]->mark = (mark) ? mark : fallback_mark; -} - -void s7_c_type_set_ref(s7_scheme *sc, s7_int tag, s7_pointer (*ref)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->ref = (ref) ? ref : fallback_ref; - sc->c_object_types[tag]->outer_type = (sc->c_object_types[tag]->ref == fallback_ref) ? T_C_OBJECT : (T_C_OBJECT | T_SAFE_PROCEDURE); -} - -void s7_c_type_set_getter(s7_scheme *sc, s7_int tag, s7_pointer getter) -{ - if ((S7_DEBUGGING) && (getter) && (!is_c_function(getter))) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, getter); - sc->c_object_types[tag]->getter = (getter) ? getter : sc->F; -} - -void s7_c_type_set_set(s7_scheme *sc, s7_int tag, s7_pointer (*set)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->set = (set) ? set : fallback_set; -} - -void s7_c_type_set_setter(s7_scheme *sc, s7_int tag, s7_pointer setter) -{ - if ((S7_DEBUGGING) && (setter) && (!is_c_function(setter))) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, setter); - sc->c_object_types[tag]->setter = (setter) ? setter : sc->F; -} - -void *s7_c_object_value(s7_pointer obj) {return(c_object_value(obj));} - -void *s7_c_object_value_checked(s7_pointer obj, s7_int type) -{ - if ((is_c_object(obj)) && (c_object_type(obj) == type)) - return(c_object_value(obj)); - return(NULL); -} - -static s7_pointer make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let, bool with_gc) -{ - s7_pointer x; - new_cell(sc, x, sc->c_object_types[type]->outer_type); - - /* c_object_info(x) = &(sc->c_object_types[type]); */ - /* that won't work because c_object_types can move when it is realloc'd and the old stuff is freed by realloc - * and since we're checking (for example) ref_2 existence as not null, we can't use a table of c_object_t's! - * Using mallocate (s7_make_c_object_with_data) is faster, but not enough to warrant the code. - */ - c_object_type(x) = type; - c_object_value(x) = value; - c_object_set_let(x, (let == sc->rootlet) ? sc->nil : let); - c_object_s7(x) = sc; - if (with_gc) add_c_object(sc, x); - return(x); -} - -s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let) -{ - return(make_c_object_with_let(sc, type, value, let, true)); -} - -s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value) -{ - return(make_c_object_with_let(sc, type, value, sc->nil, true)); -} - -s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value) -{ - return(make_c_object_with_let(sc, type, value, sc->nil, false)); -} - -s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));} - -s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e) -{ - if ((!is_immutable(obj)) && - (is_let(e))) - c_object_set_let(obj, (e == sc->rootlet) ? sc->nil : e); - return(e); -} - -static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj) -{ - return((*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj))); -} - -static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer res = (*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj)); - if (s7_is_integer(res)) - return(s7_integer_clamped_if_gmp(sc, res)); - return(-1); -} - -static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args) -{ - s7_pointer obj = car(args); - check_method(sc, obj, sc->copy_symbol, args); - if (!c_object_copy(sc, obj)) - missing_method_error_nr(sc, sc->copy_symbol, obj); - return((*(c_object_copy(sc, obj)))(sc, args)); -} - -static s7_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj) -{ - return(internal_inlet(sc, 4, - sc->name_symbol, c_object_scheme_name(sc, cobj), - sc->setter_symbol, (c_object_set(sc, cobj) != fallback_set) ? sc->c_object_set_function : sc->F)); - /* should we make new wrappers every time this is called? or save the let somewhere and reuse it? */ -} - -static void apply_c_object(s7_scheme *sc) /* -------- applicable c_object -------- */ -{ - sc->value = (*(c_object_ref(sc, sc->code)))(sc, set_ulist_1(sc, sc->code, sc->args)); - set_car(sc->u1_1, sc->F); -} - -static bool op_implicit_c_object_ref_a(s7_scheme *sc) -{ - s7_pointer c = lookup_checked(sc, car(sc->code)); - if (!is_c_object(c)) {sc->last_function = c; return(false);} - set_car(sc->t2_2, fx_call(sc, cdr(sc->code))); - set_car(sc->t2_1, c); /* fx_call above might use sc->t2* */ - sc->value = (*(c_object_ref(sc, c)))(sc, sc->t2_1); - return(true); -} - - -/* -------- dilambda -------- */ - -s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation) -{ - s7_pointer get_func, set_func; - char *internal_set_name; - s7_int len, name_len; - - if (!name) return(sc->F); - name_len = safe_strlen(name); - len = 16 + name_len; - internal_set_name = (char *)permalloc(sc, len); - internal_set_name[0] = '\0'; - catstrs_direct(internal_set_name, "[set-", name, "]", (const char *)NULL); - get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation); - s7_define(sc, envir, make_symbol(sc, name, name_len), get_func); - set_func = s7_make_safe_function(sc, internal_set_name, setter, set_req_args, set_opt_args, false, documentation); - c_function_set_setter(get_func, set_func); - return(get_func); -} - -s7_pointer s7_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation) -{ - return(s7_dilambda_with_environment(sc, sc->nil, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation)); -} - -s7_pointer s7_typed_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation, - s7_pointer get_sig, s7_pointer set_sig) -{ - s7_pointer get_func = s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation); - s7_pointer set_func = c_function_setter(get_func); - if (get_sig) c_function_signature(get_func) = get_sig; - if (set_sig) c_function_signature(set_func) = set_sig; - return(get_func); -} - - -/* -------------------------------- dilambda? -------------------------------- */ -bool s7_is_dilambda(s7_pointer obj) -{ - switch (type(obj)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - return(is_any_procedure(closure_setter_or_map_list(obj))); /* type >= T_CLOSURE (excludes goto/continuation) */ - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR: - return(is_any_procedure(c_function_setter(obj))); - case T_C_MACRO: - return(is_any_procedure(c_macro_setter(obj))); - } - return(false); -} - -static s7_pointer g_is_dilambda(s7_scheme *sc, s7_pointer args) -{ - #define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter." - #define Q_is_dilambda sc->pl_bt - check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args); -} - - -/* -------------------------------- dilambda -------------------------------- */ -static s7_pointer g_dilambda(s7_scheme *sc, s7_pointer args) -{ - #define H_dilambda "(dilambda getter setter) sets getter's setter to be setter." - #define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol) - - s7_pointer getter = car(args), setter; - if (!is_any_procedure(getter)) - wrong_type_error_nr(sc, sc->dilambda_symbol, 1, getter, a_procedure_or_a_macro_string); - - setter = cadr(args); - if (!is_any_procedure(setter)) - wrong_type_error_nr(sc, sc->dilambda_symbol, 2, setter, a_procedure_or_a_macro_string); - - s7_set_setter(sc, getter, setter); - return(getter); -} - - -/* -------------------------------- arity -------------------------------- */ -static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args) -{ - /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition */ - int32_t len; - - if (is_symbol(x_args)) /* any number of args is ok */ - return(cons(sc, int_zero, max_arity)); - if (closure_arity_unknown(x)) - closure_set_arity(x, s7_list_length(sc, x_args)); - len = closure_arity(x); - if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ - return(cons(sc, make_integer(sc, -len), max_arity)); - return(cons(sc, make_integer(sc, len), make_integer_unchecked(sc, len))); -} - -static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args) -{ - if (closure_arity_unknown(x)) - { - if (is_null(args)) - closure_set_arity(x, 0); - else - if ((is_symbol(args)) || (allows_other_keys(args))) - closure_set_arity(x, -1); - else - { - s7_pointer p; - int32_t i; - for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) /* is_pair(p) so (f1 a . b) will end with b not null */ - { - s7_pointer arg = car(p); - if (arg == sc->rest_keyword) - break; - } - closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */ - }} -} - -static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args) -{ - closure_star_arity_1(sc, x, x_args); - return((closure_arity(x) == -1) ? cons(sc, int_zero, max_arity) : cons(sc, int_zero, make_integer(sc, closure_arity(x)))); -} - -static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer x) -{ - /* not lambda* here */ - if (closure_arity_unknown(x)) - { - int32_t i; - s7_pointer b; - for (i = 0, b = closure_args(x); is_pair(b); i++, b = cdr(b)) {}; - if (is_null(b)) - closure_set_arity(x, i); - else - { - if (i == 0) - return(-1); - closure_set_arity(x, -i); - }} - return(closure_arity(x)); -} - -static int32_t closure_star_arity_to_int(s7_scheme *sc, s7_pointer x) -{ - /* not lambda here */ - closure_star_arity_1(sc, x, closure_args(x)); - return(closure_arity(x)); -} - -s7_pointer s7_arity(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_C_FUNCTION: - return(cons(sc, make_integer(sc, c_function_min_args(x)), make_integer_unchecked(sc, c_function_max_args(x)))); - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR: - return(cons(sc, int_zero, make_integer(sc, c_function_max_args(x)))); - case T_MACRO: case T_BACRO: case T_CLOSURE: - return(closure_arity_to_cons(sc, x, closure_args(x))); - case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - return(closure_star_arity_to_cons(sc, x, closure_args(x))); - case T_C_MACRO: - return(cons(sc, make_integer(sc, c_macro_min_args(x)), make_integer_unchecked(sc, c_macro_max_args(x)))); - case T_GOTO: case T_CONTINUATION: - return(cons(sc, int_zero, max_arity)); - case T_STRING: - return((string_length(x) == 0) ? sc->F : cons(sc, int_one, int_one)); - case T_LET: - return(cons(sc, int_one, int_one)); - case T_C_OBJECT: - check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x)); - return((is_safe_procedure(x)) ? cons(sc, int_zero, max_arity) : sc->F); - case T_VECTOR: - if (vector_length(x) == 0) return(sc->F); - if (has_simple_elements(x)) return(cons(sc, int_one, make_integer(sc, vector_rank(x)))); - return(cons(sc, int_one, max_arity)); - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return((vector_length(x) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(x)))); - case T_PAIR: case T_HASH_TABLE: - return(cons(sc, int_one, max_arity)); - case T_ITERATOR: - return(cons(sc, int_zero, int_zero)); - case T_SYNTAX: - return(cons(sc, small_int(syntax_min_args(x)), (syntax_max_args(x) == -1) ? max_arity : small_int(syntax_max_args(x)))); - } - return(sc->F); -} - -static s7_pointer g_arity(s7_scheme *sc, s7_pointer args) -{ - #define H_arity "(arity obj) the min and max acceptable args for obj if it is applicable, otherwise #f." - #define Q_arity s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T) - /* check_method(sc, p, sc->arity_symbol, args); */ - return(s7_arity(sc, car(args))); -} - - -/* -------------------------------- aritable? -------------------------------- */ -static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args) -{ - /* x_args is unprocessed -- it is exactly the list as used in the closure definition */ - s7_int len; - - if (args == 0) - return(!is_pair(x_args)); - if (is_symbol(x_args)) /* any number of args is ok */ - return(true); - - len = closure_arity(x); - if (len == CLOSURE_ARITY_NOT_SET) - { - len = s7_list_length(sc, x_args); - closure_set_arity(x, len); - } - if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ - return((-len) <= args); /* so we have enough to take care of the required args */ - return(args == len); /* in a normal lambda list, there are no other possibilities */ -} - -static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args) -{ - if (is_symbol(x_args)) - return(true); - closure_star_arity_1(sc, x, x_args); - return((closure_arity(x) == -1) || - (args <= closure_arity(x))); -} - -bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) -{ - switch (type(x)) - { - case T_C_FUNCTION: - return(c_function_is_aritable(x, args)); - case T_C_RST_NO_REQ_FUNCTION: - if ((x == initial_value(sc->hash_table_symbol)) || /* these two need a value for each key */ - (x == initial_value(sc->weak_hash_table_symbol))) - return((args & 1) == 0); - case T_C_FUNCTION_STAR: - return(c_function_max_args(x) >= args); - - case T_MACRO: case T_BACRO: case T_CLOSURE: - return(closure_is_aritable(sc, x, closure_args(x), args)); - - case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - return(closure_star_is_aritable(sc, x, closure_args(x), args)); - - case T_C_MACRO: - return((c_macro_min_args(x) <= args) && - (c_macro_max_args(x) >= args)); - - case T_GOTO: case T_CONTINUATION: - return(true); - - case T_STRING: - return((args == 1) && (string_length(x) > 0)); /* ("" 0) -> error */ - - case T_C_OBJECT: - { - s7_pointer func; - if ((has_active_methods(sc, x)) && - ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined)) - return(s7_apply_function(sc, func, set_plist_2(sc, x, make_integer(sc, args))) != sc->F); - return(is_safe_procedure(x)); - } - - case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return((args > 0) && - (vector_length(x) > 0) && /* (#() 0) -> error */ - (args <= vector_rank(x))); - - case T_LET: case T_HASH_TABLE: case T_PAIR: /* for hash-table, this refers to (table 'key) */ - return(args == 1); - - case T_ITERATOR: - return(args == 0); - - case T_SYNTAX: - return((args >= syntax_min_args(x)) && ((args <= syntax_max_args(x)) || (syntax_max_args(x) == -1))); - } - return(false); -} - -static s7_pointer g_is_aritable(s7_scheme *sc, s7_pointer args) -{ - #define H_is_aritable "(aritable? obj num-args) returns #t if 'obj can be applied to 'num-args arguments." - #define Q_is_aritable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_integer_symbol) - - s7_pointer n = cadr(args); - s7_int num; - - if (!s7_is_integer(n)) /* remember gmp case! */ - return(method_or_bust(sc, n, sc->is_aritable_symbol, args, sc->type_names[T_INTEGER], 2)); - - num = s7_integer_clamped_if_gmp(sc, n); - if (num < 0) - out_of_range_error_nr(sc, sc->is_aritable_symbol, int_two, n, it_is_negative_string); - if (num > MAX_ARITY) num = MAX_ARITY; - return(make_boolean(sc, s7_is_aritable(sc, car(args), num))); -} - -static bool is_aritable_b_7pp(s7_scheme *sc, s7_pointer f, s7_pointer i) {return(g_is_aritable(sc, set_plist_2(sc, f, i)) != sc->F);} - -static int32_t arity_to_int(s7_scheme *sc, s7_pointer x) -{ - int32_t args; - switch (type(x)) - { - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR: - return(c_function_max_args(x)); - - case T_MACRO: case T_BACRO: case T_CLOSURE: - args = closure_arity_to_int(sc, x); - return((args < 0) ? MAX_ARITY : args); - - case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - args = closure_star_arity_to_int(sc, x); - return((args < 0) ? MAX_ARITY : args); - - case T_C_MACRO: return(c_macro_max_args(x)); - case T_C_OBJECT: return(MAX_ARITY); - /* do vectors et al make sense here? */ - } - return(-1); -} - - -/* -------------------------------- sequence? -------------------------------- */ -static s7_pointer g_is_sequence(s7_scheme *sc, s7_pointer args) -{ - #define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)" - #define Q_is_sequence sc->pl_bt - check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol, args); -} - -static bool is_sequence_b(s7_pointer p) {return(is_simple_sequence(p));} - - -/* -------------------------------- setter ------------------------------------------------ */ -static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) -{ - if (type(cadr(args)) != typer) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), - car(args), cadr(args), sc->type_names[type(cadr(args))], sc->type_names[typer])); - return(cadr(args)); -} - -static s7_pointer b_is_symbol_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYMBOL, args));} -static s7_pointer b_is_syntax_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYNTAX, args));} -static s7_pointer b_is_let_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_LET, args));} -static s7_pointer b_is_iterator_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_ITERATOR, args));} -static s7_pointer b_is_c_pointer_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_POINTER, args));} -static s7_pointer b_is_input_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INPUT_PORT, args));} -static s7_pointer b_is_output_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_OUTPUT_PORT, args));} -static s7_pointer b_is_eof_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_EOF, args));} -static s7_pointer b_is_random_state_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_RANDOM_STATE, args));} -static s7_pointer b_is_char_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CHARACTER, args));} -static s7_pointer b_is_string_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_STRING, args));} -static s7_pointer b_is_float_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_FLOAT_VECTOR, args));} -static s7_pointer b_is_int_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INT_VECTOR, args));} -static s7_pointer b_is_byte_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BYTE_VECTOR, args));} -static s7_pointer b_is_hash_table_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_HASH_TABLE, args));} -static s7_pointer b_is_continuation_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CONTINUATION, args));} -static s7_pointer b_is_null_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_NIL, args));} -static s7_pointer b_is_pair_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_PAIR, args));} -static s7_pointer b_is_boolean_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BOOLEAN, args));} -static s7_pointer b_is_undefined_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_UNDEFINED, args));} -static s7_pointer b_is_unspecified_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_UNSPECIFIED, args));} -static s7_pointer b_is_c_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_OBJECT, args));} -static s7_pointer b_is_goto_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_GOTO, args));} - -#define b_setter(sc, typer, args, str, len) \ - do { \ - if (!typer(cadr(args))) \ - error_nr(sc, sc->wrong_type_arg_symbol, \ - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), \ - car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, str, len))); \ - return(cadr(args)); \ - } while (0) - -static s7_pointer b_is_number_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);} -static s7_pointer b_is_complex_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);} -static s7_pointer b_is_gensym_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_gensym, args, "a gensym", 8);} -static s7_pointer b_is_keyword_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_symbol_and_keyword, args, "a keyword", 9);} -static s7_pointer b_is_openlet_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, has_methods, args, "an open let", 11);} -static s7_pointer b_is_macro_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_macro, args, "a macro", 7);} -static s7_pointer b_is_integer_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_integer, args, "an integer", 10);} -static s7_pointer b_is_byte_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_byte, args, "an unsigned byte", 16);} -static s7_pointer b_is_real_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_real, args, "a real", 6);} -static s7_pointer b_is_float_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_t_real, args, "a float", 7);} -static s7_pointer b_is_rational_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_rational, args, "a rational", 10);} -static s7_pointer b_is_list_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_list, args, "a list", 6);} -static s7_pointer b_is_vector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_vector, args, "a vector", 8);} -static s7_pointer b_is_procedure_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_procedure, args, "a procedure", 11);} -static s7_pointer b_is_dilambda_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_dilambda, args, "a dilambda", 10);} -static s7_pointer b_is_sequence_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_sequence, args, "a sequence", 10);} -static s7_pointer b_is_subvector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_subvector, args, "a subvector", 11);} -static s7_pointer b_is_weak_hash_table_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_weak_hash_table, args, "a weak hash-table", 17);} - -static s7_pointer b_is_proper_list_setter(s7_scheme *sc, s7_pointer args) -{ - if (!s7_is_proper_list(sc, car(args))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), - car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, "a proper list", 13))); - return(cadr(args)); -} - -static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer p, s7_pointer e) -{ - if (!((is_let(e)) || (e == sc->rootlet) || (e == sc->nil))) - wrong_type_error_nr(sc, sc->setter_symbol, 2, e, sc->type_names[T_LET]); /* need to check this in case let arg is bogus */ - - switch (type(p)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_any_procedure(closure_setter(p))) /* setter already known */ - return(closure_setter(p)); - if (!closure_no_setter(p)) - { - s7_pointer f = funclet_entry(sc, p, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(p) */ - if (f) - { - if (f == sc->F) - { - closure_set_no_setter(p); - return(sc->F); - } - if (!is_any_procedure(f)) - sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, p, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45)); - closure_set_setter(p, f); - return(f); - } - /* we used to search for setter here, but that can find the built-in setter causing an infinite loop (maybe check for that??) */ - closure_set_no_setter(p); - } - return(sc->F); - - case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: - return(c_function_setter(p)); - - case T_C_MACRO: - return(c_macro_setter(p)); -#if 0 - case T_GOTO: case T_CONTINUATION: - return(sc->F); -#endif - case T_C_OBJECT: - check_method(sc, p, sc->setter_symbol, set_plist_2(sc, p, e)); - return((c_object_set(sc, p) == fallback_set) ? sc->F : sc->c_object_set_function); /* for example ((setter obj) obj 0 1.0) if s7test block */ - /* this could wrap the setter as an s7_function giving p's class-name etc */ - - case T_LET: - check_method(sc, p, sc->setter_symbol, set_plist_2(sc, p, e)); - return(global_value(sc->let_set_symbol)); - - case T_ITERATOR: /* (set! (iter) val) doesn't fit the other setters */ - return((is_any_closure(iterator_sequence(p))) ? closure_setter(iterator_sequence(p)) : sc->F); - - case T_PAIR: return(global_value(sc->list_set_symbol)); /* or maybe initial-value? */ - case T_HASH_TABLE: return(global_value(sc->hash_table_set_symbol)); - case T_STRING: return(global_value(sc->string_set_symbol)); - case T_BYTE_VECTOR: return(global_value(sc->byte_vector_set_symbol)); - case T_VECTOR: return(global_value(sc->vector_set_symbol)); - case T_INT_VECTOR: return(global_value(sc->int_vector_set_symbol)); - case T_FLOAT_VECTOR: return(global_value(sc->float_vector_set_symbol)); - case T_SLOT: return((slot_has_setter(p)) ? slot_setter(p) : sc->F); - - case T_SYMBOL: /* (setter symbol let) */ - { - s7_pointer sym = p, slot, setter; - if (is_keyword(sym)) - return(sc->F); - if ((e == sc->rootlet) || (e == sc->nil)) - slot = global_slot(sym); - else - { - s7_pointer old_e = sc->curlet; - set_curlet(sc, e); - slot = lookup_slot_from(sym, sc->curlet); - set_curlet(sc, old_e); - } - if ((!is_slot(slot)) || (!slot_has_setter(slot))) return(sc->F); - setter = slot_setter(slot); - if (is_bool_function(setter)) return(c_function_setter(setter)); - return(setter); - }} -#if 0 - wrong_type_error_nr(sc, sc->setter_symbol, 1, p, wrap_string(sc, "something that might have a setter", 34)); /* this seems unfriendly -- why not return #f? */ - return(NULL); /* make tcc happy */ -#else - return(sc->F); -#endif -} - -static s7_pointer g_setter(s7_scheme *sc, s7_pointer args) -{ - #define H_setter "(setter obj let) returns the setter associated with obj" - #define Q_setter s7_make_signature(sc, 3, s7_make_signature(sc, 2, \ - sc->not_symbol, sc->is_procedure_symbol), sc->T, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol)) - return(setter_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->curlet)); -} - -s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj) {return(setter_p_pp(sc, obj, sc->curlet));} - - -/* -------------------------------- set-setter -------------------------------- */ -static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer acc) -{ - s7_int loc; - if (sc->protected_setters_size == sc->protected_setters_loc) - { - s7_int size = sc->protected_setters_size; - s7_int new_size = 2 * size; - block_t *ob = vector_block(sc->protected_setters); - block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - block_info(nb) = NULL; - vector_block(sc->protected_setters) = nb; - vector_elements(sc->protected_setters) = (s7_pointer *)block_data(nb); - vector_length(sc->protected_setters) = new_size; - - ob = vector_block(sc->protected_setter_symbols); - nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - vector_block(sc->protected_setter_symbols) = nb; - vector_elements(sc->protected_setter_symbols) = (s7_pointer *)block_data(nb); - vector_length(sc->protected_setter_symbols) = new_size; - - for (s7_int i = size; i < new_size; i++) - { - vector_element(sc->protected_setters, i) = sc->unused; - vector_element(sc->protected_setter_symbols, i) = sc->unused; - } - sc->protected_setters_size = new_size; - } - loc = sc->protected_setters_loc++; - vector_element(sc->protected_setters, loc) = acc; - vector_element(sc->protected_setter_symbols, loc) = sym; -} - -static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer args) -{ - s7_pointer func, slot; - if (is_keyword(sym)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, sym, wrap_string(sc, "a normal symbol (a keyword can't be set)", 40)); - - if (is_pair(cddr(args))) - { - s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ - func = caddr(args); - if ((e == sc->rootlet) || (e == sc->nil)) - slot = global_slot(sym); - else - { - if (!is_let(e)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, e, sc->type_names[T_LET]); - slot = lookup_slot_from(sym, e); - }} - else - { - slot = lookup_slot_from(sym, sc->curlet); /* (set! (setter 'x) (lambda (s v) ...)) */ - func = cadr(args); - } - if (!is_slot(slot)) - return(sc->F); - - if (func != sc->F) - { - if (sym == sc->setter_symbol) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter 'setter) to ~S", 32), func)); - if (is_syntax_or_qq(slot_value(slot))) /* (set! (setter 'begin) ...), qq is syntax sez r7rs */ - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't set (setter '~S) to ~S", 28), sym, func)); - if (!is_any_procedure(func)) /* disallow continuation/goto here */ - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 3, func, wrap_string(sc, "a function or #f", 16)); - if ((!is_c_function(func)) || (!c_function_has_bool_setter(func))) - { - if (s7_is_aritable(sc, func, 3)) - set_has_let_arg(func); - else - if (!s7_is_aritable(sc, func, 2)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "symbol setter function, ~A, should take 2 or 3 arguments", 56), func)); - }} - if (slot == global_slot(sym)) - s7_set_setter(sc, sym, func); /* special GC protection for global vars */ - else slot_set_setter(slot, func); /* func might be #f */ - if (func != sc->F) - slot_set_has_setter(slot); - return(func); -} - -static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = car(args), setter; - if (is_symbol(p)) - return(symbol_set_setter(sc, p, args)); - if (p == sc->s7_starlet) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, p, wrap_string(sc, "something other than *s7*", 25)); - - setter = cadr(args); - if (setter != sc->F) - { - if (!is_any_procedure(setter)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, setter, wrap_string(sc, "a procedure or #f", 17)); - if (arity_to_int(sc, setter) < 1) /* we need at least an arg for the set! value */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take at least one argument", 54), setter)); - } - switch (type(p)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - closure_set_setter(p, setter); - if (setter == sc->F) - closure_set_no_setter(p); - break; - - case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: - if (p == global_value(sc->setter_symbol)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter setter) to ~S", 31), setter)); - c_function_set_setter(p, setter); - if ((is_any_closure(setter)) || - (is_any_macro(setter))) - add_setter(sc, p, setter); - break; - - case T_C_MACRO: - c_macro_set_setter(p, setter); - if ((is_any_closure(setter)) || - (is_any_macro(setter))) - add_setter(sc, p, setter); - break; - - default: /* (set! (setter 4) ...) or p==continuation etc */ - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, p, wrap_string(sc, "a symbol, a procedure, or a macro", 33)); - } - return(setter); -} - -s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) -{ - if (is_symbol(p)) - { - if (slot_has_setter(global_slot(p))) - for (s7_int index = 0; index < sc->protected_setters_loc; index++) - if (vector_element(sc->protected_setter_symbols, index) == p) - { - s7_pointer old_func = vector_element(sc->protected_setters, index); - if ((is_any_procedure(old_func)) && /* i.e. not #f! */ - (is_immutable(old_func))) - return(setter); - vector_element(sc->protected_setters, index) = setter; - slot_set_setter(global_slot(p), setter); - if ((setter != sc->F) && (s7_is_aritable(sc, setter, 3))) - set_has_let_arg(setter); - return(setter); - } - if (setter != sc->F) - { - slot_set_has_setter(global_slot(p)); - protect_setter(sc, p, setter); - slot_set_setter(global_slot(p), setter); - if (s7_is_aritable(sc, setter, 3)) - set_has_let_arg(setter); - return(setter); - } - slot_set_setter(global_slot(p), setter); - return(setter); - } - return(g_set_setter(sc, set_plist_2(sc, p, setter))); -} - -/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix)) - * so set setter before use! - */ - -static s7_pointer call_c_function_setter(s7_scheme *sc, s7_pointer func, s7_pointer symbol, s7_pointer new_value) -{ - if (has_let_arg(func)) - return(c_function_call(func)(sc, with_list_t3(symbol, new_value, sc->curlet))); - return(c_function_call(func)(sc, with_list_t2(symbol, new_value))); -} - -static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) /* see also op_set1 */ -{ - s7_pointer func = slot_setter(slot), result; - if (is_c_function(func)) - return(call_c_function_setter(sc, func, slot_symbol(slot), new_value)); - if (!is_any_procedure(func)) - return(new_value); - sc->temp10 = (has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value, sc->curlet) : list_2(sc, slot_symbol(slot), new_value); - /* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */ - result = s7_call(sc, func, sc->temp10); - sc->temp10 = sc->unused; - return(result); -} - -static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value) -{ - s7_pointer func = setter_p_pp(sc, symbol, sc->curlet); - if (is_c_function(func)) - return(call_c_function_setter(sc, func, symbol, new_value)); - if (!is_any_procedure(func)) - return(new_value); - sc->args = (has_let_arg(func)) ? list_3(sc, symbol, new_value, sc->curlet) : list_2(sc, symbol, new_value); - push_stack_direct(sc, op); - sc->code = func; - return(sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */ -} - - -/* -------------------------------- hooks -------------------------------- */ -s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook) -{ - return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook))); -} - -s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions) -{ - if (is_list(functions)) - let_set(sc, closure_let(hook), sc->body_symbol, functions); - return(functions); -} - - -/* -------------------------------- eq? eqv? equal? equivalent? -------------------------------- */ -bool s7_is_eq(s7_pointer obj1, s7_pointer obj2) -{ - return((obj1 == obj2) || /* so floats and NaNs might be eq? but not eqv? */ - ((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */ -} - -static s7_pointer is_eq_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) -{ - return(make_boolean(sc, ((obj1 == obj2) || ((is_unspecified(obj1)) && (is_unspecified(obj2)))))); -} - -static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args) -{ - #define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2" - #define Q_is_eq sc->pcl_bt - return(make_boolean(sc, ((car(args) == cadr(args)) || - ((is_unspecified(car(args))) && (is_unspecified(cadr(args))))))); - /* (eq? (apply apply apply values '(())) #) should return #t */ -} - -bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ -#if WITH_GMP - if ((is_big_number(a)) || (is_big_number(b))) return(big_numbers_are_eqv(sc, a, b)); -#endif - if (type(a) != type(b)) return(false); - if ((a == b) && (!is_number(a))) /* if a is NaN, a == b doesn't mean (eqv? a b) */ - return(true); /* a == b means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ - if (is_number(a)) return(numbers_are_eqv(sc, a, b)); - if (is_unspecified(a)) return(true); /* types are the same so we know b is also unspecified */ - return(false); -} - -static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args) -{ - #define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" - #define Q_is_eqv sc->pcl_bt - return(make_boolean(sc, s7_is_eqv(sc, car(args), cadr(args)))); -} - -static s7_pointer is_eqv_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) {return(make_boolean(sc, s7_is_eqv(sc, obj1, obj2)));} - -static bool floats_are_equivalent(s7_scheme *sc, s7_double x, s7_double y) -{ - s7_double diff; - if (x == y) return(true); - diff = fabs(x - y); - if (diff <= sc->equivalent_float_epsilon) return(true); - return((is_NaN(x)) && (is_NaN(y))); -} - -#if WITH_GMP -static bool big_floats_are_equivalent(s7_scheme *sc, mpfr_t x, mpfr_t y) -{ - /* protect mpfr_1 */ - if ((mpfr_nan_p(x)) || (mpfr_nan_p(y))) - return((mpfr_nan_p(x)) && (mpfr_nan_p(y))); - mpfr_sub(sc->mpfr_3, x, y, MPFR_RNDN); - mpfr_abs(sc->mpfr_3, sc->mpfr_3, MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_3, sc->equivalent_float_epsilon) <= 0); -} -#endif - -static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);} - -static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) return(true); - if (!is_normal_symbol(y)) return(false); /* (equivalent? ''(1) '(1)) */ - return((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its own */ - (is_syntax(global_value(x))) && - (is_slot(global_slot(y))) && - (is_syntax(global_value(y))) && - (syntax_symbol(global_value(x)) == syntax_symbol(global_value(y)))); -} - -static bool unspecified_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(is_unspecified(y)); -} - -static bool undefined_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((x == y) || - ((is_undefined(y)) && (undefined_name_length(x) == undefined_name_length(y)) && - (safe_strcmp(undefined_name(x), undefined_name(y))))); -} - -static bool is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((*(equals[type(x)]))(sc, x, y, ci)); -} - -static bool is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((*(equivalents[type(x)]))(sc, x, y, ci)); -} - -static bool c_pointer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - shared_info_t *nci = ci; - if (x == y) return(true); - if (!s7_is_c_pointer(y)) return(false); - if (c_pointer(x) != c_pointer(y)) return(false); - if (c_pointer_type(x) != c_pointer_type(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equivalent_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) - return(false); - } - if (c_pointer_info(x) != c_pointer_info(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equivalent_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) - return(false); - } - return(true); -} - -static bool c_pointer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - shared_info_t *nci = ci; - if (x == y) return(true); - if (!s7_is_c_pointer(y)) return(false); - if (c_pointer(x) != c_pointer(y)) return(false); - if (c_pointer_type(x) != c_pointer_type(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) - return(false); - } - if (c_pointer_info(x) != c_pointer_info(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) - return(false); - } - return(true); -} - -static bool string_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((is_string(y)) && (scheme_strings_are_equal(x, y))); -} - -static bool syntax_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y))); -} - -static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(x == y);} - -static bool port_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) return(true); - if (type(x) != type(y)) return(false); - if ((port_is_closed(x)) && (port_is_closed(y))) return(true); - if ((port_is_closed(x)) || (port_is_closed(y))) return(false); /* if either is closed, port_port (below) might be null */ - if (port_type(x) != port_type(y)) return(false); - switch (port_type(x)) - { - case STRING_PORT: - return((port_position(x) == port_position(y)) && - (port_data_size(x) == port_data_size(y)) && - (local_strncmp((const char *)port_data(x), (const char *)port_data(y), (is_input_port(x)) ? port_data_size(x) : port_position(x)))); - case FILE_PORT: - return((is_input_port(x)) && - (port_position(x) == port_position(y)) && - (local_strncmp((const char *)port_filename(x), (const char *)port_filename(y), port_filename_length(x)))); - case FUNCTION_PORT: - if (is_input_port(x)) - return(port_input_function(x) == port_input_function(y)); - return(port_output_function(x) == port_output_function(y)); - } - return(false); -} - -static void add_shared_ref(shared_info_t *ci, s7_pointer x, int32_t ref_x) -{ - /* called only in equality check, not printer */ - if (ci->top == ci->size) - enlarge_shared_info(ci); - set_collected(x); - ci->objs[ci->top] = x; - ci->refs[ci->top++] = ref_x; -} - -static Inline bool inline_equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* pair_equal:lg/list/io, [read] */ -{ - /* here we know x and y are pointers to the same type of structure */ - int32_t ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0; - if (is_collected(x)) - { - int32_t ref_x = peek_shared_ref_1(ci, x); - if (ref_y != 0) - return(ref_x == ref_y); /* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */ - /* try to harmonize the new guy -- there can be more than one structure equal to the current one */ - if (ref_x != 0) - add_shared_ref(ci, y, ref_x); - } - else - if (ref_y != 0) - add_shared_ref(ci, x, ref_y); - else - { - /* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer */ - if (ci->top >= ci->size2) enlarge_shared_info(ci); - set_collected(x); - set_collected(y); - ci->objs[ci->top] = x; - ci->refs[ci->top++] = ++ci->ref; - ci->objs[ci->top] = y; - ci->refs[ci->top++] = ci->ref; - } - return(false); -} - -static bool equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(inline_equal_ref(sc, x, y, ci));} - -static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, shared_info_t *ci) -{ - s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args); - shared_info_t *nci = ci; - s7_pointer pa, pb; - - if (a == b) - return(true); - if (!is_c_object(b)) - return(false); - if (c_object_type(a) != c_object_type(b)) - return(false); - - if (c_object_equal(sc, a)) - return(((*(c_object_equal(sc, a)))(sc, set_clist_2(sc, a, b))) != sc->F); - if (c_object_eql(sc, a)) - return((*(c_object_eql(sc, a)))(c_object_value(a), c_object_value(b))); - - to_list = c_object_to_list(sc, a); - if (!to_list) - return(false); - if (ci) - { - if (equal_ref(sc, a, b, ci)) return(true); /* and nci == ci above */ - } - else nci = new_shared_info(sc); - - for (pa = to_list(sc, set_plist_1(sc, a)), pb = to_list(sc, set_plist_1(sc, b)); is_pair(pa) && (is_pair(pb)); pa = cdr(pa), pb = cdr(pb)) - if (!(is_equal_1(sc, car(pa), car(pb), nci))) - return(false); - return(pa == pb); /* presumably both are nil if successful */ -} - -#define check_equivalent_method(Sc, X, Y) \ - do { \ - if (has_active_methods(sc, X)) \ - { \ - s7_pointer equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \ - if (equal_func != Sc->undefined) \ - return(s7_boolean(Sc, s7_apply_function(Sc, equal_func, set_plist_2(Sc, X, Y)))); \ - }} \ - while (0) - -static bool c_objects_are_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - check_equivalent_method(sc, x, y); - if (c_object_equivalent(sc, x)) - return(((*(c_object_equivalent(sc, x)))(sc, set_plist_2(sc, x, y))) != sc->F); - return(c_objects_are_equal(sc, x, y, ci)); -} - -static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent) -{ - hash_entry_t **lists; - s7_int len; - shared_info_t *nci = ci; - hash_check_t hf; - bool (*eqf)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); - - if (x == y) - return(true); - if (!is_hash_table(y)) - { - if (equivalent) - check_equivalent_method(sc, y, x); - return(false); - } - if ((ci) && (equal_ref(sc, x, y, ci))) return(true); - - if (hash_table_entries(x) != hash_table_entries(y)) - return(false); - if (hash_table_entries(x) == 0) - return(true); - if ((!equivalent) && ((hash_table_mapper(x) != default_hash_map) || (hash_table_mapper(y) != default_hash_map))) - { - if (hash_table_checker(x) != hash_table_checker(y)) - return(false); - if (hash_table_mapper(x) != hash_table_mapper(y)) - return(false); - } - - len = hash_table_mask(x) + 1; - lists = hash_table_elements(x); - if (!nci) nci = new_shared_info(sc); - eqf = (equivalent) ? is_equivalent_1 : is_equal_1; - - hf = hash_table_checker(y); - if ((hf != hash_equal) && (hf != hash_equivalent)) - { - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) - { - hash_entry_t *y_val = hf(sc, y, hash_entry_key(p)); - if (y_val == sc->unentry) - return(false); - if (!eqf(sc, hash_entry_value(p), hash_entry_value(y_val), nci)) - return(false); - } - /* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match, - * so surely the tables are equal?? - * if ci not null or hash-table-checker is equal/eqivalent, can't use hf? - */ - return(true); - } - - /* we need to protect the current shared_info data (nci) here so the current hash_table_checker won't work -- - * outside equal?/eqivalent? they can safely assume that they can start a new shared_info process. - */ - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) - { - s7_pointer key = hash_entry_key(p); - s7_int hash = hash_loc(sc, y, key); - s7_int loc = hash & hash_table_mask(y); - hash_entry_t *xe; - - for (xe = hash_table_element(y, loc); xe; xe = hash_entry_next(xe)) - if (hash_entry_raw_hash(xe) == hash) - if (eqf(sc, hash_entry_key(xe), key, nci)) - break; - if (!xe) - return(false); - if (!eqf(sc, hash_entry_value(p), hash_entry_value(xe), nci)) - return(false); - } - return(true); -} - -static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, false));} -static bool hash_table_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, true));} - -static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) -{ - for (s7_pointer ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(is_equal_1(sc, slot_value(px), slot_value(py), nci)); - return(false); -} - -static bool slots_equivalent_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) -{ - for (s7_pointer ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); - return(false); -} - -static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent) -{ - s7_pointer ex, ey, px, py; - shared_info_t *nci = ci; - int32_t x_len, y_len; - - if ((!is_let(y)) || (x == sc->rootlet) || (y == sc->rootlet)) - return(false); - - if ((ci) && (equal_ref(sc, x, y, ci))) return(true); - - clear_symbol_list(sc); - for (x_len = 0, ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) - for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) - if (!symbol_is_in_list(sc, slot_symbol(px))) - { - add_symbol_to_list(sc, slot_symbol(px)); - x_len++; - } - - for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (!symbol_is_in_list(sc, slot_symbol(py))) /* symbol in y, not in x */ - return(false); - - for (y_len = 0, ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (symbol_tag(slot_symbol(py)) != 0) - { - y_len++; - symbol_set_tag(slot_symbol(py), 0); - } - - if (x_len != y_len) /* symbol in x, not in y */ - return(false); - - if (!nci) nci = new_shared_info(sc); - - for (ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) - for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) - if (symbol_tag(slot_symbol(px)) == 0) /* unshadowed */ - { - symbol_set_tag(slot_symbol(px), sc->syms_tag); /* values don't match */ - if (((!equivalent) && (!slots_match(sc, px, y, nci))) || - ((equivalent) && (!slots_equivalent_match(sc, px, y, nci)))) - return(false); - } - return(true); -} - -static bool let_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - /* x == y if all unshadowed vars match, leaving aside the rootlet, so that for any local variable, we get the same value in either x or y */ - return((x == y) || (let_equal_1(sc, x, y, ci, false))); -} - -/* what should these do if there are setters? */ -static bool let_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) return(true); - if (!is_global(sc->is_equivalent_symbol)) - { - check_equivalent_method(sc, x, y); - check_equivalent_method(sc, y, x); - } - return(let_equal_1(sc, x, y, ci, true)); -} - -static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) - return(true); - if (type(x) != type(y)) - return(false); - if ((has_active_methods(sc, x)) && - (has_active_methods(sc, y))) - { - s7_pointer equal_func = find_method(sc, closure_let(x), sc->is_equal_symbol); - if (equal_func != sc->undefined) - return(s7_boolean(sc, s7_apply_function(sc, equal_func, set_plist_2(sc, x, y)))); - } - return(false); -} - -static bool closure_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) - return(true); - if (type(x) != type(y)) - return(false); - if (has_active_methods(sc, y)) - check_equivalent_method(sc, x, y); - /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y)) - * because locally defined constant functions on the second pass find the outer let. - */ - return((is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) && - (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); -} - -static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_pointer px, py; - if (x == y) - return(true); - if (!is_pair(y)) - return(false); - if (!ci) - ci = new_shared_info(sc); - else - if (inline_equal_ref(sc, x, y, ci)) - return(true); - - if (!is_equal_1(sc, car(x), car(y), ci)) return(false); - for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) - { - if (!is_equal_1(sc, car(px), car(py), ci)) return(false); - if (inline_equal_ref(sc, px, py, ci)) return(true); - } - return((px == py) || (is_equal_1(sc, px, py, ci))); -} - -static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_pointer px, py; - if (x == y) - return(true); - if (!is_pair(y)) - { - check_equivalent_method(sc, y, x); - return(false); - } - if (!ci) - ci = new_shared_info(sc); - else - if (inline_equal_ref(sc, x, y, ci)) - return(true); - - if (!is_equivalent_1(sc, car(x), car(y), ci)) return(false); - for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) - { - if (!is_equivalent_1(sc, car(px), car(py), ci)) return(false); - if (inline_equal_ref(sc, px, py, ci)) return(true); - } - return((px == py) || ((is_equivalent_1(sc, px, py, ci)))); -} - -static bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_int x_dims; - - if (!vector_has_dimension_info(x)) - return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); - x_dims = vector_ndims(x); - if (x_dims == 1) - return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); - if ((!vector_has_dimension_info(y)) || - (x_dims != vector_ndims(y))) - return(false); - - for (s7_int j = 0; j < x_dims; j++) - if (vector_dimension(x, j) != vector_dimension(y, j)) - return(false); - return(true); -} - -static bool iv_meq(s7_int *ex, s7_int *ey, s7_int len) -{ - s7_int i = 0, left = len - 8; - while (i <= left) - LOOP_8(if (ex[i] != ey[i]) return(false); i++); - for (; i < len; i++) - if (ex[i] != ey[i]) - return(false); - return(true); -} - -static bool byte_vector_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_int len = vector_length(x); - const uint8_t *xp = byte_vector_bytes(x); - const uint8_t *yp = byte_vector_bytes(y); - for (s7_int i = 0; i < len; i++) - if (xp[i] != yp[i]) - return(false); - return(true); -} - -static bool biv_meq(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len = vector_length(x); - const uint8_t *xp = byte_vector_bytes(x); - const s7_int *yp = int_vector_ints(y); - for (s7_int i = 0; i < len; i++) - if ((s7_int)(xp[i]) != yp[i]) - return(false); - return(true); -} - -#define base_vector_equal(sc, x, y) \ - do { \ - if (x == y) return(true); \ - len = vector_length(x); \ - if (len != vector_length(y)) return(false); \ - if (!vector_rank_match(sc, x, y)) return(false); \ - if (len == 0) return(true); \ - } while (0) - -static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - shared_info_t *nci = ci; - - if (!is_any_vector(y)) return(false); - base_vector_equal(sc, x, y); /* sets len */ - if (type(x) != type(y)) - { - if ((is_int_vector(x)) && (is_byte_vector(y))) - return(biv_meq(sc, y, x, NULL)); - if ((is_byte_vector(x)) && (is_int_vector(y))) - return(biv_meq(sc, x, y, NULL)); - for (s7_int i = 0; i < len; i++) - if (!is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ - return(false); - return(true); - } - if (!has_simple_elements(x)) - { - if (ci) - { - if (equal_ref(sc, x, y, ci)) return(true); - } - else nci = new_shared_info(sc); - } - for (s7_int i = 0; i < len; i++) - if (!(is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci))) - return(false); - return(true); -} - -static bool byte_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - if (!is_byte_vector(y)) - return(vector_equal(sc, x, y, ci)); - base_vector_equal(sc, x, y); - return(byte_vector_equal_1(sc, x, y)); -} - -static bool int_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - if (!is_int_vector(y)) - return(vector_equal(sc, x, y, ci)); - base_vector_equal(sc, x, y); - return(iv_meq(int_vector_ints(x), int_vector_ints(y), len)); -} - -static bool float_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - if (!is_float_vector(y)) - return(vector_equal(sc, x, y, ci)); - base_vector_equal(sc, x, y); - for (s7_int i = 0; i < len; i++) - if (float_vector(x, i) != float_vector(y, i)) - return(false); - return(true); -} - -static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - /* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */ - s7_int i, len; - shared_info_t *nci = ci; - - if (x == y) - return(true); - if (!is_any_vector(y)) - { - check_equivalent_method(sc, y, x); - return(false); - } - len = vector_length(x); - if (len != vector_length(y)) return(false); - if (len == 0) return(true); - if (!vector_rank_match(sc, x, y)) return(false); - - if (type(x) != type(y)) - { - /* (equivalent? (make-int-vector 3 0) (make-vector 3 0)) -> #t - * (equivalent? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t - */ - if ((is_int_vector(x)) && (is_byte_vector(y))) - return(biv_meq(sc, y, x, NULL)); - if ((is_byte_vector(x)) && (is_int_vector(y))) - return(biv_meq(sc, x, y, NULL)); - for (i = 0; i < len; i++) - if (!is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ - return(false); - return(true); - } - - if (is_float_vector(x)) - { - s7_double *arr1 = float_vector_floats(x), *arr2 = float_vector_floats(y); - s7_double fudge = sc->equivalent_float_epsilon; - if (fudge == 0.0) - { - for (i = 0; i < len; i++) - if ((arr1[i] != arr2[i]) && - ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i])))) - return(false); - } - else - if ((len & 0x3) == 0) - for (i = 0; i < len; ) - LOOP_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++); - else - for (i = 0; i < len; i++) - if (!floats_are_equivalent(sc, arr1[i], arr2[i])) - return(false); - return(true); - } - if (is_int_vector(x)) - return(iv_meq(int_vector_ints(x), int_vector_ints(y), len)); - if (is_byte_vector(x)) - return(byte_vector_equal_1(sc, x, y)); - - if (!has_simple_elements(x)) - { - if (ci) - { - if (equal_ref(sc, x, y, ci)) return(true); - } - else nci = new_shared_info(sc); - } - for (i = 0; i < len; i++) - if (!(is_equivalent_1(sc, vector_element(x, i), vector_element(y, i), nci))) - return(false); - return(true); -} - -static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent) -{ - s7_pointer x_seq, y_seq, xs, ys; - - if (x == y) return(true); - if (!is_iterator(y)) return(false); - - x_seq = iterator_sequence(x); - y_seq = iterator_sequence(y); - - switch (type(x_seq)) - { - case T_STRING: - return((is_string(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y)) && - (string_equal(sc, x_seq, y_seq, ci))); - - case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: - return((is_any_vector(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y)) && - ((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) : - ((is_normal_vector(x_seq)) ? (vector_equal(sc, x_seq, y_seq, ci)) : - ((is_float_vector(x_seq)) ? (float_vector_equal(sc, x_seq, y_seq, ci)) : - ((is_int_vector(x_seq)) ? (int_vector_equal(sc, x_seq, y_seq, ci)) : - (byte_vector_equal(sc, x_seq, y_seq, ci))))))); - - /* iterator_next is a function (pair_iterate, iterator_finished etc) */ - case T_PAIR: - if (iterator_next(x) != iterator_next(y)) return(false); /* even if seqs are equal, one might be at end */ - if (equivalent) - { - if (!pair_equivalent(sc, x_seq, y_seq, ci)) - return(false); - } - else - if (!pair_equal(sc, x_seq, y_seq, ci)) - return(false); - - for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys); xs = cdr(xs), ys = cdr(ys)) - if (xs == iterator_current(x)) - return(ys == iterator_current(y)); - return(is_null(xs) && is_null(ys)); - - case T_NIL: /* (make-iterator #()) works, so () should too */ - return(is_null(y_seq)); /* perhaps for equivalent case, check position in y as well as pair(seq(y))? */ - - case T_C_OBJECT: - if ((is_c_object(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y))) - { - if (equivalent) - return(c_objects_are_equivalent(sc, x_seq, y_seq, ci)); - return(c_objects_are_equal(sc, x_seq, y_seq, ci)); - } - return(false); - - case T_LET: - if (!is_let(y_seq)) return(false); - if (iterator_next(x) != iterator_next(y)) return(false); - if (x_seq == sc->rootlet) - return(iterator_position(x) == iterator_position(y)); /* y_seq must also be sc->rootlet since nexts are the same (rootlet_iterate) */ - if (equivalent) - { - if (!let_equivalent(sc, x_seq, y_seq, ci)) - return(false); - } - else - if (!let_equal(sc, x_seq, y_seq, ci)) - return(false); - - for (xs = let_slots(x_seq), ys = let_slots(y_seq); tis_slot(xs) && tis_slot(ys); xs = next_slot(xs), ys = next_slot(ys)) - if (xs == iterator_current_slot(x)) - return(ys == iterator_current_slot(y)); - return(is_slot_end(xs) && is_slot_end(ys)); - - case T_HASH_TABLE: - if (!is_hash_table(y_seq)) return(false); - if (hash_table_entries(x_seq) != hash_table_entries(y_seq)) return(false); - if (hash_table_entries(x_seq) == 0) return(true); - if (iterator_position(x) != iterator_position(y)) return(false); - if (!equivalent) - return(hash_table_equal(sc, x_seq, y_seq, ci)); - return(hash_table_equivalent(sc, x_seq, y_seq, ci)); - - case T_CLOSURE: case T_CLOSURE_STAR: - return(x_seq == y_seq); /* or closure_equal/equivalent? */ - - default: - break; - } - return(false); -} - -static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, false));} -static bool iterator_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, true));} - -#if WITH_GMP -static bool big_integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - /* (equal? 1 1.0) -> #f */ - if (is_t_big_integer(y)) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); - return((is_t_integer(y)) && (mpz_cmp_si(big_integer(x), integer(y)) == 0)); -} - -static bool big_ratio_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_big_ratio(y)) - return(mpq_equal(big_ratio(x), big_ratio(y))); - if (is_t_ratio(y)) - return((numerator(y) == mpz_get_si(mpq_numref(big_ratio(x)))) && - (denominator(y) == mpz_get_si(mpq_denref(big_ratio(x))))); - return(false); -} - -static bool big_real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_big_real(y)) - return(mpfr_equal_p(big_real(x), big_real(y))); - if (is_t_real(y)) - { - if (mpfr_nan_p(big_real(x))) return(false); - return((!is_NaN(real(y))) && - (mpfr_cmp_d(big_real(x), real(y)) == 0)); - } - return(false); -} - -static bool big_complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x))))) - return(false); - if (is_t_big_complex(y)) - return((!mpfr_nan_p(mpc_realref(big_complex(y)))) && - (!mpfr_nan_p(mpc_imagref(big_complex(y)))) && - (mpc_cmp(big_complex(x), big_complex(y)) == 0)); - if (is_t_complex(y)) - return((!is_NaN(real_part(y))) && - (!is_NaN(imag_part(y))) && - (mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y)) == 0)); - return(false); -} -#endif - -static bool integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_integer(y)) - return(integer(x) == integer(y)); -#if WITH_GMP - if (is_t_big_integer(y)) - return(mpz_cmp_si(big_integer(y), integer(x)) == 0); -#endif - return(false); -} - -/* apparently ratio_equal is predefined in g++ -- name collision on mac */ -static bool fraction_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_ratio(y)) - return((numerator(x) == numerator(y)) && - (denominator(x) == denominator(y))); -#if WITH_GMP - if (is_t_big_ratio(y)) - return((numerator(x) == mpz_get_si(mpq_numref(big_ratio(y)))) && - (denominator(x) == mpz_get_si(mpq_denref(big_ratio(y))))); -#endif - return(false); -} - -static bool real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_real(y)) - return(real(x) == real(y)); -#if WITH_GMP - if (is_t_big_real(y)) - return((!is_NaN(real(x))) && - (!mpfr_nan_p(big_real(y))) && - (mpfr_cmp_d(big_real(y), real(x)) == 0)); -#endif - return(false); -} - -static bool complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_complex(y)) - return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); -#if WITH_GMP - if (is_t_big_complex(y)) - { - if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - return((mpfr_cmp_d(mpc_realref(big_complex(y)), real_part(x)) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x)) == 0)); - } -#endif - return(false); -} - -#if WITH_GMP -static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool int_case) -{ - if (int_case) - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - else mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - - switch (type(y)) - { - case T_INTEGER: - if (int_case) - return(mpz_cmp_si(big_integer(x), integer(y)) == 0); - mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_RATIO: - mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_REAL: - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_COMPLEX: - mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); - if (!big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) - return(false); - if (is_NaN(imag_part(y))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); - return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); - case T_BIG_INTEGER: - if (int_case) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - if (big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) - { - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); - }} - return(false); -} - -static bool big_integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(big_integer_or_ratio_equivalent(sc, x, y, ci, true)); -} - -static bool big_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(big_integer_or_ratio_equivalent(sc, x, y, ci, false)); -} - - -static bool big_real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_RATIO: - mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_REAL: - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_COMPLEX: - mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); - if (!big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)) - return(false); - if (is_NaN(imag_part(y))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); - return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_BIG_REAL: - return(big_floats_are_equivalent(sc, big_real(x), big_real(y))); - case T_BIG_COMPLEX: - if (big_floats_are_equivalent(sc, big_real(x), mpc_realref(big_complex(y)))) - { - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); - }} - return(false); -} - -static bool big_complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - switch (type(y)) - { - case T_INTEGER: - mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_RATIO: - mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_REAL: - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_COMPLEX: - mpfr_set_d(sc->mpfr_1, imag_part(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_REAL: - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), big_real(y))) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_COMPLEX: - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), mpc_realref(big_complex(y)))) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), mpc_imagref(big_complex(y))))); - } - return(false); -} - -static bool both_floats_are_equivalent(s7_scheme *sc, s7_pointer y) -{ - if (!big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) - return(false); - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); -} -#endif - -static bool integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return(integer(x) == integer(y)); - case T_RATIO: - return(floats_are_equivalent(sc, (double)integer(x), fraction(y))); - case T_REAL: - return(floats_are_equivalent(sc, (double)integer(x), real(y))); - case T_COMPLEX: - return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, (double)integer(x), real_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - return(mpz_cmp_si(big_integer(y), integer(x)) == 0); - case T_BIG_RATIO: - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - return(both_floats_are_equivalent(sc, y)); -#endif - } - return(false); -} - -static bool fraction_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return(floats_are_equivalent(sc, (double)fraction(x), integer(y))); - case T_RATIO: - return(floats_are_equivalent(sc, (double)fraction(x), fraction(y))); - case T_REAL: - return(floats_are_equivalent(sc, (double)fraction(x), real(y))); - case T_COMPLEX: - return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, fraction(x), real_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, fraction(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); - return(both_floats_are_equivalent(sc, y)); -#endif - } - return(false); -} - -static bool real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return(floats_are_equivalent(sc, real(x), integer(y))); - case T_RATIO: - return(floats_are_equivalent(sc, real(x), fraction(y))); - case T_REAL: - return(floats_are_equivalent(sc, real(x), real(y))); - case T_COMPLEX: - return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, real(x), real_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(both_floats_are_equivalent(sc, y)); -#endif - } - return(false); -} - -static bool complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return((floats_are_equivalent(sc, real_part(x), integer(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_RATIO: - return((floats_are_equivalent(sc, real_part(x), fraction(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_REAL: - return((floats_are_equivalent(sc, real_part(x), real(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_COMPLEX: - return((floats_are_equivalent(sc, real_part(x), real_part(y))) && - (floats_are_equivalent(sc, imag_part(x), imag_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real_part(x), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_BIG_REAL: - mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, imag_part(x), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) && - (big_floats_are_equivalent(sc, sc->mpfr_2, mpc_imagref(big_complex(y))))); -#endif - } - return(false); -} - -static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ -#if WITH_GMP - return(x == y); -#else - return((x == y) || - ((is_random_state(y)) && - (random_seed(x) == random_seed(y)) && - (random_carry(x) == random_carry(y)))); -#endif -} - -static void init_equals(void) -{ - for (int32_t i = 0; i < NUM_TYPES; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;} - equals[T_SYMBOL] = eq_equal; - equals[T_C_POINTER] = c_pointer_equal; - equals[T_UNSPECIFIED] = unspecified_equal; - equals[T_UNDEFINED] = undefined_equal; - equals[T_STRING] = string_equal; - equals[T_SYNTAX] = syntax_equal; - equals[T_C_OBJECT] = c_objects_are_equal; - equals[T_RANDOM_STATE] = random_state_equal; - equals[T_ITERATOR] = iterator_equal; - equals[T_INPUT_PORT] = port_equal; - equals[T_OUTPUT_PORT] = port_equal; - equals[T_MACRO] = closure_equal; - equals[T_MACRO_STAR] = closure_equal; - equals[T_BACRO] = closure_equal; - equals[T_BACRO_STAR] = closure_equal; - equals[T_CLOSURE] = closure_equal; - equals[T_CLOSURE_STAR] = closure_equal; - equals[T_HASH_TABLE] = hash_table_equal; - equals[T_LET] = let_equal; - equals[T_PAIR] = pair_equal; - equals[T_VECTOR] = vector_equal; - equals[T_INT_VECTOR] = int_vector_equal; - equals[T_BYTE_VECTOR] = byte_vector_equal; - equals[T_FLOAT_VECTOR] = float_vector_equal; - equals[T_INTEGER] = integer_equal; - equals[T_RATIO] = fraction_equal; - equals[T_REAL] = real_equal; - equals[T_COMPLEX] = complex_equal; -#if WITH_GMP - equals[T_BIG_INTEGER] = big_integer_equal; - equals[T_BIG_RATIO] = big_ratio_equal; - equals[T_BIG_REAL] = big_real_equal; - equals[T_BIG_COMPLEX] = big_complex_equal; -#endif - equivalents[T_SYMBOL] = symbol_equivalent; - equivalents[T_C_POINTER] = c_pointer_equivalent; - equivalents[T_UNSPECIFIED] = unspecified_equal; - equivalents[T_UNDEFINED] = undefined_equal; - equivalents[T_STRING] = string_equal; - equivalents[T_SYNTAX] = syntax_equal; - equivalents[T_C_OBJECT] = c_objects_are_equivalent; - equivalents[T_RANDOM_STATE] = random_state_equal; - equivalents[T_ITERATOR] = iterator_equivalent; - equivalents[T_INPUT_PORT] = port_equivalent; - equivalents[T_OUTPUT_PORT] = port_equivalent; - equivalents[T_MACRO] = closure_equivalent; - equivalents[T_MACRO_STAR] = closure_equivalent; - equivalents[T_BACRO] = closure_equivalent; - equivalents[T_BACRO_STAR] = closure_equivalent; - equivalents[T_CLOSURE] = closure_equivalent; - equivalents[T_CLOSURE_STAR] = closure_equivalent; - equivalents[T_HASH_TABLE] = hash_table_equivalent; - equivalents[T_LET] = let_equivalent; - equivalents[T_PAIR] = pair_equivalent; - equivalents[T_VECTOR] = vector_equivalent; - equivalents[T_INT_VECTOR] = vector_equivalent; - equivalents[T_FLOAT_VECTOR] = vector_equivalent; - equivalents[T_BYTE_VECTOR] = vector_equivalent; - equivalents[T_INTEGER] = integer_equivalent; - equivalents[T_RATIO] = fraction_equivalent; - equivalents[T_REAL] = real_equivalent; - equivalents[T_COMPLEX] = complex_equivalent; -#if WITH_GMP - equivalents[T_BIG_INTEGER] = big_integer_equivalent; - equivalents[T_BIG_RATIO] = big_ratio_equivalent; - equivalents[T_BIG_REAL] = big_real_equivalent; - equivalents[T_BIG_COMPLEX] = big_complex_equivalent; -#endif -} - -bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equals[type(x)]))(sc, x, y, NULL));} -bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equivalents[type(x)]))(sc, x, y, NULL));} - -static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" - #define Q_is_equal sc->pcl_bt - return(make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL))); -} - -static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args) -{ - #define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." - #define Q_is_equivalent sc->pcl_bt - return(make_boolean(sc, is_equivalent_1(sc, car(args), cadr(args), NULL))); -} - -static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);} -static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);} - - -/* ---------------------------------------- length, copy, fill ---------------------------------------- */ -static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); /* why isn't this in s7.h? */ - -static s7_pointer (*length_functions[256])(s7_scheme *sc, s7_pointer obj); -static s7_pointer any_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);} - -static s7_pointer pair_length(s7_scheme *sc, s7_pointer a) -{ - s7_int i = 0; - s7_pointer slow = a, fast = a; /* we know a is a pair, don't start with fast = cdr(a)! else if a len = 3, we never match */ - while (true) - { - LOOP_4(fast = cdr(fast); i++; if (!is_pair(fast)) return(make_integer(sc, (is_null(fast)) ? i : -i))); - slow = cdr(slow); - if (fast == slow) return(real_infinity); - } - return(real_infinity); -} - -static s7_pointer nil_length(s7_scheme *sc, s7_pointer lst) {return(int_zero);} -static s7_pointer v_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, vector_length(v)));} -static s7_pointer str_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, string_length(v)));} -static s7_pointer bv_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, byte_vector_length(v)));} -static s7_pointer h_length(s7_scheme *sc, s7_pointer lst) {return(make_integer(sc, hash_table_mask(lst) + 1));} -static s7_pointer iter_length(s7_scheme *sc, s7_pointer lst) {return(s7_length(sc, iterator_sequence(lst)));} - -static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer lst) -{ - if (!is_global(sc->length_symbol)) - check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); - return(c_object_length(sc, lst)); -} - -static s7_pointer lt_length(s7_scheme *sc, s7_pointer lst) -{ - if (!is_global(sc->length_symbol)) - check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); - return(make_integer(sc, let_length(sc, lst))); -} - -static s7_pointer fnc_length(s7_scheme *sc, s7_pointer lst) -{ - return((has_active_methods(sc, lst)) ? make_integer(sc, closure_length(sc, lst)) : sc->F); -} - -static s7_pointer ip_length(s7_scheme *sc, s7_pointer port) -{ - if (port_is_closed(port)) - return(sc->F); /* or 0? */ - if (is_string_port(port)) - return(make_integer(sc, port_data_size(port))); /* length of string we're reading */ -#if (!MS_WINDOWS) - if (is_file_port(port)) - { - long len; - long cur_pos = ftell(port_file(port)); - fseek(port_file(port), 0, SEEK_END); - len = ftell(port_file(port)); - rewind(port_file(port)); - fseek(port_file(port), cur_pos, SEEK_SET); - return(make_integer(sc, len)); - } -#endif - return(sc->F); -} - -static s7_pointer op_length(s7_scheme *sc, s7_pointer port) -{ - if (port_is_closed(port)) - return(sc->F); /* or 0? */ - return((is_string_port(port)) ? make_integer(sc, port_position(port)) : sc->F); /* length of string we've written */ -} - -static s7_pointer rs_length(s7_scheme *sc, s7_pointer port) {return((WITH_GMP) ? sc->F : int_two);} - -static void init_length_functions(void) -{ - for (int32_t i = 0; i < 256; i++) length_functions[i] = any_length; - length_functions[T_NIL] = nil_length; - length_functions[T_PAIR] = pair_length; - length_functions[T_VECTOR] = v_length; - length_functions[T_FLOAT_VECTOR] = v_length; - length_functions[T_INT_VECTOR] = v_length; - length_functions[T_STRING] = str_length; - length_functions[T_BYTE_VECTOR] = bv_length; - length_functions[T_ITERATOR] = iter_length; - length_functions[T_HASH_TABLE] = h_length; - length_functions[T_C_OBJECT] = c_obj_length; - length_functions[T_LET] = lt_length; - length_functions[T_CLOSURE] = fnc_length; - length_functions[T_CLOSURE_STAR] = fnc_length; - length_functions[T_INPUT_PORT] = ip_length; - length_functions[T_OUTPUT_PORT] = op_length; - length_functions[T_RANDOM_STATE] = rs_length; -} - -static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst) {return((*length_functions[unchecked_type(lst)])(sc, lst));} - -static s7_pointer g_length(s7_scheme *sc, s7_pointer args) -{ - #define H_length "(length obj) returns the length of obj, which can be a list, vector, string, input-port, or hash-table. \ -The length of a dotted list does not include the final cdr, and is returned as a negative number. A circular \ -list has infinite length. Length of anything else returns #f." - #define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_infinite_symbol, sc->not_symbol), sc->T) - return((*length_functions[unchecked_type(car(args))])(sc, car(args))); -} - -/* length_p_p = s7_length */ - - -/* -------------------------------- copy -------------------------------- */ -static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val) -{ - if (is_character(val)) - { - string_value(str)[loc] = s7_character(val); - return(val); - } - set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25)); - set_caddr(sc->elist_3, val); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); - return(NULL); -} - -static s7_pointer string_getter(s7_scheme *sc, s7_pointer str, s7_int loc) -{ - return(chars[(uint8_t)(string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */ -} - -static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) -{ - return((*(c_object_set(sc, obj)))(sc, with_list_t3(obj, make_integer(sc, loc), val))); -} - -static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer obj, s7_int loc) -{ - return((*(c_object_ref(sc, obj)))(sc, set_plist_2(sc, obj, make_integer(sc, loc)))); -} - -static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val) -{ - /* loc is irrelevant here, val has to be of the form (cons symbol value) - * if symbol is already in e, its value is changed, otherwise a new slot is added to e - */ - if (is_pair(val)) - { - s7_pointer sym = car(val); - if (is_symbol(sym)) - { - s7_pointer slot; - if (is_keyword(sym)) sym = keyword_symbol(sym); /* else make_slot will mark the keyword as local confusing odd_bits etc */ - slot = slot_in_let(sc, e, sym); - if (is_slot(slot)) - checked_slot_set_value(sc, slot, cdr(val)); - else add_slot_checked_with_id(sc, e, sym, cdr(val)); - return(cdr(val)); - }} - set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons symbol value)", 33)); - set_caddr(sc->elist_3, val); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); - return(sc->wrong_type_arg_symbol); -} - -static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val) -{ - /* loc is irrelevant here, e is the hash-table, val has to be of the form (cons key value) - * if key is already in e, its value is changed, otherwise a new slot is added to e, cadr(elist_3) is caller - */ - if (!is_pair(val)) - { - set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons key value)", 30)); - set_caddr(sc->elist_3, val); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); - } - return(s7_hash_table_set(sc, e, car(val), cdr(val))); -} - - -static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer caller, s7_pointer source, s7_pointer args) -{ - s7_pointer dest; - switch (type(source)) - { - case T_STRING: - return(make_string_with_length(sc, string_value(source), string_length(source))); - - case T_C_OBJECT: - return(copy_c_object(sc, args)); - - case T_RANDOM_STATE: - return(random_state_copy(sc, args)); - - case T_HASH_TABLE: /* this has to copy nearly everything */ - { - s7_pointer new_hash = s7_make_hash_table(sc, hash_table_mask(source) + 1); - s7_int gc_loc = gc_protect_1(sc, new_hash); - hash_table_checker(new_hash) = hash_table_checker(source); - if (hash_chosen(source)) hash_set_chosen(new_hash); - hash_table_mapper(new_hash) = hash_table_mapper(source); - hash_table_set_procedures(new_hash, copy_hash_table_procedures(sc, source)); - hash_table_copy(sc, source, new_hash, 0, hash_table_entries(source)); - if (is_typed_hash_table(source)) - { - set_is_typed_hash_table(new_hash); - if (has_hash_key_type(source)) set_has_hash_key_type(new_hash); - if (has_hash_value_type(source)) set_has_hash_value_type(new_hash); - if (has_simple_keys(source)) set_has_simple_keys(new_hash); - if (has_simple_values(source)) set_has_simple_values(new_hash); - } - s7_gc_unprotect_at(sc, gc_loc); - return(new_hash); - } - - case T_ITERATOR: - return(iterator_copy(sc, source)); - - case T_LET: - check_method(sc, source, sc->copy_symbol, args); - return(let_copy(sc, source)); /* this copies only the local let and points to outer lets */ - - case T_CLOSURE: case T_CLOSURE_STAR: - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - check_method(sc, source, sc->copy_symbol, args); - return(copy_closure(sc, source)); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return(s7_vector_copy(sc, source)); /* "shallow" copy */ - - case T_VECTOR: - { - s7_int len = vector_length(source); - s7_pointer vec; - if (!is_typed_vector(source)) - return(s7_vector_copy(sc, source)); - if (len == 0) - return(make_simple_vector(sc, 0)); - vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR); - set_typed_vector(vec); - typed_vector_set_typer(vec, typed_vector_typer(source)); - if (has_simple_elements(source)) set_has_simple_elements(vec); - s7_vector_fill(sc, vec, vector_element(source, 0)); - if (vector_rank(source) > 1) - return(make_multivector(sc, vec, g_vector_dimensions(sc, set_plist_1(sc, source)))); /* see g_subvector to avoid g_vector_dimensions */ - add_vector(sc, vec); - return(vec); - } - - case T_PAIR: /* top level only, as in the other cases, checks for circles */ - return(copy_any_list(sc, source)); - - case T_INTEGER: - new_cell(sc, dest, T_INTEGER); - integer(dest) = integer(source); - return(dest); - case T_RATIO: - new_cell(sc, dest, T_RATIO); - numerator(dest) = numerator(source); - denominator(dest) = denominator(source); - return(dest); - case T_REAL: - new_cell(sc, dest, T_REAL); - set_real(dest, real(source)); - return(dest); - case T_COMPLEX: - new_cell(sc, dest, T_COMPLEX); - set_real_part(dest, real_part(source)); - set_imag_part(dest, imag_part(source)); - return(dest); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_to_big_integer(sc, big_integer(source))); - case T_BIG_RATIO: return(mpq_to_big_ratio(sc, big_ratio(source))); - case T_BIG_REAL: return(mpfr_to_big_real(sc, big_real(source))); - case T_BIG_COMPLEX: return(mpc_to_number(sc, big_complex(source))); -#endif - - case T_C_POINTER: - dest = s7_make_c_pointer_with_type(sc, c_pointer(source), c_pointer_type(source), c_pointer_info(source)); - c_pointer_weak1(dest) = c_pointer_weak1(source); - c_pointer_weak2(dest) = c_pointer_weak2(source); - return(dest); - } - return(source); -} - -static s7_pointer copy_p_p(s7_scheme *sc, s7_pointer source) {return(copy_source_no_dest(sc, sc->copy_symbol, source, set_plist_1(sc, source)));} - -static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int dest_start, s7_int dest_end, s7_int source_start) -{ - /* types equal, but not a let (handled in s7_copy_1), returns NULL if not copied here */ - s7_int i, j; - s7_int source_len = dest_end - dest_start; - switch (type(source)) - { - case T_PAIR: - { - s7_pointer pd, ps; - for (ps = source, i = 0; i < source_start; i++) - ps = cdr(ps); - for (pd = dest, i = 0; i < dest_start; i++) - pd = cdr(pd); - for (; (i < dest_end) && is_pair(ps) && is_pair(pd); i++, ps = cdr(ps), pd = cdr(pd)) - set_car(pd, car(ps)); - return(dest); - } - - case T_VECTOR: - if (is_typed_vector(dest)) - { - s7_pointer *els = vector_elements(source); - for (i = source_start, j = dest_start; j < dest_end; i++, j++) - typed_vector_setter(sc, dest, j, els[i]); /* types are equal, so source is a normal vector */ - } - else memcpy((void *)((vector_elements(dest)) + dest_start), (void *)((vector_elements(source)) + source_start), source_len * sizeof(s7_pointer)); - return(dest); - - case T_INT_VECTOR: - memcpy((void *)((int_vector_ints(dest)) + dest_start), (void *)((int_vector_ints(source)) + source_start), source_len * sizeof(s7_int)); - return(dest); - case T_FLOAT_VECTOR: - memcpy((void *)((float_vector_floats(dest)) + dest_start), (void *)((float_vector_floats(source)) + source_start), source_len * sizeof(s7_double)); - return(dest); - case T_BYTE_VECTOR: - if (is_string(dest)) - memcpy((void *)(string_value(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); - else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); - return(dest); - - case T_STRING: - if (is_string(dest)) - memcpy((void *)(string_value(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); - else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); - return(dest); - - case T_RANDOM_STATE: -#if (!WITH_GMP) - random_seed(dest) = random_seed(source); - random_carry(dest) = random_carry(source); -#endif - return(dest); - - case T_C_OBJECT: - { - s7_pointer (*cref)(s7_scheme *sc, s7_pointer args) = c_object_ref(sc, source); - s7_pointer (*cset)(s7_scheme *sc, s7_pointer args) = c_object_set(sc, dest); - s7_pointer mi = make_mutable_integer(sc, 0); - s7_int gc_loc1 = gc_protect_1(sc, mi); - s7_pointer mj = make_mutable_integer(sc, 0); - s7_int gc_loc2 = gc_protect_1(sc, mj); - - for (i = source_start, j = dest_start; i < dest_end; i++, j++) - { - integer(mi) = i; - integer(mj) = j; - set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); - set_car(sc->t3_1, dest); - set_car(sc->t3_2, mj); - cset(sc, sc->t3_1); - } - s7_gc_unprotect_at(sc, gc_loc1); - s7_gc_unprotect_at(sc, gc_loc2); - free_cell(sc, mi); - free_cell(sc, mj); - return(dest); - } - - case T_LET: - return(NULL); - - case T_HASH_TABLE: - { - s7_pointer p; - gc_protect_via_stack(sc, source); - p = hash_table_copy(sc, source, dest, source_start, source_start + source_len); - unstack(sc); - if ((hash_table_checker(source) != hash_table_checker(dest)) && - (hash_table_mapper(dest) == default_hash_map)) - { - if (hash_table_checker(dest) == hash_empty) - hash_table_checker(dest) = hash_table_checker(source); /* copy hash_table_procedures also? what about the mapper? see hash_table_copy */ - else - { - hash_table_checker(dest) = hash_equal; - hash_set_chosen(dest); - }} - return(p); - } - - default: - return(dest); - } - return(NULL); -} - -static noreturn void copy_element_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, int32_t desired_type) -{ - set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer(sc, num), element, type_name_string(sc, element), sc->type_names[desired_type]); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -static noreturn void copy_element_error_with_type_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, s7_pointer desired_type) -{ - set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer(sc, num), element, type_name_string(sc, element), desired_type); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - #define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end." - /* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */ - /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence, - * but it can provide a copy method. So, I think I'll just use #t - */ - #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol) - - s7_pointer source = car(args), dest; - s7_int i, j, dest_len, start, end, source_len; - s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) = NULL; - s7_pointer (*get)(s7_scheme *sc, s7_pointer obj, s7_int loc) = NULL; - bool have_indices; - - if (is_null(cdr(args))) /* (copy obj) */ - return(copy_source_no_dest(sc, caller, source, args)); - - dest = T_Ext(cadr(args)); - if ((dest == sc->readable_keyword) && (!is_pair(source))) - error_nr(sc, sc->out_of_range_symbol, - set_elist_1(sc, wrap_string(sc, "copy argument 2, :readable, only works if the source is a pair", 62))); - - if ((is_immutable(dest)) && - (dest != sc->readable_keyword) && - (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's currently NULL */ - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a mutable object", 16)); /* so this segfaults if not checking for :readable */ - - have_indices = (is_pair(cddr(args))); - if ((source == dest) && (!have_indices)) - return(dest); - - switch (type(source)) - { - case T_PAIR: - if (dest == sc->readable_keyword) /* a kludge, but I can't think of anything less stupid */ - { - if (have_indices) /* it seems to me that the start/end args here don't make any sense so... */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: start/end indices make no sense with :readable: ~S", 54), caller, args)); - return(copy_body(sc, source)); - } - end = s7_list_length(sc, source); - if (end == 0) - end = circular_list_entries(source); - else - if (end < 0) end = -end; - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - get = vector_getter(source); - end = vector_length(source); - break; - - case T_STRING: - get = string_getter; - end = string_length(source); - break; - - case T_HASH_TABLE: - if (source == dest) return(dest); - end = hash_table_entries(source); - break; - - case T_RANDOM_STATE: - get = random_state_getter; - end = 2; - break; - - case T_C_OBJECT: - if (c_object_copy(sc, source)) - { - s7_pointer x = (*(c_object_copy(sc, source)))(sc, args); - if (x == dest) - return(dest); - } - check_method(sc, source, sc->copy_symbol, args); - get = c_object_getter; - end = c_object_length_to_int(sc, source); - break; - - case T_LET: - if (source == dest) return(dest); - check_method(sc, source, sc->copy_symbol, args); - if (source == sc->rootlet) - wrong_type_error_nr(sc, caller, 1, source, wrap_string(sc, "a sequence other than the rootlet", 33)); - if ((!have_indices) && (is_let(dest)) && (dest != sc->s7_starlet)) - { - s7_pointer slot; - if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - s7_make_slot(sc, dest, slot_symbol(slot), slot_value(slot)); - else - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - /* this copies reversing the order -- if shadowing, this unshadows, tmp has in-order copy code, but it's too much effort */ - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - return(dest); - } - end = let_length(sc, source); - break; - - case T_NIL: - end = 0; - if (is_sequence(dest)) - break; - - default: - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); - } - - start = 0; - if (have_indices) - { - s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); - if (p != sc->unused) return(p); - } - if ((start == 0) && (source == dest)) - return(dest); - - source_len = end - start; - if (source_len == 0) - { - if (!is_sequence(dest)) - wrong_type_error_nr(sc, caller, 2, dest, a_sequence_string); - return(dest); - } - - switch (type(dest)) - { - case T_PAIR: - dest_len = source_len; - break; - - case T_INT_VECTOR: - case T_BYTE_VECTOR: - if (is_float_vector(source)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)])); - case T_FLOAT_VECTOR: - set = vector_setter(dest); - dest_len = vector_length(dest); - break; - - case T_VECTOR: - set = (is_typed_vector(dest)) ? typed_vector_setter : vector_setter(dest); - dest_len = vector_length(dest); - break; - - case T_STRING: - set = string_setter; - dest_len = string_length(dest); - set_cadr(sc->elist_3, caller); /* for possible error handling in string_setter */ - break; - - case T_HASH_TABLE: - set = hash_table_setter; - dest_len = source_len; - set_cadr(sc->elist_3, caller); /* for possible error handling in hash_table_setter */ - break; - - case T_C_OBJECT: - /* if source or dest is c_object, call its copy function before falling back on the get/set functions */ - if (c_object_copy(sc, dest)) - { - s7_pointer x = (*(c_object_copy(sc, dest)))(sc, args); - if (x == dest) - return(dest); - } - set = c_object_setter; - dest_len = c_object_length_to_int(sc, dest); - break; - - case T_LET: - if (dest == sc->rootlet) - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other rootlet", 24)); - if (dest == sc->s7_starlet) - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other than *s7*", 26)); - set = let_setter; - dest_len = source_len; /* grows via set, so dest_len isn't relevant */ - set_cadr(sc->elist_3, caller); /* for possible error handling in let_setter */ - break; - - case T_NIL: - return(sc->nil); - - case T_RANDOM_STATE: - set = random_state_setter; - dest_len = 2; - break; - - default: - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); - } - - if (dest_len == 0) - return(dest); - - /* end is source_len if not set explicitly */ - if (dest_len < source_len) - { - end = dest_len + start; - source_len = dest_len; - } - - if ((source != dest) && - ((type(source) == type(dest)) || - ((is_string_or_byte_vector(source)) && - (is_string_or_byte_vector(dest))))) - { - s7_pointer res = copy_to_same_type(sc, dest, source, 0, source_len, start); - if (res) return(res); - } - - switch (type(source)) - { - case T_PAIR: - { - s7_pointer p = source; - i = 0; - if (start > 0) - for (i = 0; i < start; i++) - p = cdr(p); - /* dest won't be a pair here if source != dest -- the pair->pair case was caught above */ - if (source == dest) /* here start != 0 (see above) */ - for (s7_pointer dp = source /* i = start */; i < end; i++, p = cdr(p), dp = cdr(dp)) - set_car(dp, car(p)); - else - if (is_string(dest)) - { - char *dst = string_value(dest); - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - { - if (!is_character(car(p))) - copy_element_error_nr(sc, caller, i + 1, car(p), T_CHARACTER); - dst[j] = character(car(p)); - }} - else - if ((is_normal_vector(dest)) && (set != typed_vector_setter)) - { - s7_pointer *els = vector_elements(dest); - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - els[j] = car(p); - } - else - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - set(sc, dest, j, car(p)); - return(dest); - } - - case T_LET: - if (source == sc->s7_starlet) /* *s7* */ - { - s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); - s7_int gc_loc = s7_gc_protect(sc, iter); - for (i = 0; i < start; i++) - { - s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) - { - s7_gc_unprotect_at(sc, gc_loc); - return(dest); - }} - if (is_pair(dest)) /* (append '(1) *s7* ()) */ - { - s7_pointer p; - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - { - s7_pointer val = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - set_car(p, val); - }} - else - for (i = start, j = 0; i < end; i++, j++) - { - s7_pointer val = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - set(sc, dest, j, val); - } - s7_gc_unprotect_at(sc, gc_loc); - } - else - { - /* source and dest can't be rootlet (checked above), dest also can't be *s7* */ - s7_pointer slot = let_slots(source); - for (i = 0; i < start; i++) slot = next_slot(slot); - if (is_pair(dest)) - { - s7_pointer p; - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) - set_car(p, cons_unchecked(sc, slot_symbol(slot), slot_value(slot))); - } - else - if (is_let(dest)) - { - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - for (i = start; i < end; i++, slot = next_slot(slot)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - if (is_hash_table(dest)) - for (i = start; i < end; i++, slot = next_slot(slot)) - s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); /* if value=#f, dest will not contain symbol */ - else - if ((is_normal_vector(dest)) && (set != typed_vector_setter)) - { - s7_pointer *els = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - els[j] = cons_unchecked(sc, slot_symbol(slot), slot_value(slot)); - } - else - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); - } - return(dest); - - case T_HASH_TABLE: - { - s7_int loc = -1, skip = start; - hash_entry_t **elements = hash_table_elements(source); - hash_entry_t *x = NULL; - - while (skip > 0) - { - while (!x) x = elements[++loc]; - skip--; - x = hash_entry_next(x); - } - if (is_pair(dest)) - { - s7_pointer p; - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - { - while (!x) x = elements[++loc]; - set_car(p, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }} - else - if (is_let(dest)) - { - for (i = start; i < end; i++) - { - s7_pointer symbol; - while (!x) x = elements[++loc]; - symbol = hash_entry_key(x); - if (!is_symbol(symbol)) - copy_element_error_nr(sc, caller, i + 1, symbol, T_SYMBOL); - if (is_constant_symbol(sc, symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A into ~A: ~A is a constant", 28), caller, dest, symbol)); - if ((symbol != sc->let_ref_fallback_symbol) && - (symbol != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, symbol, hash_entry_value(x)); /* ...unchecked... if size ok */ - x = hash_entry_next(x); - }} - else - { - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - { - while (!x) x = elements[++loc]; - set(sc, dest, j, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }} - return(dest); - } - - case T_VECTOR: - { - s7_pointer *vals = vector_elements(source); - if (is_float_vector(dest)) - { - s7_double *dst = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = real_to_double(sc, vals[i], symbol_name(caller)); - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *dst = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - { - if (!s7_is_integer(vals[i])) - copy_element_error_nr(sc, caller, i + 1, vals[i], T_INTEGER); - dst[j] = s7_integer_clamped_if_gmp(sc, vals[i]); - } - return(dest); - } - if (is_string(dest)) - { - char *dst = string_value(dest); - for (i = start, j = 0; i < end; i++, j++) - { - if (!is_character(vals[i])) - copy_element_error_nr(sc, caller, i + 1, vals[i], T_CHARACTER); - dst[j] = character(vals[i]); - } - return(dest); - } - if (is_byte_vector(dest)) - { - uint8_t *dst = (uint8_t *)byte_vector_bytes(dest); - for (i = start, j = 0; i < end; i++, j++) - { - s7_int byte; - if (!s7_is_integer(vals[i])) - copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); - byte = s7_integer_clamped_if_gmp(sc, vals[i]); - if ((byte >= 0) && (byte < 256)) - dst[j] = (uint8_t)byte; - else copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); - } - return(dest); - }} - break; - - case T_FLOAT_VECTOR: - { - s7_double *src = float_vector_floats(source); - /* int-vector destination can't normally work, fractional parts get rounded away */ - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = make_real_unchecked(sc, src[i]); - return(dest); - }} - break; - - case T_INT_VECTOR: - { - s7_int *src = int_vector_ints(source); - if (is_float_vector(dest)) - { - s7_double *dst = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = (s7_double)(src[i]); - return(dest); - } - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - /* this could check that the typer is integer? (similarly elsewhere): - * (typed_vector_typer(dest) != global_value(sc->is_integer_symbol)) ? - */ - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = make_integer_unchecked(sc, src[i]); - return(dest); - } - if (is_string(dest)) - { - for (i = start, j = 0; i < end; i++, j++) - { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); - string_value(dest)[j] = (uint8_t)(src[i]); - } - return(dest); - } - if (is_byte_vector(dest)) - { - for (i = start, j = 0; i < end; i++, j++) - { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); - byte_vector(dest, j) = (uint8_t)(src[i]); - } - return(dest); - }} - break; - - case T_BYTE_VECTOR: - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = small_int(byte_vector(source, i)); - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *els = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_int)((uint8_t)(byte_vector(source, i))); - return(dest); - } - if (is_float_vector(dest)) - { - s7_double *els = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_double)((uint8_t)(byte_vector(source, i))); - return(dest); - } - break; - - case T_STRING: - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = chars[(uint8_t)string_value(source)[i]]; - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *els = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_int)((uint8_t)(string_value(source)[i])); - return(dest); - } - if (is_float_vector(dest)) - { - s7_double *els = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_double)((uint8_t)(string_value(source)[i])); - return(dest); - } - break; - } - - if (is_pair(dest)) - { - s7_pointer p; - if (is_float_vector(source)) - { - s7_double *els = float_vector_floats(source); - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, make_real_unchecked(sc, els[i])); - } - else - if (is_int_vector(source)) - { - s7_int *els = int_vector_ints(source); - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, make_integer_unchecked(sc, els[i])); - } - else - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, get(sc, source, i)); - } - else /* if source == dest here, we're moving data backwards, so this is safe in either case */ - for (i = start, j = 0; i < end; i++, j++) - set(sc, dest, j, get(sc, source, i)); - /* some choices probably should raise an error, but don't: - * (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error - */ - return(dest); -} - -s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));} -#define g_copy s7_copy - - -/* -------------------------------- reverse -------------------------------- */ -s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) /* just pairs */ -{ - /* reverse list -- produce new list (other code assumes this function does not return the original!) */ - s7_pointer x, p; - - if (is_null(a)) return(a); - if (!is_pair(cdr(a))) - return((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */ - sc->w = list_1(sc, car(a)); - for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p)) - { - sc->w = cons(sc, car(x), sc->w); - if (is_pair(cdr(x))) - { - x = cdr(x); - sc->w = cons_unchecked(sc, car(x), sc->w); - } - if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ - break; - } - p = (is_null(x)) ? sc->w : cons(sc, x, sc->w); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ - sc->w = sc->unused; - return(p); -} - -/* s7_reverse sometimes tacks extra nodes on the end of a reversed circular list (it detects the cycle too late) - * (let ((lst (list 0))) (set! (cdr lst) lst) (reverse lst)) -> (#1=(0 . #1#) 0 0 0) - */ - -static s7_pointer reverse_p_p(s7_scheme *sc, s7_pointer p) -{ - s7_pointer np = sc->nil; - sc->temp3 = p; - switch (type(p)) - { - case T_NIL: - return(sc->nil); - - case T_PAIR: - return(s7_reverse(sc, p)); - - case T_STRING: - { - char *dest, *source = string_value(p); - s7_int len = string_length(p); - char *end = (char *)(source + len); - np = make_empty_string(sc, len, '\0'); - dest = (char *)(string_value(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_BYTE_VECTOR: - { - uint8_t *dest; - const uint8_t *source = byte_vector_bytes(p); - s7_int len = byte_vector_length(p); - const uint8_t *end = (const uint8_t *)(source + len); - np = make_simple_byte_vector(sc, len); - dest = (uint8_t *)(byte_vector_bytes(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_INT_VECTOR: - { - s7_int *dest, *source = int_vector_ints(p); - s7_int len = vector_length(p); - s7_int *end = (s7_int *)(source + len); - if (vector_rank(p) > 1) - np = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), int_zero), sc->make_int_vector_symbol); - else np = make_simple_int_vector(sc, len); - dest = (s7_int *)(int_vector_ints(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_FLOAT_VECTOR: - { - s7_double *dest, *source = float_vector_floats(p); - s7_int len = vector_length(p); - s7_double *end = (s7_double *)(source + len); - if (vector_rank(p) > 1) - np = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), real_zero), sc->make_float_vector_symbol); - else np = make_simple_float_vector(sc, len); - dest = (s7_double *)(float_vector_floats(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_VECTOR: - { - s7_pointer *dest, *source = vector_elements(p); - s7_int len = vector_length(p); - s7_pointer *end = (s7_pointer *)(source + len); - if (vector_rank(p) > 1) - np = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, p)))); - else np = make_simple_vector(sc, len); - dest = (s7_pointer *)(vector_elements(np) + len); - while (source < end) *(--dest) = *source++; - if (is_typed_vector(p)) - { - set_typed_vector(np); - typed_vector_set_typer(np, typed_vector_typer(p)); - if (has_simple_elements(p)) set_has_simple_elements(np); - }} - break; - - case T_HASH_TABLE: - return(hash_table_reverse(sc, p)); - - case T_C_OBJECT: - check_method(sc, p, sc->reverse_symbol, set_plist_1(sc, p)); - if (!c_object_reverse(sc, p)) - syntax_error_nr(sc, "attempt to reverse ~S?", 22, p); - return((*(c_object_reverse(sc, p)))(sc, set_plist_1(sc, p))); - - case T_LET: - check_method(sc, p, sc->reverse_symbol, set_plist_1(sc, p)); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't reverse let: ~S", 21), p)); - - default: - return(sole_arg_method_or_bust_p(sc, p, sc->reverse_symbol, a_sequence_string)); - } - return(np); -} - -static s7_pointer g_reverse(s7_scheme *sc, s7_pointer args) -{ - #define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order. reverse \ -also accepts a string or vector argument." - #define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol) - return(reverse_p_p(sc, car(args))); -} - -static s7_pointer any_list_reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list) -{ - s7_pointer p, result; - if (is_null(list)) return(term); - p = list; - result = term; - while (true) - { - s7_pointer q = cdr(p); - if (is_null(q)) - { - set_cdr(p, result); - return(p); - } - if ((is_pair(q)) && (!is_immutable_pair(q))) - { - set_cdr(p, result); - result = p; - p = q; - } - else return(sc->nil); /* improper or immutable */ - } - return(result); -} - -static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) -{ - #define H_reverse_in_place "(reverse! lst) reverses lst in place" - #define Q_reverse_in_place Q_reverse - - /* (reverse v) is only slighly faster than (reverse! (copy v)) */ - s7_pointer p = car(args); - switch (type(p)) - { - case T_NIL: - return(sc->nil); - - case T_PAIR: - if (is_immutable_pair(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_pointer np = any_list_reverse_in_place(sc, sc->nil, p); - if (is_null(np)) - wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable, proper list", 22)); - return(np); - } - /* (reverse! p) is supposed to change p directly and lisp programmers expect reverse! to be fast - * so in a sense this is different from the other cases: it assumes (set! p (reverse! p)) - * To make (reverse! p) direct: - * for (l = p, r = cdr(p); is_pair(r); l = r, r = cdr(r)) opt1(r) = l; - * if (!is_null(r)) sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_proper_list_string); - * for (r = l, l = p; l != r; l = cdr(l)) {t = car(l); set_car(l, car(r)); set_car(r, t); if (cdr(l) != r) r = opt1(r);} - * immutable check is needed else (reverse! (catch #t 1 cons)) clobbers sc->wrong_type_arg_info - */ - - case T_BYTE_VECTOR: - case T_STRING: - if (is_immutable(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len; - uint8_t *bytes; - if (is_string(p)) - { - len = string_length(p); - bytes = (uint8_t *)string_value(p); - } - else - { - len = byte_vector_length(p); - bytes = byte_vector_bytes(p); - } - if (len < 2) return(p); - -#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */ - /* this code (from StackOverflow with changes) is much faster: */ - #include - if ((len & 0x7f) == 0) - { - uint32_t *dst = (uint32_t *)(bytes + len - 4); - uint32_t *src = (uint32_t *)bytes; - while (src < dst) - { - uint32_t a, b; - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - }} - else - if ((len & 0x1f) == 0) /* 4-bytes at a time, 4 times per loop == 16 */ - { - uint32_t *dst = (uint32_t *)(bytes + len - 4); - uint32_t *src = (uint32_t *)bytes; - while (src < dst) - { - uint32_t a, b; - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - }} - else -#endif - { - char *s1 = (char *)bytes; - char *s2 = (char *)(s1 + len - 1); - while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;} - }} - break; - - case T_INT_VECTOR: - if (is_immutable_vector(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len = vector_length(p); - s7_int *s1 = int_vector_ints(p), *s2; - if (len < 2) return(p); - s2 = (s7_int *)(s1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (s1 < s2) - { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else - if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed (we're moving 2 at a time) */ - while (s1 < s2) - { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else while (s1 < s2) {s7_int c; c = *s1; *s1++ = *s2; *s2-- = c;} - } - break; - - case T_FLOAT_VECTOR: - if (is_immutable_vector(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len = vector_length(p); - s7_double *s1 = float_vector_floats(p), *s2; - if (len < 2) return(p); - s2 = (s7_double *)(s1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (s1 < s2) - { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else - if ((len & 0xf) == 0) - while (s1 < s2) - { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else while (s1 < s2) {s7_double c; c = *s1; *s1++ = *s2; *s2-- = c;} - } - break; - - case T_VECTOR: - if (is_immutable_vector(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len = vector_length(p); - s7_pointer *s1 = vector_elements(p), *s2; - if (len < 2) return(p); - s2 = (s7_pointer *)(s1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (s1 < s2) - { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else - if ((len & 0xf) == 0) - while (s1 < s2) - { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else while (s1 < s2) {s7_pointer c; c = *s1; *s1++ = *s2; *s2-- = c;} - } - break; - - default: - if (is_immutable(p)) - { - if (is_simple_sequence(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_sequence_string); - } - if ((is_simple_sequence(p)) && - (!has_active_methods(sc, p))) - sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, wrap_string(sc, "a vector, string, or list", 25)); - return(sole_arg_method_or_bust_p(sc, p, sc->reverseb_symbol, a_sequence_string)); - } - return(p); -} - - -/* -------------------------------- fill! -------------------------------- */ -static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) -{ - /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */ - s7_pointer obj = car(args), val; - s7_int i, start = 0, end, len; - -#if WITH_HISTORY - if ((is_immutable_pair(obj)) && (obj != sc->eval_history1) && (obj != sc->eval_history2)) -#else - if (is_immutable_pair(obj)) -#endif - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, obj)); - if (obj == global_value(sc->features_symbol)) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *features*", 22))); - if (obj == global_value(sc->libraries_symbol)) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *libraries*", 23))); - - val = cadr(args); - len = s7_list_length(sc, obj); - end = len; - if (end < 0) end = -end; else {if (end == 0) end = 123123123;} - if (!is_null(cddr(args))) - { - s7_pointer p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(val); - } - if (len > 0) - { - s7_pointer p; - if (end < len) len = end; - for (i = 0, p = obj; i < start; p = cdr(p), i++); - for (; i < len; p = cdr(p), i++) set_car(p, val); - return(val); - } - i = 0; - for (s7_pointer x = obj, y = obj; ; i++) - { - if ((end > 0) && (i >= end)) - return(val); - if (i >= start) set_car(x, val); - if (!is_pair(cdr(x))) - { - if (!is_null(cdr(x))) - set_cdr(x, val); - return(val); - } - x = cdr(x); - if ((i & 1) != 0) y = cdr(y); - if (x == y) - return(val); - } - return(val); -} - -s7_pointer s7_fill(s7_scheme *sc, s7_pointer args) -{ - #define H_fill "(fill! obj val (start 0) end) fills obj with val" - #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol) - - s7_pointer p = car(args); - switch (type(p)) - { - case T_STRING: return(g_string_fill_1(sc, sc->fill_symbol, args)); /* redundant type check here and below */ - case T_PAIR: return(pair_fill(sc, args)); - case T_HASH_TABLE: return(hash_table_fill(sc, args)); - case T_NIL: - if (!is_null(cddr(args))) /* (fill! () 1 21 #\a)? */ - syntax_error_nr(sc, "fill! () ... includes indices: ~S?", 34, cddr(args)); - return(cadr(args)); /* this parallels the empty vector case */ - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(g_vector_fill_1(sc, sc->fill_symbol, args)); - case T_LET: - check_method(sc, p, sc->fill_symbol, args); - return(let_fill(sc, args)); - case T_C_OBJECT: - check_method(sc, p, sc->fill_symbol, args); - if (!c_object_fill(sc, p)) /* default is NULL (s7_make_c_type) */ - syntax_error_nr(sc, "attempt to fill ~S?", 19, p); - return((*(c_object_fill(sc, p)))(sc, args)); - default: - check_method(sc, p, sc->fill_symbol, args); - } - wrong_type_error_nr(sc, sc->fill_symbol, 1, p, a_sequence_string); /* (fill! 1 0) */ - return(NULL); -} - -#define g_fill s7_fill - - -/* -------------------------------- append -------------------------------- */ -static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer caller, uint8_t typ) -{ - s7_pointer p = args; - s7_int len = 0; - - for (s7_int i = 1; is_pair(p); p = cdr(p), i++) - { - s7_pointer seq = car(p); - s7_int n = sequence_length(sc, seq); - if ((n > 0) && - (typ != T_FREE) && - ((type(seq) == T_HASH_TABLE) || /* can't append hash-tables (no obvious meaning to the operation) */ - ((type(seq) == T_LET) && /* similarly for lets, unless this is a mock-string or something similar */ - ((!has_active_methods(sc, seq)) || (find_method(sc, seq, caller) == sc->undefined))))) - { - wrong_type_error_nr(sc, caller, i, seq, sc->type_names[typ]); - return(0); - } - if (n < 0) - { - wrong_type_error_nr(sc, caller, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string); - return(0); - } - len += n; - } - return(len); -} - -static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller) -{ - s7_pointer new_vec, p, pargs, vtyper = NULL; - s7_pointer *v_elements = NULL; - s7_double *fv_elements = NULL; - s7_int *iv_elements = NULL; - uint8_t *byte_elements = NULL; - s7_int i, len; - bool typed; - - s7_gc_protect_via_stack(sc, args); - len = total_sequence_length(sc, args, caller, (typ == T_VECTOR) ? T_FREE : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER)); - if (len > sc->max_vector_length) - { - unstack(sc); - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D", 70), - caller, - wrap_integer(sc, len), - wrap_integer(sc, sc->max_vector_length))); - } - new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here (??) */ - typed = (typ == T_VECTOR); - set_stack_protected2(sc, new_vec); - add_vector(sc, new_vec); - if (len == 0) - { - unstack(sc); - return(new_vec); - } - if (typ == T_VECTOR) - v_elements = vector_elements(new_vec); - else - if (typ == T_FLOAT_VECTOR) - fv_elements = float_vector_floats(new_vec); - else - if (typ == T_INT_VECTOR) - iv_elements = int_vector_ints(new_vec); - else byte_elements = byte_vector_bytes(new_vec); - - pargs = list_2(sc, sc->F, new_vec); /* car set below */ - /* push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs); */ - set_stack_protected3(sc, pargs); - for (i = 0, p = args; is_pair(p); p = cdr(p)) /* in-place copy by goofing with new_vec's elements pointer */ - { - s7_pointer x = car(p); - s7_int n = sequence_length(sc, x); - if (n > 0) - { - if ((typed) && (is_normal_vector(x)) && (is_typed_vector(x))) - { - if (!vtyper) - vtyper = typed_vector_typer(x); - else - if (vtyper != typed_vector_typer(x)) - typed = false; - } - else typed = false; - vector_length(new_vec) = n; - set_car(pargs, x); - s7_copy_1(sc, caller, pargs); /* not set_plist_2 here! */ - vector_length(new_vec) = 0; /* so GC doesn't march off the end */ - i += n; - if (typ == T_VECTOR) - vector_elements(new_vec) = (s7_pointer *)(v_elements + i); - else - if (typ == T_FLOAT_VECTOR) - float_vector_floats(new_vec) = (s7_double *)(fv_elements + i); - else - if (typ == T_INT_VECTOR) - int_vector_ints(new_vec) = (s7_int *)(iv_elements + i); - else byte_vector_bytes(new_vec) = (uint8_t *)(byte_elements + i); - }} - /* unstack(sc); */ /* free_cell(sc, pargs); */ /* this is trouble if any arg is openlet with append method -- e.g. block */ - - if (typ == T_VECTOR) - vector_elements(new_vec) = v_elements; - else - if (typ == T_FLOAT_VECTOR) - float_vector_floats(new_vec) = fv_elements; - else - if (typ == T_INT_VECTOR) - int_vector_ints(new_vec) = iv_elements; - else byte_vector_bytes(new_vec) = byte_elements; - vector_length(new_vec) = len; - if ((typed) && (vtyper)) - { - set_typed_vector(new_vec); - typed_vector_set_typer(new_vec, vtyper); - } - unstack(sc); - return(new_vec); -} - -static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args) -{ - s7_pointer new_hash, key_typer = NULL, value_typer = NULL; - bool typed = true; - s7_gc_protect_via_stack(sc, args); - check_stack_size(sc); - new_hash = s7_make_hash_table(sc, sc->default_hash_table_length); - set_stack_protected2(sc, new_hash); - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer seq = car(p); - if (!sequence_is_empty(sc, seq)) - { - s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_hash)); - if ((typed) && (is_hash_table(seq)) && (is_typed_hash_table(seq))) - { - if (!key_typer) - { /* the equality/mapping procedures are either partly implicit or in hash-table-procedures -- a bit of a mess currently */ - key_typer = hash_table_key_typer(seq); - value_typer = hash_table_value_typer(seq); - } - else - if ((hash_table_key_typer(seq) != key_typer) || - (hash_table_value_typer(seq) != value_typer)) - typed = false; - } - else typed = false; - }} - if ((typed) && (key_typer)) - { - hash_table_set_procedures(new_hash, make_hash_table_procedures(sc)); - set_is_typed_hash_table(new_hash); - hash_table_set_key_typer(new_hash, key_typer); - hash_table_set_value_typer(new_hash, value_typer); - } - set_plist_2(sc, sc->nil, sc->nil); - unstack(sc); - return(new_hash); -} - -static s7_pointer let_append(s7_scheme *sc, s7_pointer args) -{ - s7_pointer new_let, e = car(args); - check_method(sc, e, sc->append_symbol, args); - s7_gc_protect_via_stack(sc, args); - new_let = make_let(sc, sc->nil); - set_stack_protected2(sc, new_let); - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - if (!sequence_is_empty(sc, car(p))) - s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let)); - set_plist_2(sc, sc->nil, sc->nil); - unstack(sc); - return(new_let); -} - -static s7_pointer g_append(s7_scheme *sc, s7_pointer args) -{ - #define H_append "(append ...) returns its argument sequences appended into one sequence" - #define Q_append s7_make_circular_signature(sc, 0, 1, sc->T) - - if (is_null(args)) return(sc->nil); /* (append) -> () */ - if (is_null(cdr(args))) return(car(args)); /* (append ) -> */ - sc->value = args; - args = copy_proper_list(sc, args); /* copied since other args might invoke methods */ - sc->value = args; - switch (type(car(args))) - { - case T_NIL: return(g_list_append(sc, cdr(args))); - case T_PAIR: return(g_list_append(sc, args)); - case T_STRING: return(g_string_append_1(sc, args, sc->append_symbol)); - /* should this work in the generic append: (append "12" #\3) -- currently an error, (append (list 1 2) 3) -> '(1 2 . 3), but vector is error */ - case T_HASH_TABLE: return(hash_table_append(sc, args)); - case T_LET: return(let_append(sc, args)); - case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return(vector_append(sc, args, type(car(args)), sc->append_symbol)); - default: check_method(sc, car(args), sc->append_symbol, args); - } - wrong_type_error_nr(sc, sc->append_symbol, 1, car(args), a_sequence_string); /* (append 1 0) */ - return(NULL); -} - -static s7_pointer append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(g_append(sc, set_plist_3(sc, p1, p2, p3)));} - -s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - if (is_pair(a)) - { - s7_pointer q, p, np, op; - if ((!is_pair(b)) && (!is_null(b))) - return(g_list_append(sc, list_2(sc, a, b))); - q = list_1(sc, car(a)); - sc->temp8 = q; - for (op = a, p = cdr(a), np = q; (is_pair(p)) && (p != op); p = cdr(p), np = cdr(np), op = cdr(op)) - { - set_cdr(np, list_1_unchecked(sc, car(p))); p = cdr(p); np = cdr(np); - if (!is_pair(p)) break; - set_cdr(np, list_1(sc, car(p))); - } - if (!is_null(p)) - wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string); - set_cdr(np, b); - sc->temp8 = sc->unused; - return(q); - } - if (is_null(a)) return(b); - return(g_append(sc, set_plist_2(sc, a, b))); -} - -static s7_pointer g_append_2(s7_scheme *sc, s7_pointer args) {return(s7_append(sc, car(args), cadr(args)));} - -static s7_pointer append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 2) return(sc->append_2); - return(f); -} - - -/* -------------------------------- object->let -------------------------------- */ -static s7_pointer byte_vector_to_list(s7_scheme *sc, const uint8_t *str, s7_int len) -{ - s7_pointer p; - if (len == 0) return(sc->nil); - check_free_heap_size(sc, len); - sc->w = sc->nil; - for (s7_int i = len - 1; i >= 0; i--) - sc->w = cons_unchecked(sc, small_int((uint32_t)(str[i])), sc->w); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer hash_table_to_list(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer x, iterator; - if (hash_table_entries(obj) <= 0) return(sc->nil); - iterator = s7_make_iterator(sc, obj); - gc_protect_via_stack(sc, iterator); - sc->w = sc->nil; - while (true) - { - x = s7_iterate(sc, iterator); - if (iterator_is_at_end(iterator)) break; - sc->w = cons(sc, x, sc->w); - } - x = sc->w; - sc->w = sc->unused; - unstack(sc); - return(x); -} - -static s7_pointer iterator_to_list(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result = sc->nil, p = NULL; - s7_int results = 0; - while (true) - { - s7_pointer val = s7_iterate(sc, obj); - if ((val == ITERATOR_END) && - (iterator_is_at_end(obj))) - { - if (is_pair(result)) unstack(sc); - return(result); - } - if (sc->safety > NO_SAFETY) - { - results++; - if (results > 10000) - { - s7_warn(sc, 256, "iterator is creating a very long list!\n"); - results = S7_INT32_MIN; - }} - if (val != sc->no_value) - { - if (is_null(result)) - { - if (is_multiple_value(val)) - { - result = multiple_value(val); - clear_multiple_value(val); - for (p = result; is_pair(cdr(p)); p = cdr(p)); - } - else - { - result = list_1(sc, val); - p = result; - } - gc_protect_via_stack(sc, result); /* unstacked above */ - } - else - if (is_multiple_value(val)) - { - set_cdr(p, multiple_value(val)); - clear_multiple_value(val); - for (; is_pair(cdr(p)); p = cdr(p)); - } - else - { - set_cdr(p, list_1(sc, val)); - p = cdr(p); - }}} -} - -static s7_pointer c_obj_to_list(s7_scheme *sc, s7_pointer obj) /* "c_object_to_list" is the ->list method mentioned below */ -{ - int64_t len; - s7_pointer x, z, zc, result; - s7_int gc_z; - - if (c_object_to_list(sc, obj)) - return((*(c_object_to_list(sc, obj)))(sc, set_plist_1(sc, obj))); - - x = c_object_length(sc, obj); - if (!s7_is_integer(x)) return(sc->F); - len = s7_integer_clamped_if_gmp(sc, x); - if (len < 0) - return(sc->F); - if (len == 0) - return(sc->nil); - - result = make_list(sc, len, sc->nil); - sc->temp7 = result; - zc = make_mutable_integer(sc, 0); - z = list_2_unchecked(sc, obj, zc); - gc_z = gc_protect_1(sc, z); - x = result; - for (int64_t i = 0; i < len; i++, x = cdr(x)) /* used to save/restore sc->x|z here */ - { - integer(zc) = i; - set_car(x, (*(c_object_ref(sc, obj)))(sc, z)); - } - s7_gc_unprotect_at(sc, gc_z); - sc->temp7 = sc->unused; - return(result); -} - -static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in format_to_port_1 and (map values ...) */ -{ - switch (type(obj)) - { - case T_STRING: return(string_to_list(sc, string_value(obj), string_length(obj))); - case T_BYTE_VECTOR: return(byte_vector_to_list(sc, byte_vector_bytes(obj), byte_vector_length(obj))); - case T_HASH_TABLE: return(hash_table_to_list(sc, obj)); - case T_ITERATOR: return(iterator_to_list(sc, obj)); - case T_C_OBJECT: return(c_obj_to_list(sc, obj)); - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(s7_vector_to_list(sc, obj)); - case T_LET: -#if (!WITH_PURE_S7) - check_method(sc, obj, sc->let_to_list_symbol, set_plist_1(sc, obj)); -#endif - return(s7_let_to_list(sc, obj)); - } - return(obj); -} - - -/* ---------------- object->let ---------------- */ -static s7_pointer symbol_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, obj, - sc->type_symbol, (is_keyword(obj)) ? sc->is_keyword_symbol : - ((is_gensym(obj)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); - if (!is_keyword(obj)) - { - s7_int gc_loc = gc_protect_1(sc, let); - s7_pointer val = s7_symbol_value(sc, obj); - if (!sc->current_value_symbol) - sc->current_value_symbol = make_symbol(sc, "current-value", 13); - s7_varlet(sc, let, sc->current_value_symbol, val); - s7_varlet(sc, let, sc->setter_symbol, setter_p_pp(sc, obj, sc->curlet)); - s7_varlet(sc, let, sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_symbol(obj))); - if (!is_undefined(val)) - { - const char *doc = s7_documentation(sc, obj); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - } - s7_gc_unprotect_at(sc, gc_loc); - } - return(let); -} - -static s7_pointer random_state_to_let(s7_scheme *sc, s7_pointer obj) -{ -#if WITH_GMP - return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_random_state_symbol)); -#else - if (!sc->seed_symbol) - { - sc->seed_symbol = make_symbol(sc, "seed", 4); - sc->carry_symbol = make_symbol(sc, "carry", 5); - } - return(internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_random_state_symbol, - sc->seed_symbol, make_integer(sc, random_seed(obj)), - sc->carry_symbol, make_integer(sc, random_carry(obj)))); -#endif -} - -static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let; - s7_int gc_loc; - - if (!sc->dimensions_symbol) sc->dimensions_symbol = make_symbol(sc, "dimensions", 10); - if (!sc->original_vector_symbol) sc->original_vector_symbol = make_symbol(sc, "original-vector", 15); - let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, (is_subvector(obj)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(obj))) : s7_type_of(sc, obj), - sc->size_symbol, s7_length(sc, obj), - sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, obj)), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_vector(obj))); - gc_loc = gc_protect_1(sc, let); - if (is_subvector(obj)) - { - s7_int pos = 0; - switch (type(obj)) /* correct type matters here: gcc 10.2 with -O2 segfaults otherwise, cast to intptr_t has a similar role in earlier gcc's */ - { - case T_VECTOR: pos = (s7_int)((intptr_t)(vector_elements(obj) - vector_elements(subvector_vector(obj)))); break; - case T_INT_VECTOR: pos = (s7_int)((intptr_t)(int_vector_ints(obj) - int_vector_ints(subvector_vector(obj)))); break; - case T_FLOAT_VECTOR: pos = (s7_int)((intptr_t)(float_vector_floats(obj) - float_vector_floats(subvector_vector(obj)))); break; - case T_BYTE_VECTOR: pos = (s7_int)((intptr_t)(byte_vector_bytes(obj) - byte_vector_bytes(subvector_vector(obj)))); break; - } - s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); - s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(obj)); - } - if (is_typed_vector(obj)) - s7_varlet(sc, let, sc->signature_symbol, g_signature(sc, set_plist_1(sc, obj))); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer obj) -{ - if ((hash_table_checker(obj) == hash_eq) || - (hash_table_checker(obj) == hash_c_function) || - (hash_table_checker(obj) == hash_closure) || - (hash_table_checker(obj) == hash_equal_eq) || - (hash_table_checker(obj) == hash_equal_syntax) || - (hash_table_checker(obj) == hash_symbol)) - s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol); - else - if (hash_table_checker(obj) == hash_eqv) - s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol); - else - if ((hash_table_checker(obj) == hash_equal) || - (hash_table_checker(obj) == hash_empty)) - s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); - else - if (hash_table_checker(obj) == hash_equivalent) - s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); - else - if ((hash_table_checker(obj) == hash_number_num_eq) || - (hash_table_checker(obj) == hash_int) || - (hash_table_checker(obj) == hash_float)) - s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); - else - if (hash_table_checker(obj) == hash_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); - else - if (hash_table_checker(obj) == hash_char) - s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); -#if (!WITH_PURE_S7) - else - if (hash_table_checker(obj) == hash_ci_char) - s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); - else - if (hash_table_checker(obj) == hash_ci_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); -#endif -} - -static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let; - s7_int gc_loc; - if (!sc->entries_symbol) - { - sc->entries_symbol = make_symbol(sc, "entries", 7); - sc->weak_symbol = make_symbol(sc, "weak", 4); - } - let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_hash_table_symbol, - sc->size_symbol, s7_length(sc, obj), - sc->entries_symbol, make_integer(sc, hash_table_entries(obj)), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = gc_protect_1(sc, let); - if (is_weak_hash_table(obj)) - s7_varlet(sc, let, sc->weak_symbol, sc->T); - - if (is_typed_hash_table(obj)) - { - s7_pointer checker = hash_table_procedures_checker(obj); - if (checker == sc->T) /* perhaps typed because typers were set, but not checker/mapper */ - hash_table_checker_to_let(sc, let, obj); - else s7_varlet(sc, let, sc->function_symbol, list_2(sc, checker, hash_table_procedures_mapper(obj))); - s7_varlet(sc, let, sc->signature_symbol, - (is_typed_hash_table(obj)) ? - list_3(sc, - hash_table_typer_symbol(sc, hash_table_value_typer(obj)), - sc->is_hash_table_symbol, - hash_table_typer_symbol(sc, hash_table_key_typer(obj))) : - sc->hash_table_signature); - } - else hash_table_checker_to_let(sc, let, obj); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let, seq = iterator_sequence(obj); - s7_int gc_loc; - if (!sc->at_end_symbol) - { - sc->at_end_symbol = make_symbol(sc, "at-end", 6); - sc->sequence_symbol = make_symbol(sc, "sequence", 8); - } - let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_iterator_symbol, - sc->at_end_symbol, s7_make_boolean(sc, iterator_is_at_end(obj)), - sc->sequence_symbol, iterator_sequence(obj)); - gc_loc = gc_protect_1(sc, let); - if (is_pair(seq)) - s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq)); - else - if (is_hash_table(seq)) - s7_varlet(sc, let, sc->size_symbol, make_integer(sc, hash_table_entries(seq))); - else s7_varlet(sc, let, sc->size_symbol, s7_length(sc, obj)); - if ((is_string(seq)) || - (is_any_vector(seq)) || - (seq == sc->rootlet) || - (is_c_object(seq)) || - (is_hash_table(seq))) - s7_varlet(sc, let, sc->position_symbol, make_integer(sc, iterator_position(obj))); - else - if (is_pair(seq)) - s7_varlet(sc, let, sc->position_symbol, iterator_current(obj)); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj) -{ - /* how to handle setters? - * (display (let ((e (let ((i 0)) (set! (setter 'i) integer?) (curlet)))) (object->let e))): - * "(inlet 'value (inlet 'i 0) 'type let? 'length 1 'open #f 'outlet () 'immutable? #f)" - */ - s7_pointer let; - s7_int gc_loc; - if (!sc->open_symbol) - { - sc->open_symbol = make_symbol(sc, "open", 4); - sc->alias_symbol = make_symbol(sc, "alias", 5); - } - let = internal_inlet(sc, 12, sc->value_symbol, obj, - sc->type_symbol, sc->is_let_symbol, - sc->size_symbol, s7_length(sc, obj), - sc->open_symbol, s7_make_boolean(sc, is_openlet(obj)), - sc->outlet_symbol, (obj == sc->rootlet) ? sc->nil : let_outlet(obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = gc_protect_1(sc, let); - if (obj == sc->rootlet) - s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol); - else - if (obj == sc->owlet) /* this can't happen, I think -- owlet is always copied first */ - s7_varlet(sc, let, sc->alias_symbol, sc->owlet_symbol); - else - if (is_funclet(obj)) - { - s7_varlet(sc, let, sc->function_symbol, funclet_function(obj)); - if ((has_let_file(obj)) && - (let_file(obj) <= (s7_int)sc->file_names_top) && - (let_line(obj) > 0) && - (let_line(obj) < 1000000)) - { - s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(obj)]); - s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(obj))); - }} - else - if (obj == sc->s7_starlet) - { - s7_pointer iter = s7_make_iterator(sc, obj); - s7_int gc_loc1 = s7_gc_protect(sc, iter); - while (true) - { - s7_pointer x = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - s7_varlet(sc, let, car(x), cdr(x)); - } - s7_gc_unprotect_at(sc, gc_loc1); - } - if (has_active_methods(sc, obj)) - { - s7_pointer func = find_method(sc, obj, sc->object_to_let_symbol); - if (func != sc->undefined) - s7_apply_function(sc, func, set_plist_2(sc, obj, let)); - } - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let, clet = c_object_let(obj); - if (!sc->class_symbol) - { - sc->class_symbol = make_symbol(sc, "class", 5); - sc->c_object_let_symbol = make_symbol(sc, "c-object-let", 12); - } - let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_c_object_symbol, - sc->c_object_type_symbol, make_integer(sc, c_object_type(obj)), - sc->c_object_let_symbol, clet, - sc->class_symbol, c_object_type_to_let(sc, obj)); - if ((is_let(clet)) && - ((has_active_methods(sc, clet)) || (has_active_methods(sc, obj)))) - { - s7_int gc_loc = gc_protect_1(sc, let); - s7_pointer func = find_method(sc, clet, sc->object_to_let_symbol); - if (func != sc->undefined) - s7_apply_function(sc, func, set_plist_2(sc, obj, let)); - s7_gc_unprotect_at(sc, gc_loc); - } - return(let); -} - -static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underbars! */ -{ - s7_pointer let; - s7_int gc_loc; - if (!sc->data_symbol) - { - sc->data_symbol = make_symbol(sc, "data", 4); - sc->port_type_symbol = make_symbol(sc, "port-type", 9); - sc->closed_symbol = make_symbol(sc, "closed", 6); - sc->file_info_symbol = make_symbol(sc, "file-info", 9); - } - let = internal_inlet(sc, 10, sc->value_symbol, obj, - /* obj as 'value means it will say "(closed)" when subsequently the let is displayed */ - sc->type_symbol, (is_input_port(obj)) ? sc->is_input_port_symbol : sc->is_output_port_symbol, - sc->port_type_symbol, (is_string_port(obj)) ? sc->string_symbol : ((is_file_port(obj)) ? sc->file_symbol : sc->function_symbol), - sc->closed_symbol, s7_make_boolean(sc, port_is_closed(obj)), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_port(obj))); - gc_loc = gc_protect_1(sc, let); - if (is_file_port(obj)) - { - s7_varlet(sc, let, sc->file_symbol, g_port_filename(sc, set_plist_1(sc, obj))); - if (is_input_port(obj)) - s7_varlet(sc, let, sc->line_symbol, g_port_line_number(sc, set_plist_1(sc, obj))); -#if (!MS_WINDOWS) - if ((!port_is_closed(obj)) && (obj != sc->standard_error) && (obj != sc->standard_input) && (obj != sc->standard_output)) - { - struct stat sb; - s7_varlet(sc, let, sc->file_symbol, make_integer(sc, fileno(port_file(obj)))); - if (fstat(fileno(port_file(obj)), &sb) != -1) - { - char c1[64], c2[64], str[512]; - int32_t bytes; - strftime(c1, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_atime)); - strftime(c2, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_mtime)); - bytes = snprintf(str, 512, "mode: #o%u, links: %ld, owner uid: %d gid: %d, size: %ld bytes, last file access: %s, last file modification: %s", - sb.st_mode, - (long)sb.st_nlink, - (int)sb.st_uid, (int)sb.st_gid, - (long)sb.st_size, - c1, c2); - s7_varlet(sc, let, sc->file_info_symbol, make_string_with_length(sc, (const char *)str, bytes)); - }} -#endif - } - if ((is_string_port(obj)) && /* file port might not have a data buffer */ - (port_data(obj)) && - (port_data_size(obj) > 0)) - { - s7_varlet(sc, let, sc->size_symbol, make_integer(sc, port_data_size(obj))); - s7_varlet(sc, let, sc->position_symbol, make_integer(sc, port_position(obj))); - /* I think port_data need not be null-terminated, but s7_make_string assumes it is: - * both valgrind and lib*san complain about the uninitialized data during strlen. - */ - s7_varlet(sc, let, sc->data_symbol, - make_string_with_length(sc, (const char *)port_data(obj), ((port_position(obj)) > 16) ? 16 : port_position(obj))); - } - if (is_function_port(obj)) - s7_varlet(sc, let, sc->function_symbol, port_string_or_function(obj)); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer obj) -{ - const char *doc = s7_documentation(sc, obj); - s7_pointer sig = s7_signature(sc, obj); - s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity(sc, obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - s7_int gc_loc = gc_protect_1(sc, let); - - if (is_pair(sig)) - s7_varlet(sc, let, sc->local_signature_symbol, sig); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - - if (is_let(closure_let(obj))) - { - s7_pointer flet = closure_let(obj); - if ((has_let_file(flet)) && - (let_file(flet) <= (s7_int)sc->file_names_top) && - (let_line(flet) > 0)) - { - s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(flet)]); - s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(flet))); - }} - - if (closure_setter(obj) != sc->F) - s7_varlet(sc, let, sc->local_setter_symbol, closure_setter(obj)); - - if (!sc->source_symbol) - sc->source_symbol = make_symbol(sc, "source", 6); - s7_varlet(sc, let, sc->source_symbol, - append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(obj)), closure_args(obj)), - closure_body(obj))); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer c_pointer_to_let(s7_scheme *sc, s7_pointer obj) -{ - /* c_pointer_info can be a let and might have an object->let method (see c_object below) */ - if (!sc->c_type_symbol) - { - sc->c_type_symbol = make_symbol(sc, "c-type", 6); - sc->info_symbol = make_symbol(sc, "info", 4); - } - if (!sc->pointer_symbol) sc->pointer_symbol = make_symbol(sc, "pointer", 7); - return(internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_c_pointer_symbol, - sc->pointer_symbol, make_integer(sc, (s7_int)((intptr_t)c_pointer(obj))), - sc->c_type_symbol, c_pointer_type(obj), - sc->info_symbol, c_pointer_info(obj))); -} - -static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer obj) -{ - const char *doc = s7_documentation(sc, obj); - s7_pointer sig = c_function_signature(obj); - s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity(sc, obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - s7_int gc_loc = gc_protect_1(sc, let); - - if (is_pair(sig)) - s7_varlet(sc, let, sc->local_signature_symbol, sig); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - - if (c_function_setter(obj) != sc->F) /* c_macro_setter is the same underlying field */ - s7_varlet(sc, let, sc->local_setter_symbol, c_function_setter(obj)); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer goto_to_let(s7_scheme *sc, s7_pointer obj) -{ - /* there's room in s7_cell to store the procedure, but we would have to mark it (goto escapes, context GC'd) */ - if (!sc->active_symbol) - { - sc->active_symbol = make_symbol(sc, "active", 6); - sc->goto_symbol = make_symbol(sc, "goto?", 5); - } - if (is_symbol(call_exit_name(obj))) - return(internal_inlet(sc, 8, sc->value_symbol, obj, sc->type_symbol, sc->goto_symbol, - sc->active_symbol, s7_make_boolean(sc, call_exit_active(obj)), - sc->name_symbol, call_exit_name(obj))); - return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->goto_symbol, - sc->active_symbol, s7_make_boolean(sc, call_exit_active(obj)))); -} - -static s7_pointer object_to_let_p_p(s7_scheme *sc, s7_pointer obj) -{ - switch (type(obj)) - { - case T_NIL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_null_symbol)); - case T_UNSPECIFIED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_unspecified_symbol)); - case T_UNDEFINED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_undefined_symbol)); - case T_EOF: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_eof_object_symbol)); - case T_BOOLEAN: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_boolean_symbol)); - case T_CHARACTER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_char_symbol)); - case T_SYMBOL: return(symbol_to_let(sc, obj)); - case T_RANDOM_STATE: return(random_state_to_let(sc, obj)); - case T_GOTO: return(goto_to_let(sc, obj)); - case T_C_POINTER: return(c_pointer_to_let(sc, obj)); - case T_ITERATOR: return(iterator_to_let(sc, obj)); - case T_HASH_TABLE: return(hash_table_to_let(sc, obj)); - case T_LET: return(let_to_let(sc, obj)); - case T_C_OBJECT: return(c_object_to_let(sc, obj)); - - case T_INTEGER: case T_BIG_INTEGER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol)); - case T_RATIO: case T_BIG_RATIO: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol)); - case T_REAL: case T_BIG_REAL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol)); - case T_COMPLEX: case T_BIG_COMPLEX: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol)); - - case T_STRING: - return(internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_string_symbol, - sc->size_symbol, str_length(sc, obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_string(obj)))); - case T_PAIR: - return(internal_inlet(sc, 6, sc->value_symbol, obj, - sc->type_symbol, sc->is_pair_symbol, - sc->size_symbol, pair_length(sc, obj))); - case T_SYNTAX: - return(internal_inlet(sc, 6, sc->value_symbol, obj, - sc->type_symbol, sc->is_syntax_symbol, - sc->documentation_symbol, s7_make_string(sc, syntax_documentation(obj)))); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_VECTOR: - return(vector_to_let(sc, obj)); - - case T_CONTINUATION: /* perhaps include the continuation-key */ - if (is_symbol(continuation_name(obj))) - return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol, sc->name_symbol, continuation_name(obj))); - return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol)); - - case T_INPUT_PORT: case T_OUTPUT_PORT: - return(port_to_let(sc, obj)); - - case T_CLOSURE: case T_CLOSURE_STAR: case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR: - return(closure_to_let(sc, obj)); - - case T_C_MACRO: case T_C_FUNCTION_STAR: - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: - return(c_function_to_let(sc, obj)); - - default: - return(sc->F); - } - return(sc->F); -} - -static s7_pointer g_object_to_let(s7_scheme *sc, s7_pointer args) -{ - #define H_object_to_let "(object->let obj) returns a let (namespace) describing obj." - #define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T) - return(object_to_let_p_p(sc, car(args))); -} - - -/* ---------------- stacktrace ---------------- */ -static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer e) -{ - if ((is_let(e)) && (e != sc->rootlet)) - return(((is_funclet(e)) || (is_maclet(e))) ? funclet_function(e) : stacktrace_find_caller(sc, let_outlet(e))); - return(sc->F); -} - -static bool stacktrace_find_let(s7_scheme *sc, int64_t loc, s7_pointer e) -{ - return((loc > 0) && - ((stack_let(sc->stack, loc) == e) || - (stacktrace_find_let(sc, loc - 4, e)))); -} - -static int64_t stacktrace_find_error_hook_quit(s7_scheme *sc) -{ - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - if (stack_op(sc->stack, i) == OP_ERROR_HOOK_QUIT) - return(i); - return(-1); -} - -static bool stacktrace_in_error_handler(s7_scheme *sc, int64_t loc) -{ - return((let_outlet(sc->owlet) == sc->curlet) || - (stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) || - (stacktrace_find_error_hook_quit(sc) > 0)); -} - -static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer f = s7_symbol_value(sc, sym); - return((is_procedure(f)) && - (hook_has_functions(sc->error_hook)) && - (direct_memq(f, s7_hook_functions(sc, sc->error_hook)))); - } - return(false); -} - -static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e, char *notes, - s7_int code_cols, s7_int total_cols, s7_int notes_start_col, - bool as_comment, int32_t depth) -{ - if (is_symbol(code)) - { - if ((!symbol_is_in_list(sc, code)) && - (!is_slot(global_slot(code)))) - { - s7_pointer val; - add_symbol_to_list(sc, code); - val = s7_symbol_local_value(sc, code, e); - if ((val) && - (val != sc->undefined) && - (!is_any_macro(val))) - { - int32_t typ = type(val); - if (typ < T_CONTINUATION) - { - char *objstr, *str; - s7_pointer objp; - s7_int new_note_len, notes_max; - bool new_notes_line = false, old_short_print = sc->short_print; - s7_int old_len = sc->print_length, objlen; - - if (notes_start_col < 0) notes_start_col = 50; - if (notes_start_col > total_cols) notes_start_col = 0; - notes_max = total_cols - notes_start_col; - sc->short_print = true; - if (sc->print_length > 4) sc->print_length = 4; - objp = s7_object_to_string(sc, val, true); - objstr = string_value(objp); - objlen = string_length(objp); - if ((objlen > notes_max) && - (notes_max > 5)) - { - objstr[notes_max - 4] = '.'; - objstr[notes_max - 3] = '.'; - objstr[notes_max - 2] = '.'; - objstr[notes_max - 1] = '\0'; - objlen = notes_max; - } - sc->short_print = old_short_print; - sc->print_length = old_len; - - new_note_len = symbol_name_length(code) + 3 + objlen; - /* we want to append this much info to the notes, but does it need a new line? */ - if (notes_start_col < code_cols) - new_notes_line = true; - else - if (notes) - { - char *last_newline = strrchr(notes, (int)'\n'); /* returns ptr to end if none = nil if not found? */ - s7_int cur_line_len = (last_newline) ? (strlen(notes) - strlen(last_newline)) : strlen(notes); - new_notes_line = ((cur_line_len + new_note_len) > notes_max); - } - if (new_notes_line) - { - const char *spaces = " "; - s7_int spaces_len = 80; - new_note_len += (4 + notes_start_col + ((notes) ? strlen(notes) : 0)); - str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ - catstrs_direct(str, - (notes) ? notes : "", - "\n", - (as_comment) ? "; " : "", - (spaces_len >= notes_start_col) ? (char *)(spaces + spaces_len - notes_start_col) : "", - (as_comment) ? "" : " ; ", - symbol_name(code), - ": ", - objstr, (const char *)NULL); - } - else - { - new_note_len += ((notes) ? strlen(notes) : 0) + 4; - str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ - catstrs_direct(str, - (notes) ? notes : "", - (notes) ? ", " : " ; ", - symbol_name(code), - ": ", - objstr, (const char *)NULL); - } - if (notes) free(notes); - return(str); - }}} - return(notes); - } - if ((is_pair(code)) && - (s7_list_length(sc, code) > 0) && - (depth < 32)) - { - notes = stacktrace_walker(sc, car(code), e, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 1); - return(stacktrace_walker(sc, cdr(code), e, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 2)); - } - return(notes); -} - -static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code, const char *errstr, char *notes, s7_int code_max, bool as_comment) -{ - s7_int newlen, errlen = strlen(errstr); - char *newstr, *str; - block_t *newp, *b; - if ((is_symbol(f)) && - (f != car(code))) - { - newlen = symbol_name_length(f) + errlen + 10; - newp = mallocate(sc, newlen); - newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */ - errlen = catstrs_direct(newstr, symbol_name(f), ": ", errstr, (const char *)NULL); - } - else - { - newlen = errlen + 8; - newp = mallocate(sc, newlen); - newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */ - if ((errlen > 2) && (errstr[2] == '(')) - errlen = catstrs_direct(newstr, " ", errstr, (const char *)NULL); - else - { - memcpy((void *)newstr, (void *)errstr, errlen); - newstr[errlen] = '\0'; - }} - newlen = code_max + 8 + ((notes) ? strlen(notes) : 0); - b = mallocate(sc, newlen); - str = (char *)block_data(b); /* str[0] = '\0'; */ - - if (errlen >= code_max) - { - newstr[code_max - 4] = '.'; - newstr[code_max - 3] = '.'; - newstr[code_max - 2] = '.'; - newstr[code_max - 1] = '\0'; - catstrs_direct(str, (as_comment) ? "; " : "", newstr, (notes) ? notes : "", "\n", (const char *)NULL); - } - else - { - /* send out newstr, pad with spaces to code_max, then notes */ - s7_int len = catstrs_direct(str, (as_comment) ? "; " : "", newstr, (const char *)NULL); - if (notes) - { - s7_int i; - for (i = len; i < code_max - 1; i++) str[i] = ' '; - str[i] = '\0'; - catstrs(str, newlen, notes, "\n", (char *)NULL); - } - else catstrs(str, newlen, "\n", (char *)NULL); - } - liberate(sc, newp); - return(b); -} - -static s7_pointer stacktrace_1(s7_scheme *sc, s7_int frames_max, s7_int code_cols, s7_int total_cols, s7_int notes_start_col, bool as_comment) -{ - char *str = NULL; - block_t *strp = NULL; - int64_t loc, frames = 0; - int64_t top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not current_stack_top! */ - clear_symbol_list(sc); - - if (stacktrace_in_error_handler(sc, top)) - { - s7_pointer err_code = slot_value(sc->error_code); - if ((is_pair(err_code)) && - (!tree_is_cyclic(sc, err_code))) - { - char *notes = NULL; - s7_pointer current_let = let_outlet(sc->owlet); - s7_pointer errstr = s7_object_to_string(sc, err_code, false); - s7_pointer f = stacktrace_find_caller(sc, current_let); /* this is a symbol */ - if ((is_let(current_let)) && - (current_let != sc->rootlet)) - notes = stacktrace_walker(sc, err_code, current_let, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); - strp = stacktrace_add_func(sc, f, err_code, string_value(errstr), notes, code_cols, as_comment); - str = (char *)block_data(strp); - } - loc = stacktrace_find_error_hook_quit(sc); /* if OP_ERROR_HOOK_QUIT is in the stack, jump past it! */ - if (loc > 0) top = (loc + 1) / 4; - } - for (loc = top - 1; loc > 0; loc--) - { - s7_int true_loc = (loc + 1) * 4 - 1; - s7_pointer code = stack_code(sc->stack, true_loc); - if ((is_pair(code)) && - (!tree_is_cyclic(sc, code))) - { - s7_pointer codep = s7_object_to_string(sc, code, false); - if (string_length(codep) > 0) - { - char *codestr = string_value(codep); - if ((!local_strcmp(codestr, "(result)")) && - (!local_strcmp(codestr, "(#f)")) && - (!strstr(codestr, "(stacktrace)")) && - (!strstr(codestr, "(stacktrace "))) - { - s7_pointer e = stack_let(sc->stack, true_loc); - s7_pointer f = stacktrace_find_caller(sc, e); - if (!stacktrace_error_hook_function(sc, f)) - { - char *notes = NULL, *newstr, *catstr; - block_t *newp, *catp; - s7_int newlen; - - frames++; - if (frames > frames_max) - return(block_to_string(sc, strp, safe_strlen((char *)block_data(strp)))); - - if ((is_let(e)) && (e != sc->rootlet)) - notes = stacktrace_walker(sc, code, e, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); - newp = stacktrace_add_func(sc, f, code, codestr, notes, code_cols, as_comment); - newstr = (char *)block_data(newp); - - if ((notes) && (notes != newstr) && (is_let(e)) && (e != sc->rootlet)) - free(notes); - - newlen = strlen(newstr) + 1 + ((str) ? strlen(str) : 0); - catp = mallocate(sc, newlen); - catstr = (char *)block_data(catp); - catstrs_direct(catstr, (str) ? str : "", newstr, (const char *)NULL); - liberate(sc, newp); - if (strp) liberate(sc, strp); - strp = catp; - str = (char *)block_data(strp); - }}}}} - return((strp) ? block_to_string(sc, strp, safe_strlen((char *)block_data(strp))) : nil_string); -} - -s7_pointer s7_stacktrace(s7_scheme *sc) -{ - return(stacktrace_1(sc, - s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)), - s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)))); -} - -static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args) -{ - #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \ -a stacktrace as a string. Each line has two portions, the code being evaluated and a note giving \ -the value of local variables in that code. The first argument sets how many lines are displayed. \ -The next three arguments set the length and layout of those lines. 'as-comment' if #t causes each \ -line to be preceded by a semicolon." - #define Q_stacktrace s7_make_signature(sc, 6, \ - sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, \ - sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol) - - s7_int max_frames = 30, code_cols = 50, total_cols = 80, notes_start_col = 50; - bool as_comment = false; - - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - return(method_or_bust(sc, car(args), sc->stacktrace_symbol, args, sc->type_names[T_INTEGER], 1)); - max_frames = s7_integer_clamped_if_gmp(sc, car(args)); - if ((max_frames <= 0) || (max_frames > S7_INT32_MAX)) - max_frames = 30; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 2, car(args), sc->type_names[T_INTEGER]); - code_cols = s7_integer_clamped_if_gmp(sc, car(args)); - if ((code_cols <= 8) || (code_cols > 1024)) - code_cols = 50; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 3, car(args), sc->type_names[T_INTEGER]); - total_cols = s7_integer_clamped_if_gmp(sc, car(args)); - if ((total_cols <= code_cols) || (total_cols > S7_INT32_MAX)) - total_cols = 80; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 4, car(args), sc->type_names[T_INTEGER]); - notes_start_col = s7_integer_clamped_if_gmp(sc, car(args)); - if ((notes_start_col <= 0) || (notes_start_col > S7_INT32_MAX)) - notes_start_col = 50; - args = cdr(args); - if (!is_null(args)) - { - if (!is_boolean(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 5, car(args), sc->type_names[T_BOOLEAN]); - as_comment = s7_boolean(sc, car(args)); - }}}}} - return(stacktrace_1(sc, max_frames, code_cols, total_cols, notes_start_col, as_comment)); -} - - -/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ - -s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry) -{ -#if WITH_HISTORY - set_current_code(sc, entry); -#endif - return(entry); -} - -s7_pointer s7_history(s7_scheme *sc) -{ -#if WITH_HISTORY - if (sc->cur_code == sc->history_sink) - return(sc->old_cur_code); -#endif - return(sc->cur_code); -} - -bool s7_history_enabled(s7_scheme *sc) -{ -#if WITH_HISTORY - return(sc->cur_code != sc->history_sink); -#else - return(false); -#endif -} - -bool s7_set_history_enabled(s7_scheme *sc, bool enabled) -{ -#if WITH_HISTORY - bool old_enabled = (sc->cur_code == sc->history_sink); - if (enabled) /* this needs to restore the old cur_code (saving its position in the history_buffer) */ - sc->cur_code = sc->old_cur_code; - else - if (sc->cur_code != sc->history_sink) - { - sc->old_cur_code = sc->cur_code; - sc->cur_code = sc->history_sink; - } - return(old_enabled); -#else - return(false); -#endif -} - -#if WITH_HISTORY -static s7_pointer history_cons(s7_scheme *sc, s7_pointer code, s7_pointer args) -{ - s7_pointer p = car(sc->history_pairs); - sc->history_pairs = cdr(sc->history_pairs); - set_car(p, code); - set_cdr(p, args); - return(p); -} -#else -#define history_cons(Sc, Code, Args) Code -#endif - - -/* -------------------------------- profile -------------------------------- */ -static void swap_stack(s7_scheme *sc, opcode_t new_op, s7_pointer new_code, s7_pointer new_args) -{ - s7_pointer code, args, e; - opcode_t op; - - sc->stack_end -= 4; - code = sc->stack_end[0]; - e = sc->stack_end[1]; - args = sc->stack_end[2]; - op = (opcode_t)(sc->stack_end[3]); /* this should be begin1 */ - if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) - fprintf(stderr, "swap %s in %s\n", op_names[op], display(s7_name_to_value(sc, "estr"))); - push_stack(sc, new_op, new_args, new_code); - sc->stack_end[0] = code; - sc->stack_end[1] = e; - sc->stack_end[2] = args; - sc->stack_end[3] = (s7_pointer)op; - sc->stack_end += 4; -} - -static s7_pointer find_funclet(s7_scheme *sc, s7_pointer e) -{ - if ((e == sc->rootlet) || (!is_let(e))) return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) e = let_outlet(e); - if ((e == sc->rootlet) || (!is_let(e))) return(sc->F); - return(((is_funclet(e)) || (is_maclet(e))) ? e : sc->F); -} - -#define PD_INITIAL_SIZE 16 -enum {PD_CALLS = 0, PD_RECUR, PD_START, PD_ITOTAL, PD_ETOTAL, PD_BLOCK_SIZE}; - -static s7_pointer g_profile_out(s7_scheme *sc, s7_pointer args) -{ - s7_int pos = integer(car(args)) * PD_BLOCK_SIZE; - profile_data_t *pd = sc->profile_data; - s7_int *v = (s7_int *)(pd->timing_data + pos); - v[PD_RECUR]--; - if (v[PD_RECUR] == 0) - { - s7_int cur_time = (my_clock() - v[PD_START]); - v[PD_ITOTAL] += cur_time; - v[PD_ETOTAL] += (cur_time - pd->excl[pd->excl_top]); - pd->excl_top--; - pd->excl[pd->excl_top] += cur_time; - } - return(sc->F); -} - -static s7_pointer g_profile_in(s7_scheme *sc, s7_pointer args) /* only external func -- added to each profiled func by add_profile above */ -{ - #define H_profile_in "(profile-in e) is the profiler's hook into closures" - #define Q_profile_in s7_make_signature(sc, 3, sc->T, sc->is_integer_symbol, sc->is_let_symbol) - - s7_pointer e; - s7_int pos; - if (sc->profile == 0) return(sc-> F); - - pos = integer(car(args)); - e = find_funclet(sc, cadr(args)); - - if ((is_let(e)) && - (is_symbol(funclet_function(e)))) - { - s7_pointer func_name = funclet_function(e); - s7_int *v; - profile_data_t *pd = sc->profile_data; - - if (pos >= pd->size) - { - s7_int new_size = 2 * pos; - pd->funcs = (s7_pointer *)Realloc(pd->funcs, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->funcs + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->timing_data = (s7_int *)Realloc(pd->timing_data, new_size * PD_BLOCK_SIZE * sizeof(s7_int)); - memclr((void *)(pd->timing_data + (pd->size * PD_BLOCK_SIZE)), (new_size - pd->size) * PD_BLOCK_SIZE * sizeof(s7_int)); - pd->let_names = (s7_pointer *)Realloc(pd->let_names, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->let_names + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->files = (s7_pointer *)Realloc(pd->files, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->files + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->lines = (s7_int *)Realloc(pd->lines, new_size * sizeof(s7_int)); - memclr((void *)(pd->lines + pd->size), (new_size - pd->size) * sizeof(s7_int)); - pd->size = new_size; - } - if (pd->funcs[pos] == NULL) - { - pd->funcs[pos] = func_name; - if (is_gensym(func_name)) sc->profiling_gensyms = true; - if (pos >= pd->top) pd->top = (pos + 1); - - /* perhaps add_profile needs to reuse ints if file/line exists? */ - if (is_symbol(sc->profile_prefix)) - { - s7_pointer let_name = s7_symbol_local_value(sc, sc->profile_prefix, e); - if (is_symbol(let_name)) pd->let_names[pos] = let_name; - } - if (has_let_file(e)) - { - pd->files[pos] = sc->file_names[let_file(e)]; - pd->lines[pos] = let_line(e); - }} - v = (s7_int *)(sc->profile_data->timing_data + (pos * PD_BLOCK_SIZE)); - v[PD_CALLS]++; - if (v[PD_RECUR] == 0) - { - v[PD_START] = my_clock(); - pd->excl_top++; - if (pd->excl_top == pd->excl_size) - { - pd->excl_size *= 2; - pd->excl = (s7_int *)Realloc(pd->excl, pd->excl_size * sizeof(s7_int)); - } - pd->excl[pd->excl_top] = 0; - } - v[PD_RECUR]++; - - /* this doesn't work in "continuation passing" code (e.g. cpstak.scm in the so-called standard benchmarks). - * swap_stack pushes dynamic_unwind, but we don't pop back to it, so the stack grows to the recursion depth. - */ - if (sc->stack_end >= sc->stack_resize_trigger) - { - #define PROFILE_MAX_STACK_SIZE 10000000 /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */ - if (sc->stack_size > PROFILE_MAX_STACK_SIZE) - error_nr(sc, make_symbol(sc, "stack-too-big", 13), - set_elist_2(sc, wrap_string(sc, "profiling stack size has grown past ~D", 38), wrap_integer(sc, PROFILE_MAX_STACK_SIZE))); - /* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is - * a very rare problem, and the results will be confusing anyway. - */ - resize_stack(sc); - } - swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out, car(args)); - } - return(sc->F); -} - -static s7_pointer profile_info_out(s7_scheme *sc) -{ - s7_pointer p, pp, vs, vi, vn, vf, vl, matches; - s7_int i; - profile_data_t *pd = sc->profile_data; - if ((!pd) || (pd->top == 0)) return(sc->F); - p = make_list(sc, 7, sc->F); - sc->w = p; - set_car(p, vs = make_simple_vector(sc, pd->top)); - set_car(cdr(p), vi = make_simple_int_vector(sc, pd->top * PD_BLOCK_SIZE)); - set_car(cddr(p), make_integer(sc, ticks_per_second())); - pp = cdddr(p); - set_car(pp, vn = make_simple_vector(sc, pd->top)); - set_car(cdr(pp), vf = make_simple_vector(sc, pd->top)); - set_car(cddr(pp), vl = make_simple_int_vector(sc, pd->top)); - matches = cdddr(pp); - set_car(matches, sc->nil); - for (i = 0; i < pd->top; i++) - { - if (pd->funcs[i]) - { - vector_element(vs, i) = pd->funcs[i]; - if ((is_matched_symbol(pd->funcs[i])) && /* find ambiguous names */ - (!direct_memq(pd->funcs[i], car(matches)))) - set_car(matches, cons(sc, pd->funcs[i], car(matches))); - set_match_symbol(pd->funcs[i]); - } - else vector_element(vs, i) = sc->F; - vector_element(vn, i) = (!pd->let_names[i]) ? sc->F : pd->let_names[i]; - vector_element(vf, i) = (!pd->files[i]) ? sc->F : pd->files[i]; - } - for (i = 0; i < pd->top; i++) if (pd->funcs[i]) clear_match_symbol(pd->funcs[i]); - memcpy((void *)int_vector_ints(vl), (void *)pd->lines, pd->top * sizeof(s7_int)); - memcpy((void *)int_vector_ints(vi), (void *)pd->timing_data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); - sc->w = sc->unused; - return(p); -} - -static s7_pointer clear_profile_info(s7_scheme *sc) -{ - if (sc->profile_data) - { - profile_data_t *pd = sc->profile_data; - memclr(pd->timing_data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); - memclr(pd->funcs, pd->top * sizeof(s7_pointer)); - memclr(pd->let_names, pd->top * sizeof(s7_pointer)); - memclr(pd->files, pd->top * sizeof(s7_pointer)); - memclr(pd->lines, pd->top * sizeof(s7_int)); - pd->top = 0; - for (int32_t i = 0; i < pd->excl_top; i++) - pd->excl[i] = 0; - pd->excl_top = 0; - sc->profiling_gensyms = false; - } - return(sc->F); -} - -static s7_pointer make_profile_info(s7_scheme *sc) -{ - if (!sc->profile_data) - { - profile_data_t *pd = (profile_data_t *)Malloc(sizeof(profile_data_t)); - pd->size = PD_INITIAL_SIZE; - pd->excl_size = PD_INITIAL_SIZE; - pd->top = 0; - pd->excl_top = 0; - pd->funcs = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); - pd->let_names = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); - pd->files = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); - pd->lines = (s7_int *)Calloc(pd->size, sizeof(s7_int)); - pd->excl = (s7_int *)Calloc(pd->excl_size, sizeof(s7_int)); - pd->timing_data = (s7_int *)Calloc(pd->size * PD_BLOCK_SIZE, sizeof(s7_int)); - sc->profile_data = pd; - } - return(sc->F); -} - - -/* -------------------------------- dynamic-unwind -------------------------------- */ -static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e) -{ - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) - fprintf(stderr, "%s[%d]: unexpected multiple-value! %s %s %s\n", __func__, __LINE__, display(func), display(e), display(sc->value)); - return(s7_apply_function(sc, func, set_plist_2(sc, e, sc->value))); /* s7_apply_function returns sc->value */ -} - -static s7_pointer g_dynamic_unwind(s7_scheme *sc, s7_pointer args) -{ - #define H_dynamic_unwind "(dynamic-unwind func arg) pushes func and arg on the stack, then (func arg) is called when the stack unwinds." - #define Q_dynamic_unwind s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T) - - s7_pointer func = car(args); - if (((is_closure(func)) && (closure_arity_to_int(sc, func) == 2)) || - ((is_c_function(func)) && (c_function_is_aritable(func, 2))) || - ((is_closure_star(func)) && (closure_star_arity_to_int(sc, func) == 2)) || - ((is_c_function_star(func)) && (c_function_max_args(func) == 2))) - swap_stack(sc, OP_DYNAMIC_UNWIND, func, cadr(args)); - else wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 1, func, wrap_string(sc, "a procedure of two arguments", 28)); - return(cadr(args)); -} - - -/* -------------------------------- catch -------------------------------- */ -static s7_pointer g_catch(s7_scheme *sc, s7_pointer args) -{ - #define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called" - #define Q_catch s7_make_signature(sc, 4, sc->values_symbol, \ - s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), \ - sc->is_procedure_symbol, sc->is_procedure_symbol) - s7_pointer p, proc = cadr(args), err = caddr(args); - - /* Guile sets up the catch before looking for arg errors: (catch #t log (lambda args "hiho")) -> "hiho" - * which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...) - * but what if the error handler arg is messed up? Seems weird to handle args in reverse order with an intervening let etc. - */ - /* if (is_let(err)) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */ - - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]\n", __func__, __LINE__); - new_cell(sc, p, T_CATCH); - catch_tag(p) = car(args); - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack); - catch_set_handler(p, err); - catch_cstack(p) = sc->goto_start; - push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, p); - - /* not sure about these error checks -- they can be omitted */ - if (!is_thunk(sc, proc)) - wrong_type_error_nr(sc, sc->catch_symbol, 2, proc, a_thunk_string); - if (!is_applicable(err)) - wrong_type_error_nr(sc, sc->catch_symbol, 3, err, something_applicable_string); - - /* should we check here for (aritable? err 2)? (catch #t (lambda () 1) "hiho") -> 1 - * currently this is checked only if the error handler is called - */ - if (is_closure(proc)) /* not also lambda* here because we need to handle the arg defaults */ - { - /* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=() - * the case that caught this: (catch #t make-hook ...) - */ - sc->code = closure_body(proc); - if (is_symbol(closure_args(proc))) - sc->curlet = make_let_with_slot(sc, closure_let(proc), closure_args(proc), sc->nil); - else sc->curlet = inline_make_let(sc, closure_let(proc)); - push_stack_no_args_direct(sc, sc->begin_op); - } - else push_stack(sc, OP_APPLY, sc->nil, proc); - return(sc->F); -} - -s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler) -{ - s7_pointer p, result; - if (sc->stack_end == sc->stack_start) /* no stack! */ - push_stack_direct(sc, OP_EVAL_DONE); - - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]\n", __func__, __LINE__); - new_cell(sc, p, T_CATCH); - catch_tag(p) = tag; - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack); - catch_set_handler(p, error_handler); - catch_cstack(p) = sc->goto_start; - - if (!sc->longjmp_ok) - { - declare_jump_info(); - TRACK(sc); - store_jump_info(sc); - set_jump_info(sc, S7_CALL_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ - (sc->stack_end == sc->stack_start)) - push_stack_op(sc, OP_ERROR_QUIT); - result = sc->value; - } - else - { - /* we've replaced our jump point, fix it in this catch too */ - catch_cstack(p) = &new_goto_start; - push_stack(sc, OP_CATCH, error_handler, p); - result = s7_call(sc, body, sc->nil); - if (((opcode_t)sc->stack_end[-1]) == OP_CATCH) sc->stack_end -= 4; - } - restore_jump_info(sc); - } - else - { - push_stack(sc, OP_CATCH, error_handler, p); - result = s7_call(sc, body, sc->nil); - if (((opcode_t)sc->stack_end[-1]) == OP_CATCH) sc->stack_end -= 4; - } - return(result); -} - -static void op_c_catch(s7_scheme *sc) -{ - /* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args)) - * code is (catch #t (lambda () ....) (lambda args ....)) - */ - s7_pointer p, f = cadr(sc->code), args = cddr(sc->code), tag; - - /* defer making the error lambda */ - if (!is_pair(f)) /* (catch #t ...) or (catch sym ...) */ - tag = (is_symbol(f)) ? lookup_checked(sc, f) : f; - else tag = cadr(f); /* (catch 'sym ...) */ - - new_cell(sc, p, T_CATCH); /* the catch object sitting on the stack */ - catch_tag(p) = tag; - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = sc->op_stack_now - sc->op_stack; - catch_set_handler(p, cdadr(args)); /* not yet a closure... */ - catch_cstack(p) = sc->goto_start; - push_stack(sc, OP_CATCH_1, sc->code, p); /* code ignored here, except by GC */ - sc->curlet = inline_make_let(sc, sc->curlet); - sc->code = T_Pair(cddar(args)); -} - -static void op_c_catch_all(s7_scheme *sc) -{ - s7_pointer p; - new_cell(sc, p, T_CATCH); - catch_tag(p) = sc->T; - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = sc->op_stack_now - sc->op_stack; - catch_set_handler(p, sc->nil); - catch_cstack(p) = sc->goto_start; - push_stack(sc, OP_CATCH_ALL, opt2_con(sc->code), p); /* push_stack: op args code */ - sc->code = T_Pair(opt1_pair(cdr(sc->code))); /* the body of the first lambda (or car of it if catch_all_o) */ -} - -static void op_c_catch_all_a(s7_scheme *sc) -{ - op_c_catch_all(sc); - sc->value = fx_call(sc, sc->code); -} - - -/* -------------------------------- owlet -------------------------------- */ -/* error reporting info -- save filename and line number */ - -static s7_pointer init_owlet(s7_scheme *sc) -{ - s7_pointer p; /* watch out for order below */ - s7_pointer e = make_let(sc, sc->nil); - sc->temp3 = e; - sc->error_type = add_slot_checked_with_id(sc, e, make_symbol(sc, "error-type", 10), sc->F); /* the error type or tag ('division-by-zero) */ - sc->error_data = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-data", 10), sc->F); /* the message or information passed by the error function */ - sc->error_code = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-code", 10), sc->F); /* the code that s7 thinks triggered the error */ - sc->error_line = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-line", 10), p = make_permanent_integer(0)); /* the line number of that code */ - add_saved_pointer(sc, p); - sc->error_file = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-file", 10), sc->F); /* the file name of that code */ - sc->error_position = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-position", 14), p = make_permanent_integer(0)); /* file-byte position of that code */ - add_saved_pointer(sc, p); -#if WITH_HISTORY - sc->error_history = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-history", 13), sc->F); /* buffer of previous evaluations */ -#endif - sc->temp3 = sc->unused; - return(e); -} - -#if WITH_HISTORY -static s7_pointer cull_history(s7_scheme *sc, s7_pointer code) -{ - clear_symbol_list(sc); /* make a list of words banned from the history */ - add_symbol_to_list(sc, sc->s7_starlet_symbol); - add_symbol_to_list(sc, sc->eval_symbol); - add_symbol_to_list(sc, make_symbol(sc, "debug", 5)); - add_symbol_to_list(sc, make_symbol(sc, "trace-in", 8)); - add_symbol_to_list(sc, make_symbol(sc, "trace-out", 9)); - add_symbol_to_list(sc, sc->dynamic_unwind_symbol); - add_symbol_to_list(sc, make_symbol(sc, "history-enabled", 15)); - for (s7_pointer p = code; is_pair(p); p = cdr(p)) - { - if (tree_set_memq(sc, car(p))) - set_car(p, sc->nil); - if (cdr(p) == code) break; - } - return(code); -} -#endif - -static s7_pointer g_owlet(s7_scheme *sc, s7_pointer unused_args) -{ -#if WITH_HISTORY - #define H_owlet "(owlet) returns the environment at the point of the last error. \ -It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history." -#else - #define H_owlet "(owlet) returns the environment at the point of the last error. \ -It has the additional local variables: error-type, error-data, error-code, error-line, and error-file." -#endif - #define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol) - /* if owlet is not copied, (define e (owlet)), e changes as owlet does! */ - - s7_pointer e; - s7_int gc_loc; - bool old_gc = sc->gc_off; -#if WITH_HISTORY - slot_set_value(sc->error_history, cull_history(sc, slot_value(sc->error_history))); -#endif - e = let_copy(sc, sc->owlet); - gc_loc = gc_protect_1(sc, e); - - /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */ - sc->gc_off = true; - - for (s7_pointer x = let_slots(e); tis_slot(x); x = next_slot(x)) - if (is_pair(slot_value(x))) - { - s7_pointer new_list = copy_any_list(sc, slot_value(x)); - slot_set_value(x, new_list); - for (s7_pointer p = new_list, sp = p; is_pair(p); p = cdr(p), sp = cdr(sp)) - { - s7_pointer val = car(p); - if (is_t_real(val)) - set_car(p, make_real(sc, real(val))); - else - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - else - if (is_t_integer(val)) - set_car(p, make_integer(sc, integer(val))); - p = cdr(p); - if ((!is_pair(p)) || (p == sp)) break; - val = car(p); - if (is_t_real(val)) - set_car(p, make_real(sc, real(val))); - else - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - }} - sc->gc_off = old_gc; - s7_gc_unprotect_at(sc, gc_loc); - return(e); -} - - -/* -------- catch handlers -------- (don't free the catcher) */ -static void load_catch_cstack(s7_scheme *sc, s7_pointer c) -{ - if (catch_cstack(c)) - sc->goto_start = catch_cstack(c); -} - -static bool catch_all_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer catcher = T_Cat(stack_code(sc->stack, i)); - sc->value = stack_args(sc->stack, i); /* error result, optimize_func_three_args -> op_c_catch_all etc */ - if (sc->value == sc->unused) sc->value = type; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher)); - sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(catcher)); - load_catch_cstack(sc, catcher); - pop_stack(sc); - return(true); -} - -static bool catch_2_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - /* this is the macro-error-handler case from g_catch - * (let () (define-macro (m . args) (apply (car args) (cadr args))) (catch #t (lambda () (error abs -1)) m)) - */ - s7_pointer x = T_Cat(stack_code(sc->stack, i)); - if ((catch_tag(x) == sc->T) || (catch_tag(x) == type) || (type == sc->T)) - { - sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(x)); - sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(x)); - sc->code = catch_handler(x); - load_catch_cstack(sc, x); - if (needs_copied_args(sc->code)) - sc->args = list_2(sc, type, info); - else sc->args = with_list_t2(type, info); /* very unlikely: need c_macro as error catcher: (catch #t (lambda () (error 'oops)) require) */ - sc->cur_op = OP_APPLY; - return(true); - } - return(false); -} - -static bool catch_1_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer x = T_Cat(stack_code(sc->stack, i)); - if ((catch_tag(x) == sc->T) || /* the normal case */ - (catch_tag(x) == type) || - (type == sc->T)) - { - opcode_t op = stack_op(sc->stack, i); - s7_pointer catcher = x, error_body, error_args; - s7_pointer error_func = catch_handler(catcher); - uint64_t loc = catch_goto_loc(catcher); - - init_temp(sc->y, type); - sc->value = info; - - sc->temp4 = stack_let(sc->stack, i); /* GC protect this, since we're moving the stack top below */ - sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher)); - sc->stack_end = (s7_pointer *)(sc->stack_start + loc); - load_catch_cstack(sc, catcher); - - /* very often the error handler just returns either a constant ('error or #f), or - * the args passed to it, so there's no need to laboriously make a closure, - * and apply it -- just set sc->value to the closure body (or the args) and return. - * so first examine closure_body(error_func) - * if it is a constant, or quoted symbol, return that, - * if it is the args symbol, return (list type info) - */ - - /* if OP_CATCH_1, we deferred making the error handler until it is actually needed */ - if (op == OP_CATCH_1) - { - error_body = cdr(error_func); - error_args = car(error_func); - } - else - if (is_closure(error_func)) - { - error_body = closure_body(error_func); - error_args = closure_args(error_func); - } - else - { - error_body = NULL; - error_args = NULL; - } - if ((error_body) && (is_null(cdr(error_body)))) - { - s7_pointer y = NULL; - error_body = car(error_body); - if (is_pair(error_body)) - { - if (car(error_body) == sc->quote_symbol) - y = cadr(error_body); - else - if ((car(error_body) == sc->car_symbol) && - (is_pair(cdr(error_body))) && /* catch: (lambda (type info) (car)) */ - (cadr(error_body) == error_args)) - y = type; - } - else - if (!is_symbol(error_body)) - y = error_body; /* not pair or symbol */ - else - if (error_body == error_args) - y = list_2(sc, type, info); - else - if (is_keyword(error_body)) - y = error_body; - else - if ((is_pair(error_args)) && - (error_body == car(error_args))) - y = type; - if (y) - { - if ((SHOW_EVAL_OPS) && (loc > 4)) {fprintf(stderr, "about to pop_stack: \n"); s7_show_stack(sc);} - if (loc > 4) - pop_stack(sc); - /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming - * from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE - * to end that call, but it's pushed at the precatch stack end (far beyond the catch loc). - * If we catch an error, catch unwinds to its starting point, and the pop_stack above - * puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE. - * Now we return true, ending up back in eval, because the error handler jumped out of eval, - * back to wherever we were in eval when we hit the error. eval jumps back to the start - * of its loop, and pops the stack to see what to do next! So the (loc > 4) at least - * protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval. - * We can't do anything fancy here because we have to unwind the C stack as well as s7's stack. - * s7_eval doesn't know anything about the catches on the stack. We can't look back for - * OP_EVAL_DONE -- segfault in OP_BEGIN. Hmmmm. Perhaps catch should not unwind until the - * end? But we want the error handler to run as a part of the calling expression, and - * in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case). - */ - sc->value = y; - sc->y = sc->unused; - sc->temp4 = sc->unused; - sc->w = sc->unused; - if (loc == 4) - sc->code = cons(sc, sc->value, sc->nil); /* if we end up at op_begin, give it something it can handle */ - return(true); - }} - /* here type and info need to be GC protected (new_cell below), g_throw and error_nr, throw sc->w for type, but error_nr nothing currently */ - if (op == OP_CATCH_1) - { - s7_pointer p; - new_cell(sc, p, T_CLOSURE); - closure_set_args(p, car(error_func)); - closure_set_body(p, cdr(error_func)); - closure_set_setter(p, sc->F); - closure_set_arity(p, CLOSURE_ARITY_NOT_SET); - closure_set_let(p, sc->temp4); - sc->code = p; - if ((S7_DEBUGGING) && (!s7_is_aritable(sc, sc->code, 2))) fprintf(stderr, "%s[%d]: errfunc not aritable(2)!\n", __func__, __LINE__); - } - else - { - sc->code = error_func; - sc->y = sc->unused; - if (!s7_is_aritable(sc, sc->code, 2)) /* op_catch_1 from op_c_catch already checks this */ - wrong_number_of_args_error_nr(sc, "catch error handler should accept two arguments: ~S", sc->code); - } - sc->temp4 = sc->unused; - /* if user (i.e. yers truly!) copies/pastes the preceding lambda () into the - * error handler portion of the catch, he gets the inexplicable message: - * ;(): too many arguments: (a1 ()) - * when this apply tries to call the handler. So, we need a special case error check here! - */ - sc->args = list_2(sc, type, info); /* almost never able to skip this -- costs more to check! */ - sc->w = sc->unused; - sc->y = sc->unused; - sc->cur_op = OP_APPLY; - /* explicit eval needed if s7_call called into scheme where a caught error occurred (ex6 in exs7.c) - * but putting it here (via eval(sc, OP_APPLY)) means the C stack is not cleared correctly in non-s7-call cases, - * so defer it until s7_call - */ - return(true); - } - return(false); -} - -static bool catch_dynamic_wind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer x = T_Dyn(stack_code(sc->stack, i)); - if (dynamic_wind_state(x) == DWIND_BODY) - { - dynamic_wind_state(x) = DWIND_FINISH; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */ - if (dynamic_wind_out(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); - } - return(false); -} - -static bool catch_out_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer x = T_Prt(stack_code(sc->stack, i)); /* "code" = port that we opened */ - s7_close_output_port(sc, x); - x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not # */ - if (x != sc->unused) - set_current_output_port(sc, x); - return(false); -} - -static bool catch_in_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - return(false); -} - -static bool catch_read_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - pop_input_port(sc); - return(false); -} - -static bool catch_eval_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - return(false); -} - -static bool catch_barrier_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - if (is_input_port(stack_args(sc->stack, i))) /* (eval-string "'(1 .)") */ - { - if (current_input_port(sc) == stack_args(sc->stack, i)) - pop_input_port(sc); - s7_close_input_port(sc, stack_args(sc->stack, i)); - } - return(false); -} - -static bool catch_hook_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, i)); - /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */ - (*reset_hook) = true; - /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */ - return(false); -} - -static bool catch_goto_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - call_exit_active(stack_args(sc->stack, i)) = false; - return(false); -} - -static bool catch_map_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - sc->map_call_ctr--; - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - return(false); -} - -static bool op_let_temp_done1(s7_scheme *sc); - -static bool catch_let_temporarily_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - /* this is aimed at let-temp error-hook... error -- not yet tested much */ - if ((!*reset_hook) && - (hook_has_functions(sc->error_hook))) - { - s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); - - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); - sc->code = sc->let_temp_hook; - sc->args = list_2(sc, type, info); - - push_stack_direct(sc, OP_EVAL_DONE); - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, error_hook_funcs); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); - - sc->args = stack_args(sc->stack, i); - sc->code = stack_code(sc->stack, i); - set_curlet(sc, stack_let(sc->stack, i)); - - push_stack_direct(sc, OP_GC_PROTECT); - if (!op_let_temp_done1(sc)) - { - push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_SET_UNCHECKED); - }} - else let_temp_done(sc, stack_args(sc->stack, i), stack_let(sc->stack, i)); - return(false); -} - -static bool catch_let_temp_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - slot_set_value(stack_code(sc->stack, i), stack_args(sc->stack, i)); - return(false); -} - -static bool catch_let_temp_s7_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - return(false); -} - -static bool catch_let_temp_s7_direct_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - return(false); -} - -static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - /* if func has an error, s7_error will call it as it unwinds the stack -- an infinite loop. So, cancel the unwind first */ - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - - /* we're in an error or throw, so there is no return value to report, but we need to decrement *debug-spaces* (if in debug) - * stack_let is the trace-in let at the point of the dynamic_unwind call - */ - if (sc->debug > 0) - { - s7_pointer spaces = lookup_slot_from(make_symbol(sc, "*debug-spaces*", 14), stack_let(sc->stack, i)); - if (is_slot(spaces)) - slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ - } - return(false); -} - -typedef bool (*catch_function_t)(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook); -static catch_function_t catchers[NUM_OPS]; - -static void init_catchers(void) -{ - for (int32_t i = 0; i < NUM_OPS; i++) catchers[i] = NULL; - catchers[OP_CATCH_ALL] = catch_all_function; - catchers[OP_CATCH_2] = catch_2_function; - catchers[OP_CATCH_1] = catch_1_function; - catchers[OP_CATCH] = catch_1_function; - catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function; - catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function; - catchers[OP_GET_OUTPUT_STRING] = catch_out_function; - catchers[OP_UNWIND_OUTPUT] = catch_out_function; - catchers[OP_UNWIND_INPUT] = catch_in_function; - catchers[OP_READ_DONE] = catch_read_function; /* perhaps an error during (read) */ - catchers[OP_EVAL_STRING] = catch_eval_function; - catchers[OP_BARRIER] = catch_barrier_function; - catchers[OP_DEACTIVATE_GOTO] = catch_goto_function; - catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function; - catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function; - catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function; - catchers[OP_LET_TEMP_S7_DIRECT_UNWIND] = catch_let_temp_s7_direct_unwind_function; - catchers[OP_ERROR_HOOK_QUIT] = catch_hook_function; - catchers[OP_MAP_UNWIND] = catch_map_unwind_function; -} - -/* -------------------------------- throw -------------------------------- */ -static s7_pointer g_throw(s7_scheme *sc, s7_pointer args) -{ - #define H_throw "(throw tag . info) is like (error ...) but it does not affect owlet. \ -It looks for an existing catch with a matching tag, and jumps to it if found. Otherwise it raises an error." - #define Q_throw s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) - - bool ignored_flag = false; - s7_pointer type = car(args), info = cdr(args); - gc_protect_via_stack(sc, args); - /* type can be anything: (throw (list 1 2 3) (make-list 512)), sc->w and sc->value not good here for gc protection */ - - for (int64_t i = current_stack_top(sc) - 5; i >= 3; i -= 4) /* look for a catcher */ - { - catch_function_t catcher = catchers[stack_op(sc->stack, i)]; - if ((catcher) && - (catcher(sc, i, type, info, &ignored_flag))) - { - if (sc->longjmp_ok) LongJmp(*(sc->goto_start), THROW_JUMP); - return(sc->value); - }} - if (is_let(car(args))) - check_method(sc, car(args), sc->throw_symbol, args); - error_nr(sc, make_symbol(sc, "uncaught-throw", 14), - set_elist_3(sc, wrap_string(sc, "no catch found for (throw ~W~{~^ ~S~})", 38), type, info)); - return(sc->F); -} - - -/* -------------------------------- warn -------------------------------- */ -#if WITH_GCC -static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) -#else -static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = max size of output string (for vsnprintf) */ -#endif -{ - if ((sc->error_port != sc->F) && (!sc->muffle_warnings)) - { - int32_t bytes; - va_list ap; - block_t *b = mallocate(sc, len); - char *str = (char *)block_data(b); - str[0] = '\0'; - va_start(ap, ctrl); - bytes = vsnprintf(str, len, ctrl, ap); - va_end(ap); - if (port_is_closed(sc->error_port)) - sc->error_port = sc->standard_error; - if ((bytes > 0) && (sc->error_port != sc->F)) - port_write_string(sc->error_port)(sc, str, bytes, sc->error_port); - liberate(sc, b); - } -} - - -/* -------------------------------- error -------------------------------- */ -static void fill_error_location(s7_scheme *sc) -{ - if (((is_input_port(current_input_port(sc))) && (is_loader_port(current_input_port(sc)))) || - (((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE)))) - { - integer(slot_value(sc->error_line)) = port_line_number(current_input_port(sc)); - integer(slot_value(sc->error_position)) = port_position(current_input_port(sc)); - slot_set_value(sc->error_file, wrap_string(sc, port_filename(current_input_port(sc)), port_filename_length(current_input_port(sc)))); - } - else - { - integer(slot_value(sc->error_line)) = 0; - integer(slot_value(sc->error_position)) = 0; - slot_set_value(sc->error_file, sc->F); - } -} - -static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) -{ - bool reset_error_hook = false; - s7_pointer cur_code = current_code(sc); - - sc->format_depth = -1; - sc->object_out_locked = false; /* possible error in obj->str method after object_out has set this flag */ - sc->has_openlets = true; /* same problem -- we need a cleaner way to handle this, op_?_unwind */ - sc->value = info; /* feeble GC protection (otherwise info is sometimes freed in this function), throw also protects type */ - - if (sc->current_safe_list > 0) - clear_list_in_use(sc->safe_lists[sc->current_safe_list]); - slot_set_value(sc->error_type, type); - slot_set_value(sc->error_data, info); - - if (unchecked_type(sc->curlet) != T_LET) - sc->curlet = sc->nil; /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */ - let_set_outlet(sc->owlet, sc->curlet); - slot_set_value(sc->error_code, cur_code); - -#if WITH_HISTORY - slot_set_value(sc->error_history, sc->cur_code); - if (sc->cur_code != sc->history_sink) - { - sc->cur_code = (sc->using_history1) ? sc->eval_history2 : sc->eval_history1; - sc->using_history1 = (!sc->using_history1); - pair_fill(sc, set_plist_2(sc, sc->cur_code, sc->nil)); - } -#endif - if (is_pair(cur_code)) - { - s7_int line = -1, file, position; - if (has_location(cur_code)) - { - line = pair_line_number(cur_code); - file = pair_file_number(cur_code); - position = pair_position(cur_code); - } - else /* try to find a plausible line number! */ - for (s7_pointer p = cur_code, sp = cur_code; is_pair(p); p = cdr(p), sp = cdr(sp)) - { - if ((is_pair(car(p))) && /* what about p itself? */ - (has_location(car(p)))) - { - line = pair_line_number(car(p)); - file = pair_file_number(car(p)); - position = pair_position(car(p)); - break; - } - p = cdr(p); - if ((!is_pair(p)) || (p == sp)) break; - if ((is_pair(car(p))) && - (has_location(car(p)))) - { - line = pair_line_number(car(p)); - file = pair_file_number(car(p)); - position = pair_position(car(p)); - break; - }} - if ((line <= 0) || (file < 0)) - fill_error_location(sc); - else - { - integer(slot_value(sc->error_line)) = line; - integer(slot_value(sc->error_position)) = position; - slot_set_value(sc->error_file, sc->file_names[file]); - }} - else fill_error_location(sc); - - /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */ - /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the cell containing the catch struct */ - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - { - catch_function_t catcher = catchers[stack_op(sc->stack, i)]; - if ((catcher) && - (catcher(sc, i, type, info, &reset_error_hook))) - { - if (SHOW_EVAL_OPS) {fprintf(stderr, "after catch: \n"); s7_show_stack(sc);} - if ((S7_DEBUGGING) && (!sc->longjmp_ok)) fprintf(stderr, "s7_error jump not available?\n"); - LongJmp(*(sc->goto_start), CATCH_JUMP); - }} - /* error not caught (but catcher might have been called and returned false) */ - - if ((!reset_error_hook) && - (hook_has_functions(sc->error_hook))) - { - s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); - /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'args))))) */ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); - /* if the *error-hook* functions trigger an error, we had better not have hook_functions(*error-hook*) still set! */ - - /* here we have no catcher (anywhere!), we're headed back to the top-level(?), so error_hook_quit can call reset_stack? */ - push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_funcs); /* restore *error-hook* upon successful (or any!) evaluation */ - sc->code = sc->let_temp_hook; - sc->args = list_2(sc, type, info); - /* if we drop into the longjmp below, the hook functions are not called! - * OP_ERROR_HOOK_QUIT performs the longjmp, so it should be safe to go to eval. - */ - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - } - else - { - s7_int op = sc->print_length; - if (op < 32) sc->print_length = 32; - - if ((!is_output_port(sc->error_port)) || /* error-port can be #f */ - (port_is_closed(sc->error_port))) - sc->error_port = sc->standard_error; - /* if info is not a list, send object->string to current error port, - * else assume car(info) is a format control string, and cdr(info) are its args - * if at all possible, get some indication of where we are! - */ - - if ((!is_pair(info)) || - (!is_string(car(info)))) - format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), false, 7); - else - { - /* it's possible that the error string is just a string -- not intended for format */ - if ((type != sc->format_error_symbol) && /* avoid an infinite loop of format errors */ - (strchr(string_value(car(info)), '~'))) - { - s7_int len = string_length(car(info)) + 8; - block_t *b = mallocate(sc, len); - char *errstr = (char *)block_data(b); - s7_int str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), (const char *)NULL); - format_to_port(sc, sc->error_port, errstr, cdr(info), false, str_len); - liberate(sc, b); - } - else format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), false, 7); /* 7 = ctrl str len */ - } - if (op < 32) sc->print_length = op; - - /* now display location at end */ - if (is_string(slot_value(sc->error_file))) - { - s7_newline(sc, sc->error_port); - format_to_port(sc, sc->error_port, "; ~A\n", - set_plist_1(sc, object_to_truncated_string(sc, cur_code, 40)), - false, 8); - format_to_port(sc, sc->error_port, "; ~A, line ~D, position: ~D\n", - set_plist_3(sc, slot_value(sc->error_file), slot_value(sc->error_line), slot_value(sc->error_position)), - false, 31); - } - else - { - if ((is_input_port(current_input_port(sc))) && - (port_file(current_input_port(sc)) != stdin) && - (!port_is_closed(current_input_port(sc)))) - { - const char *filename = port_filename(current_input_port(sc)); - int32_t line = port_line_number(current_input_port(sc)); - - if (filename) - format_to_port(sc, sc->error_port, "\n; ~A[~D]", - set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), - wrap_integer(sc, line)), false, 10); - else - if ((line > 0) && - (integer(slot_value(sc->error_line)) > 0)) - format_to_port(sc, sc->error_port, "\n; line ~D", set_plist_1(sc, wrap_integer(sc, line)), false, 11); - else - if (sc->input_port_stack_loc > 0) - { - s7_pointer p = sc->input_port_stack[sc->input_port_stack_loc - 1]; - if ((is_input_port(p)) && - (port_file(p) != stdin) && - (!port_is_closed(p))) - { - filename = port_filename(p); - line = port_line_number(p); - if (filename) - format_to_port(sc, sc->error_port, "\n; ~A[~D]", - set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), - wrap_integer(sc, line)), false, 10); - }}} - else - { - const char *call_name = sc->s7_call_name; - if (call_name) - { - sc->s7_call_name = NULL; - if ((sc->s7_call_file) && - (sc->s7_call_line >= 0)) - format_to_port(sc, sc->error_port, "\n; ~A ~A[~D]", - set_plist_3(sc, - s7_make_string_wrapper(sc, call_name), - s7_make_string_wrapper(sc, sc->s7_call_file), - wrap_integer(sc, sc->s7_call_line)), - false, 13); - }} - s7_newline(sc, sc->error_port); - } - /* look for __func__ in the error environment etc */ - if (sc->error_port != sc->F) - { - s7_pointer errp = s7_stacktrace(sc); - if (string_length(errp) > 0) - { - port_write_string(sc->error_port)(sc, string_value(errp), string_length(errp), sc->error_port); - port_write_character(sc->error_port)(sc, '\n', sc->error_port); - }} - else - if (is_pair(slot_value(sc->error_code))) - { - format_to_port(sc, sc->error_port, "; ~S", set_plist_1(sc, slot_value(sc->error_code)), false, 7); - s7_newline(sc, sc->error_port); - } - /* if (is_continuation(type)) - * go into repl here with access to continuation? Or expect *error-handler* to deal with it? - */ - sc->value = type; - sc->cur_op = OP_ERROR_QUIT; - } - /* if (sc->longjmp_ok) */ LongJmp(*(sc->goto_start), ERROR_JUMP); -} - -s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) /* s7.h backwards compatibility */ -{ - error_nr(sc, type, info); - return(type); -} - -static noreturn void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool string_error) -{ - /* reader errors happen before the evaluator gets involved, so forms such as: - * (catch #t (lambda () (car '( . ))) (lambda arg 'error)) - * do not catch the error if we simply signal an error when we encounter it. - */ - s7_pointer pt = current_input_port(sc); - - if (!string_error) - { - /* make an heroic effort to find where we slid off the tracks */ - if (is_string_port(current_input_port(sc))) - { - #define QUOTE_SIZE 40 - s7_int i, j, start = 0, end, slen, size; - char *recent_input = NULL; - - /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ - if (port_position(pt) >= port_data_size(pt)) - port_position(pt) = port_data_size(pt) - 1; - - /* start at current position and look back a few chars */ - for (i = port_position(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); i--, j++) - if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) - break; - start = i; - - /* start at current position and look ahead a few chars */ - size = port_data_size(pt); - for (i = port_position(pt), j = 0; (i < size) && (j < QUOTE_SIZE); i++, j++) - if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) - break; - end = i; - - slen = end - start; /* hopefully this is more or less the current line where the read error happened */ - if (slen > 0) - { - recent_input = (char *)Calloc(slen + 9, 1); - for (i = 0; i < (slen + 8); i++) recent_input[i] = '.'; - recent_input[3] = ' '; - recent_input[slen + 4] = ' '; - for (i = 0; i < slen; i++) recent_input[i + 4] = port_data(pt)[start + i]; - } - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - string_length(p) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - if (recent_input) free(recent_input); - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - else - { - s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if ((sc->current_file) && - (sc->current_line >= 0)) - string_length(p) = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", - sc->current_file, sc->current_line); - else string_length(p) = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : ""); - if (recent_input) free(recent_input); - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - }}} - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int nlen = 0; - s7_int len = safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 128; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if (string_error) - nlen = snprintf(msg, len, "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" ld64 "]", - errmsg, port_filename(pt), port_line_number(pt), - sc->strbuf, sc->current_file, sc->current_line); - else nlen = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%" ld64 "]", - errmsg, port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - string_length(p) = nlen; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - error_nr(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, - set_elist_1(sc, s7_make_string_wrapper(sc, (char *)errmsg))); -} - -static noreturn void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);} -static noreturn void string_read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, true);} - -static s7_pointer g_error(s7_scheme *sc, s7_pointer args) -{ - #define H_error "(error type ...) signals an error. The 'type' can be used with catch to trap \ -particular errors. If the error is not caught, s7 treats the second argument as a format control string, \ -and applies it to the rest of the arguments." - #define Q_error s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) - - if (is_string(car(args))) /* a CL-style error -- use tag='no-catch */ - error_nr(sc, make_symbol(sc, "no-catch", 8), args); - error_nr(sc, car(args), cdr(args)); - return(sc->unspecified); -} - -static char *truncate_string(char *form, s7_int len, use_write_t use_write) -{ - uint8_t *f = (uint8_t *)form; - s7_int i; - if (use_write != P_DISPLAY) - { - /* I guess we need to protect the outer double quotes in this case */ - for (i = len - 5; i >= (len / 2); i--) - if (is_white_space((int32_t)f[i])) - return(form); - i = len - 5; - if (i > 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '"'; form[i + 4] = '\0';} - else - if (len >= 2) - { - form[len - 1] = '"'; - form[len] = '\0'; - }} - else - { - for (i = len - 4; i >= (len / 2); i--) - if (is_white_space((int32_t)f[i])) - { - form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0'; - return(form); - } - i = len - 4; - if (i >= 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0';} - else form[len] = '\0'; - } - return(form); -} - -static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len) -{ - char *s; - s7_int s_len; - s7_pointer strp; - sc->objstr_max_len = len + 2; - strp = s7_object_to_string(sc, p, false); - s = string_value(strp); - sc->objstr_max_len = S7_INT64_MAX; - s_len = string_length(strp); - if (s_len > len) - truncate_string(s, len, P_DISPLAY); - return(strp); -} - -static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, uint32_t line) -{ - s7_pointer tp; - if (!is_pair(p)) return(NULL); - if (has_location(p)) - { - uint32_t x = (uint32_t)pair_line_number(p); - if (x > 0) - { - if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ - line = x; - else - if (x < line) - return(p); - }} - tp = tree_descend(sc, car(p), line); - return((tp) ? tp : tree_descend(sc, cdr(p), line)); -} - -static noreturn void missing_close_paren_error_nr(s7_scheme *sc) -{ - char *syntax_msg = NULL; - s7_pointer pt = current_input_port(sc); - - if ((unchecked_type(sc->curlet) != T_LET) && (sc->curlet != sc->nil)) - sc->curlet = sc->nil; - - /* check *missing-close-paren-hook* */ - if (hook_has_functions(sc->missing_close_paren_hook)) - { - s7_pointer result; - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - integer(slot_value(sc->error_line)) = port_line_number(pt); - integer(slot_value(sc->error_position)) = port_position(pt); - slot_set_value(sc->error_file, wrap_string(sc, port_filename(pt), port_filename_length(pt))); - } - result = s7_call(sc, sc->missing_close_paren_hook, sc->nil); - if (result != sc->unspecified) - g_throw(sc, list_1(sc, result)); - } - - if (is_pair(sc->args)) - { - s7_pointer p = tree_descend(sc, sc->args, 0); - if ((p) && (is_pair(p)) && - (has_location(p))) - { - s7_pointer strp = object_to_truncated_string(sc, p, 40); - char *form = string_value(strp); - s7_int form_len = string_length(strp); - s7_int msg_len = form_len + 128; - syntax_msg = (char *)Malloc(msg_len); - snprintf(syntax_msg, msg_len, "; current form awaiting a close paren starts around line %u: %s", (uint32_t)pair_line_number(p), form); - }} - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int nlen; - s7_int len = port_filename_length(pt) + safe_strlen(sc->current_file) + safe_strlen(syntax_msg) + 128; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if (syntax_msg) - { - nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", - port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line, syntax_msg); - free(syntax_msg); - } - else nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]", - port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - string_length(p) = nlen; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - - if (syntax_msg) - { - s7_int len = safe_strlen(syntax_msg) + 128; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - len = catstrs(msg, len, "missing close paren\n", syntax_msg, "\n", (char *)NULL); - free(syntax_msg); - string_length(p) = len; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - if ((is_input_port(pt)) && - (!port_is_closed(pt)) && - (port_data(pt)) && - (port_position(pt) > 0)) - { - s7_pointer p = make_empty_string(sc, 128, '\0'); - s7_int pos = port_position(pt); - s7_int start = pos - 40; - char *msg = string_value(p); - memcpy((void *)msg, (void *)"missing close paren: ", 21); - if (start < 0) start = 0; - memcpy((void *)(msg + 21), (void *)(port_data(pt) + start), pos - start); - string_length(p) = 21 + pos - start; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "missing close paren", 19))); -} - -static noreturn void improper_arglist_error_nr(s7_scheme *sc) -{ - /* sc->code is the last (dotted) arg, sc->args is the arglist reversed not including sc->code - * the original was `(func ,@(reverse args) . ,code) essentially where func is sc->value or pop_op_stack(sc) - */ - s7_pointer func = pop_op_stack(sc); - if (sc->args == sc->nil) /* (abs . 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "attempt to evaluate (~S . ~S)?", 30), func, sc->code)); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "attempt to evaluate (~S ~S . ~S)?", 33), - func, sc->args = proper_list_reverse_in_place(sc, sc->args), sc->code)); -} - -static void op_error_hook_quit(s7_scheme *sc) -{ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->code); /* restore old value */ - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); - /* now mimic the end of the normal error handler. Since this error hook evaluation can happen - * in an arbitrary s7_call nesting, we can't just return from the current evaluation -- - * we have to jump to the original (top-level) call. Otherwise '# or whatever - * is simply treated as the (non-error) return value, and the higher level evaluations - * get confused. - */ - stack_reset(sc); /* is this necessary? is it a good idea?? */ - push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */ - sc->cur_op = OP_ERROR_QUIT; - if (sc->longjmp_ok) - LongJmp(*(sc->goto_start), ERROR_QUIT_JUMP); -} - - -/* -------------------------------- begin_hook -------------------------------- */ -void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val) {return(sc->begin_hook);} - -void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val)) -{ - sc->begin_hook = hook; - sc->begin_op = (hook) ? OP_BEGIN_HOOK : OP_BEGIN_NO_HOOK; -} - -static bool call_begin_hook(s7_scheme *sc) -{ - bool result = false; - /* originally begin_hook was bool (*hook)(s7_scheme *sc): the value was returned directly, - * rather than going through a *bool arg (&result below). That works in gcc (Linux/OSX), - * but does not work in MS Visual C++. In the latter, the compiler apparently completely - * eliminates any local, returning (for example) a thread-relative stack-allocated value - * directly, but then by the time we get here, that variable has vanished, and we get - * garbage. We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...); - * So, in the new form (26-Jun-13), the value is passed directly into an s7 variable - * that I hope can't be optimized out of existence. - * - * cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think) - * originally this facility was aimed at interrupting infinite loops, and the expected usage was: - * set begin_hook, eval-string(...), unset begin_hook - */ - opcode_t op = sc->cur_op; - push_stack_direct(sc, OP_BARRIER); - sc->begin_hook(sc, &result); - if (result) - { - s7_pointer cur_code = current_code(sc); - /* set (owlet) in case we were interrupted and need to see why something was hung */ - slot_set_value(sc->error_type, sc->F); - slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */ - slot_set_value(sc->error_code, cur_code); - if (has_location(cur_code)) - { - integer(slot_value(sc->error_line)) = (s7_int)pair_line_number(cur_code); - slot_set_value(sc->error_file, sc->file_names[pair_file_number(cur_code)]); - integer(slot_value(sc->error_position)) = (s7_int)pair_position(cur_code); - } - else - { - integer(slot_value(sc->error_line)) = 0; - integer(slot_value(sc->error_position)) = 0; - slot_set_value(sc->error_file, sc->F); - } -#if WITH_HISTORY - slot_set_value(sc->error_history, sc->F); -#endif - let_set_outlet(sc->owlet, sc->curlet); - sc->value = make_symbol(sc, "begin-hook-interrupt", 20); - /* otherwise the evaluator returns whatever random thing is in sc->value (normally #) - * which makes debugging unnecessarily difficult. ?? why not return something useful? make return s7_pointer*, not bool* - */ - s7_quit(sc); /* don't call gc here -- eval_c_string is the context -- allows interrupt of infinite loop */ - return(true); - } - pop_stack_no_op(sc); - sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in syntax_error */ - return(false); -} - - -/* -------------------------------- apply -------------------------------- */ -static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d) -{ - /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */ - s7_pointer p; - gc_protect_via_stack(sc, d); - p = cons(sc, car(d), cdr(d)); - sc->w = p; - while (is_not_null(cddr(p))) - { - d = cdr(d); - set_cdr(p, cons(sc, car(d), cdr(d))); - if (is_not_null(cdr(d))) - p = cdr(p); - } - unstack(sc); - set_cdr(p, cadr(p)); - return(sc->w); -} - -static noreturn void apply_list_error_nr(s7_scheme *sc, s7_pointer lst) -{ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "apply's last argument should be a proper list: ~S", 49), lst)); -} - -static s7_pointer g_apply(s7_scheme *sc, s7_pointer args) -{ - #define H_apply "(apply func ...) applies func to the rest of the arguments" - #define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_sequence_symbol), sc->T) - - /* can apply always be replaced with apply values? (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3))) - * not if apply* in disguise, I think: (apply + 1 2 ()) -> 3, (apply + 1 2 (apply values ())) -> error - */ - s7_pointer func = car(args); - if (!is_applicable(func)) - apply_error_nr(sc, func, args); - - if (is_null(cdr(args))) - { - push_stack(sc, OP_APPLY, sc->nil, func); - return(sc->nil); - } - if (is_safe_procedure(func)) - { - s7_pointer p, q; - for (q = args, p = cdr(args); is_not_null(cdr(p)); q = p, p = cdr(p)); - /* the last arg is supposed to be a list, it will be spliced onto the end of the previous arg list (if any) below */ - - if (!s7_is_proper_list(sc, car(p))) /* (apply + #f) etc, the cycle protection here is checked in s7test */ - apply_list_error_nr(sc, args); - set_cdr(q, car(p)); /* args affected, so don't depend on cdr(args) from above */ - - if (is_c_function(func)) /* handle in-place to get better error messages */ - { - s7_int len; - uint8_t typ = type(func); - if (typ == T_C_RST_NO_REQ_FUNCTION) - return(c_function_call(func)(sc, cdr(args))); - len = proper_list_length(cdr(args)); - if (c_function_max_args(func) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, too_many_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); - if ((typ == T_C_FUNCTION) && - (len < c_function_min_args(func))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, not_enough_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); - return(c_function_call(func)(sc, cdr(args))); - } - push_stack(sc, OP_APPLY, cdr(args), func); - return(sc->nil); - } - sc->code = func; - sc->args = (is_null(cddr(args))) ? cadr(args) : apply_list_star(sc, cdr(args)); - if (!s7_is_proper_list(sc, sc->args)) - apply_list_error_nr(sc, sc->args); - - /* (define imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()))))))) - * (define (fop4 x y) (apply x y)) - * (display (object->string (apply (lambda (a . b) (cons a b)) imp) :readable)) -> (list 0 1 2) - * (display (object->string (fop4 (lambda (a . b) (cons a b)) imp) :readable)) -> (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()) - * g_apply sees the first one and thinks the lambda arg is unsafe, apply_ss sees the second and thinks it is safe (hence the list is not copied), - * so calling sort on the first is fine, but on the second gets an immutable object error. - */ - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, sc->args) : sc->args; - push_stack_direct(sc, OP_APPLY); - return(sc->nil); -} - -s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args) -{ - TRACK(sc); - if (is_c_function(fnc)) - return(c_function_call(fnc)(sc, args)); - /* if [if (!is_applicable(fnc)) apply_error_nr(sc, fnc, sc->args);] here, needs_copied_args can be T_App */ - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = fnc; - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - /* fprintf(stderr, "apply %s %s\n", display(sc->code), display(sc->args)); */ - eval(sc, OP_APPLY); - /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = fn_proc(...) where the fn_proc - * happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally. - */ - return(sc->value); -} - -static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args) -{ - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = func; - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - return(sc->value); -} - -static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_pointer args); - -static s7_pointer implicit_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices) -{ - if (!is_applicable(in_obj)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - set_ulist_1(sc, obj, indices), cons(sc, in_obj, cdr(indices)), in_obj)); - return(implicit_index(sc, in_obj, cdr(indices))); -} - -static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices) -{ - /* (let ((lst '("12" "34"))) (lst 0 1)) -> #\2 - * (let ((lst (list #(1 2) #(3 4)))) (lst 0 1)) -> 2 - * this can get tricky: ((list (lambda (a) (+ a 1)) (lambda (b) (* b 2))) 1 2) -> 4 - * but what if func takes rest/optional args, etc: ((list (lambda args (car args))) 0 "hi" 0) - * should this return #\h or "hi"?? currently it is "hi" which is consistent with ((lambda args (car args)) "hi" 0) - * but ((lambda (arg) arg) "hi" 0) is currently an error (too many arguments) - * maybe it should be (((lambda (arg) arg) "hi") 0) -> #\h - */ - s7_pointer res, in_obj; - switch (type(obj)) - { - case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */ - return(vector_ref_1(sc, obj, indices)); - - case T_FLOAT_VECTOR: - res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->float_vector_ref_symbol, T_FLOAT_VECTOR); - set_car(sc->u1_1, sc->F); - return(res); - - case T_INT_VECTOR: - res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->int_vector_ref_symbol, T_INT_VECTOR); - set_car(sc->u1_1, sc->F); - return(res); - - case T_BYTE_VECTOR: - res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->byte_vector_ref_symbol, T_BYTE_VECTOR); - set_car(sc->u1_1, sc->F); - return(res); - - case T_STRING: /* (#("12" "34") 0 1) -> #\2 */ - if (!is_null(cdr(indices))) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); - if (!is_t_integer(car(indices))) - wrong_type_error_nr(sc, sc->string_ref_symbol, 2, car(indices), sc->type_names[T_INTEGER]); - return(string_ref_p_pi_unchecked(sc, obj, integer(car(indices)))); - - case T_PAIR: /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */ - in_obj = list_ref_1(sc, obj, car(indices)); - if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); - return(in_obj); - - case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ - in_obj = s7_hash_table_ref(sc, obj, car(indices)); - if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); - return(in_obj); - - case T_LET: - in_obj = let_ref(sc, obj, car(indices)); - if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); - return(in_obj); - - case T_C_OBJECT: - res = (*(c_object_ref(sc, obj)))(sc, set_ulist_1(sc, obj, indices)); - set_car(sc->u1_1, sc->F); - return(res); - - case T_ITERATOR: /* indices is not nil, so this is an error */ - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); - - case T_CLOSURE: case T_CLOSURE_STAR: - if (!is_safe_closure(obj)) /* s7_call can't work in general with unsafe stuff */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't call a (possibly unsafe) function implicitly: ~S ~S", 57), obj, indices)); - check_stack_size(sc); - sc->temp10 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* s7_call copies and this is safe? 2-Oct-22 (and below) */ - sc->value = s7_call(sc, obj, sc->temp10); - sc->temp10 = sc->unused; - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "mv: %s %s %s\n", display(obj), display(indices), display(sc->value)); - /* if mv: sc->value = splice_in_values(sc, multiple_value(sc->value)); */ - return(sc->value); - - case T_C_FUNCTION: - return(apply_c_function(sc, obj, indices)); - - case T_C_RST_NO_REQ_FUNCTION: - return(c_function_call(obj)(sc, indices)); - - default: - if (!is_applicable(obj)) /* (apply (list cons cons) (list 1 2)) needs the argnum check mentioned below */ - apply_error_nr(sc, obj, indices); - sc->temp10 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* do not use sc->args here! */ - sc->value = s7_call(sc, obj, sc->temp10); - sc->temp10 = sc->unused; - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); - } -} - -static inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t start_arg, int32_t n_args, s7_pointer par) -{ - s7_pointer *df = c_function_arg_defaults(func); - if (c_func_has_simple_defaults(func)) - for (int32_t i = start_arg; i < n_args; i++, par = cdr(par)) - set_car(par, df[i]); - else - for (int32_t i = start_arg; i < n_args; i++, par = cdr(par)) - { - s7_pointer defval = df[i]; - if (is_symbol(defval)) - set_car(par, lookup_checked(sc, defval)); - else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->nil) : defval); - } -} - -static s7_pointer set_c_function_star_args(s7_scheme *sc) -{ - int32_t i, j; - s7_pointer arg, par, call_args, func = sc->code; - s7_pointer *df; - int32_t n_args = c_function_max_args(func); /* not counting keywords, I think */ - - if (is_safe_procedure(func)) - call_args = c_function_call_args(func); - else - { - call_args = make_list(sc, c_function_optional_args(func), sc->F); - gc_protect_via_stack(sc, call_args); - } - - /* assume at the start that there are no keywords */ - for (i = 0, arg = sc->args, par = call_args; (i < n_args) && (is_pair(arg)); i++, arg = cdr(arg), par = cdr(par)) - if (!is_symbol_and_keyword(car(arg))) - set_car(par, car(arg)); - else - { - s7_pointer kpar, karg; - int32_t ki; - /* oops -- there are keywords, change scanners (much duplicated code...) - * setting checked on the call_args here rather than parsing the parameters to use add_symbol_to_list - */ - for (kpar = call_args; kpar != par; kpar = cdr(kpar)) - set_checked(kpar); - for (; is_pair(kpar); kpar = cdr(kpar)) - clear_checked(kpar); - df = c_function_arg_names(func); - for (ki = i, karg = arg, kpar = par; (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) - if (!is_symbol_and_keyword(car(karg))) - { - if (is_checked(kpar)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, car(kpar), sc->args)); - } - set_checked(kpar); - set_car(kpar, car(karg)); - kpar = cdr(kpar); - } - else - { - s7_pointer p; - for (j = 0, p = call_args; j < n_args; j++, p = cdr(p)) - if (df[j] == car(karg)) - break; - if (j == n_args) - { - if (!c_function_allows_other_keys(func)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "~A: not a parameter name?", 25), car(karg))); - } - karg = cdr(karg); - if (is_null(karg)) /* (f :x) where f arglist includes :allow-other-keys */ - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(arg), sc->args)); - } - ki--; - } - else - { - if (is_checked(p)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, car(p), sc->args)); - } - if (!is_pair(cdr(karg))) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(karg), sc->args)); - } - set_checked(p); - karg = cdr(karg); - set_car(p, car(karg)); - kpar = cdr(kpar); - }} - if ((!is_null(karg)) && (!c_function_allows_other_keys(func))) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); - } - if (ki < n_args) - { - df = c_function_arg_defaults(func); - if (c_func_has_simple_defaults(func)) - { - for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) - if (!is_checked(kpar)) - set_car(kpar, df[ki]); - } - else - for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) - if (!is_checked(kpar)) - { - s7_pointer defval = df[ki]; - if (is_symbol(defval)) - set_car(kpar, lookup_checked(sc, defval)); - else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->nil) : defval); - }} - if (!is_safe_procedure(func)) unstack(sc); - return(call_args); - } - if (!is_null(arg)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); - } - if (i < n_args) - fill_star_defaults(sc, func, i, n_args, par); - if (!is_safe_procedure(func)) unstack(sc); - return(call_args); -} - -static s7_pointer set_c_function_star_defaults(s7_scheme *sc, int32_t num) -{ - s7_pointer call_args, func = sc->code, par; - int32_t n_args = c_function_max_args(func); - - if (is_safe_procedure(func)) - call_args = c_function_call_args(func); - else - { - call_args = make_list(sc, c_function_optional_args(func), sc->F); - gc_protect_via_stack(sc, call_args); - } - par = call_args; - if (num == 1) - { - set_car(par, car(sc->args)); - par = cdr(par); - } - fill_star_defaults(sc, func, num, n_args, par); - if (!is_safe_procedure(func)) unstack(sc); - return(call_args); -} - -#define apply_c_function_star(Sc) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_args(Sc)) -#define apply_c_function_star_fill_defaults(Sc, Num) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_defaults(Sc, Num)) - -s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args) -{ - TRACK(sc); - if (is_c_function_star(fnc)) - { - sc->w = sc->args; - sc->z = sc->code; - sc->args = T_Ext(args); - sc->code = fnc; - apply_c_function_star(sc); - sc->args = sc->w; - sc->code = sc->z; - return(sc->value); - } - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = fnc; - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - eval(sc, OP_APPLY); - return(sc->value); -} - -/* -------------------------------- eval -------------------------------- */ -s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e) -{ - declare_jump_info(); - TRACK(sc); - if (sc->safety > NO_SAFETY) - { - if (!s7_is_valid(sc, code)) - s7_warn(sc, 256, "bad code argument to %s: %p\n", __func__, code); - if (!s7_is_valid(sc, e)) - s7_warn(sc, 256, "bad environment argument to %s: %p\n", __func__, e); - } - store_jump_info(sc); - set_jump_info(sc, EVAL_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } - else - { - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = code; - if ((e != sc->rootlet) && - (is_let(e))) - set_curlet(sc, e); - else sc->curlet = sc->nil; - eval(sc, OP_EVAL); - } - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line) -{ - s7_pointer result; - if (caller) - { - sc->s7_call_name = caller; - sc->s7_call_file = file; - sc->s7_call_line = line; - } - result = s7_eval(sc, code, e); - if (caller) - { - sc->s7_call_name = NULL; - sc->s7_call_file = NULL; - sc->s7_call_line = -1; - } - return(result); -} - -static s7_pointer g_eval(s7_scheme *sc, s7_pointer args) -{ - #define H_eval "(eval code (let (curlet))) evaluates code in the environment let. 'let' \ -defaults to the curlet; to evaluate something in the top-level environment instead, \ -pass (rootlet):\n\ -\n\ - (define x 32) \n\ - (let ((x 3))\n\ - (eval 'x (rootlet)))\n\ -\n\ - returns 32" - #define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol) - - if (is_not_null(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->eval_symbol, 2, e, a_let_string); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - } - sc->code = car(args); - - if ((sc->safety > NO_SAFETY) && - (is_pair(sc->code))) - { - check_free_heap_size(sc, 8192); - sc->code = copy_body(sc, sc->code); - } - else - if (is_optimized(sc->code)) - clear_all_optimizations(sc, sc->code); /* clears "unsafe" ops, not all ops */ - - set_current_code(sc, sc->code); - if (current_stack_top(sc) < 12) - push_stack_op(sc, OP_BARRIER); - push_stack_direct(sc, OP_EVAL); - return(sc->nil); -} - - -s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) -{ - if (is_c_function(func)) - return(c_function_call(func)(sc, args)); /* no check for wrong-number-of-args -- is that reasonable? maybe use apply_c_function(sc, func, args) */ - { - declare_jump_info(); - TRACK(sc); - set_current_code(sc, history_cons(sc, func, args)); - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display(func), display_80(args))); - - sc->temp4 = T_App(func); /* this is feeble GC protection */ - sc->temp2 = T_Lst(args); /* only use of temp2 */ - - store_jump_info(sc); - set_jump_info(sc, S7_CALL_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - - if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ - (sc->stack_end == sc->stack_start)) - push_stack_op(sc, OP_ERROR_QUIT); - } - else - { - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_call", args); - push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ - sc->code = func; - sc->args = (needs_copied_args(func)) ? copy_proper_list(sc, args) : args; - eval(sc, OP_APPLY); - } - restore_jump_info(sc); - /* don't clear temp4 or temp2 here -- lots of (Snd) code calls s7_call repeatedly and assumes the "func" arg is protected between calls */ - return(sc->value); - } -} - -s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line) -{ - s7_pointer result; - if (caller) - { - sc->s7_call_name = caller; - sc->s7_call_file = file; - sc->s7_call_line = line; - } - result = s7_call(sc, func, args); - if (caller) - { - sc->s7_call_name = NULL; - sc->s7_call_file = NULL; - sc->s7_call_line = -1; - } - return(result); -} - - -/* -------------------------------- type-of -------------------------------- */ -#if (!WITH_GCC) -static inline bool gen_type_match(s7_scheme *sc, s7_pointer val, uint8_t typ) /* opt3_byte = uint8_t */ -{ - return((type(val) == typ) || - ((has_active_methods(sc, val)) && - (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != sc->F))); -} -#else -#define gen_type_match(Sc, Val, Typ) \ - ({s7_pointer _val_ = Val; \ - ((type(_val_) == Typ) || \ - ((has_active_methods(Sc, _val_)) && \ - (apply_boolean_method(Sc, _val_, Sc->type_to_typers[Typ]) != Sc->F)));}) -#endif - -static void init_typers(s7_scheme *sc) -{ - sc->type_to_typers[T_FREE] = sc->F; - sc->type_to_typers[T_PAIR] = sc->is_pair_symbol; - sc->type_to_typers[T_NIL] = sc->is_null_symbol; - sc->type_to_typers[T_UNUSED] = sc->F; - sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol; - sc->type_to_typers[T_UNDEFINED] = sc->is_undefined_symbol; - sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol; - sc->type_to_typers[T_BOOLEAN] = sc->is_boolean_symbol; - sc->type_to_typers[T_CHARACTER] = sc->is_char_symbol; - sc->type_to_typers[T_SYMBOL] = sc->is_symbol_symbol; /* and keyword? */ - sc->type_to_typers[T_SYNTAX] = sc->is_syntax_symbol; - sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol; - sc->type_to_typers[T_RATIO] = sc->is_rational_symbol; - sc->type_to_typers[T_REAL] = sc->is_float_symbol; - sc->type_to_typers[T_COMPLEX] = sc->is_complex_symbol; - sc->type_to_typers[T_BIG_INTEGER] = sc->is_integer_symbol; - sc->type_to_typers[T_BIG_RATIO] = sc->is_rational_symbol; - sc->type_to_typers[T_BIG_REAL] = sc->is_float_symbol; - sc->type_to_typers[T_BIG_COMPLEX] = sc->is_complex_symbol; - sc->type_to_typers[T_STRING] = sc->is_string_symbol; - sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol; - sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol; - sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol; - sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol; - sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol; - sc->type_to_typers[T_CATCH] = sc->F; - sc->type_to_typers[T_DYNAMIC_WIND] = sc->F; - sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol; - sc->type_to_typers[T_LET] = sc->is_let_symbol; - sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol; - sc->type_to_typers[T_STACK] = sc->F; - sc->type_to_typers[T_COUNTER] = sc->F; - sc->type_to_typers[T_SLOT] = sc->F; - sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol; - sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol; - sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol; - sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_symbol; - sc->type_to_typers[T_GOTO] = sc->is_goto_symbol; - sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol; - sc->type_to_typers[T_CLOSURE] = sc->is_procedure_symbol; - sc->type_to_typers[T_CLOSURE_STAR] = sc->is_procedure_symbol; - sc->type_to_typers[T_C_MACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_MACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_MACRO_STAR] = sc->is_macro_symbol; - sc->type_to_typers[T_BACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol; - sc->type_to_typers[T_C_FUNCTION] = sc->is_procedure_symbol; - sc->type_to_typers[T_C_FUNCTION_STAR] = sc->is_procedure_symbol; - sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION] = sc->is_procedure_symbol; -} - -s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg) {return(sc->type_to_typers[type(arg)]);} - -static s7_pointer g_type_of(s7_scheme *sc, s7_pointer args) -{ - #define H_type_of "(type-of obj) returns a symbol describing obj's type" - #define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T) - return(sc->type_to_typers[type(car(args))]); -} - - -/* -------------------------------- exit emergency-exit -------------------------------- */ -void s7_quit(s7_scheme *sc) -{ - sc->longjmp_ok = false; - pop_input_port(sc); - stack_reset(sc); - push_stack_op_let(sc, OP_EVAL_DONE); -} - -static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args) -{ - #define H_emergency_exit "(emergency-exit obj) exits s7 immediately" - #define Q_emergency_exit s7_make_signature(sc, 2, sc->T, sc->T) - - s7_pointer obj; -#ifndef EXIT_SUCCESS - #define EXIT_SUCCESS 0 - #define EXIT_FAILURE 1 -#endif - if (is_null(args)) - _exit(EXIT_SUCCESS); /* r7rs spec says use _exit here */ - obj = car(args); - if (obj == sc->F) - _exit(EXIT_FAILURE); - if ((obj == sc->T) || (!s7_is_integer(obj))) - _exit(EXIT_SUCCESS); - _exit((int)s7_integer_clamped_if_gmp(sc, obj)); - return(sc->F); -} - -static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) -{ - #define H_exit "(exit obj) exits s7" - #define Q_exit s7_make_signature(sc, 2, sc->T, sc->T) - /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? longjmp perhaps? */ - - s7_quit(sc); - if (show_gc_stats(sc)) - s7_warn(sc, 256, "gc calls %" ld64 " total time: %f\n", sc->gc_calls, (double)(sc->gc_total_time) / ticks_per_second()); - return(g_emergency_exit(sc, args)); -} - -#if WITH_GCC -static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort(); return(NULL);} -#endif - - -/* -------------------------------- optimizer stuff -------------------------------- */ -/* There is a problem with cache misses: a bigger cache reduces one test from 24 seconds to 17 (cachegrind agrees). - * But how to optimize s7 for cache hits? The culprits are eval and gc. Looking at the numbers, - * I think the least affected tests are able to use opt_info optimization which makes everything local? - */ - -#if S7_DEBUGGING -static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - if (let_slots(e) != lookup_slot_from(var, sc->curlet)) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(sc->curlet), - (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer t_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_t_1(sc, sc->curlet, func, expr, symbol); - return(slot_value(let_slots(sc->curlet))); -} - -static s7_pointer T_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_t_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(slot_value(let_slots(let_outlet(sc->curlet)))); -} - -static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - if (next_slot(let_slots(e)) != lookup_slot_from(var, sc->curlet)) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(e), - (tis_slot(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer u_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_u_1(sc, sc->curlet, func, expr, symbol); - return(slot_value(next_slot(let_slots(sc->curlet)))); -} - -static s7_pointer U_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_u_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(slot_value(next_slot(let_slots(let_outlet(sc->curlet))))); -} - -static void check_v_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - if (next_slot(next_slot(let_slots(e))) != lookup_slot_from(var, sc->curlet)) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(e), - (tis_slot(next_slot(next_slot(let_slots(e))))) ? display(next_slot(next_slot(let_slots(e)))) : "no next slot", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer v_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_v_1(sc, sc->curlet, func, expr, symbol); - return(slot_value(next_slot(next_slot(let_slots(sc->curlet))))); -} - -static s7_pointer V_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_v_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet)))))); -} - -static void check_o_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - s7_pointer slot = lookup_slot_from(var, sc->curlet); - if (lookup_slot_from(var, e) != slot) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(e), - (tis_slot(slot)) ? display(slot) : "undefined", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer o_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_o_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(inline_lookup_from(sc, symbol, let_outlet(sc->curlet))); -} - -#define t_lookup(Sc, Symbol, Expr) t_lookup_1(Sc, Symbol, __func__, Expr) -#define u_lookup(Sc, Symbol, Expr) u_lookup_1(Sc, Symbol, __func__, Expr) -#define v_lookup(Sc, Symbol, Expr) v_lookup_1(Sc, Symbol, __func__, Expr) -#define T_lookup(Sc, Symbol, Expr) T_lookup_1(Sc, Symbol, __func__, Expr) -#define U_lookup(Sc, Symbol, Expr) U_lookup_1(Sc, Symbol, __func__, Expr) -#define V_lookup(Sc, Symbol, Expr) V_lookup_1(Sc, Symbol, __func__, Expr) -#define o_lookup(Sc, Symbol, Expr) o_lookup_1(Sc, Symbol, __func__, Expr) -#else -#define t_lookup(Sc, Symbol, Expr) slot_value(let_slots(sc->curlet)) -#define u_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(sc->curlet))) -#define v_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(sc->curlet)))) -#define T_lookup(Sc, Symbol, Expr) slot_value(let_slots(let_outlet(sc->curlet))) -#define U_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(let_outlet(sc->curlet)))) -#define V_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet))))) -#define o_lookup(Sc, Symbol, Expr) inline_lookup_from(Sc, Symbol, let_outlet(Sc->curlet)) -#endif - -#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym) -#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym) - -/* arg here is the full expression */ -static s7_pointer fx_c(s7_scheme *sc, s7_pointer arg) {return(arg);} -static s7_pointer fx_q(s7_scheme *sc, s7_pointer arg) {return(cadr(arg));} -static s7_pointer fx_unsafe_s(s7_scheme *sc, s7_pointer arg) {return(lookup_checked(sc, T_Sym(arg)));} - -static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, T_Sym(arg)));} -static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? global_value(arg) : lookup(sc, arg));} -static s7_pointer fx_o(s7_scheme *sc, s7_pointer arg) {return(o_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_t(s7_scheme *sc, s7_pointer arg) {return(t_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_u(s7_scheme *sc, s7_pointer arg) {return(u_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_v(s7_scheme *sc, s7_pointer arg) {return(v_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_T(s7_scheme *sc, s7_pointer arg) {return(T_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg) {return(U_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_V(s7_scheme *sc, s7_pointer arg) {return(V_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_c_nc(s7_scheme *sc, s7_pointer arg) {return(fc_call(sc, arg));} -static s7_pointer fx_cons_cc(s7_scheme *sc, s7_pointer arg) {return(cons(sc, cadr(arg), caddr(arg)));} -static s7_pointer fx_curlet(s7_scheme *sc, s7_pointer arg) {return(sc->curlet);} - -#define fx_c_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(fn_proc(arg)(sc, with_list_t1(Lookup(sc, cadr(arg), arg)))); \ - } - -fx_c_any(fx_c_s, s_lookup) -fx_c_any(fx_c_g, g_lookup) -fx_c_any(fx_c_t, t_lookup) -fx_c_any(fx_c_u, u_lookup) -fx_c_any(fx_c_v, v_lookup) -fx_c_any(fx_c_o, o_lookup) -fx_c_any(fx_c_T, T_lookup) -fx_c_any(fx_c_V, V_lookup) - -static s7_pointer fx_c_g_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup_global(sc, cadr(arg))));} -static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg))));} -static s7_pointer fx_c_o_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, o_lookup(sc, cadr(arg), arg)));} -static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg)));} -static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg)));} -static s7_pointer fx_c_v_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, v_lookup(sc, cadr(arg), arg)));} - - -#define fx_car_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ - } - /* using car_p_p(val) here is exactly the same in speed according to callgrind */ - -fx_car_any(fx_car_s, s_lookup) -fx_car_any(fx_car_t, t_lookup) -fx_car_any(fx_car_u, u_lookup) -fx_car_any(fx_car_o, o_lookup) -fx_car_any(fx_car_T, T_lookup) -fx_car_any(fx_car_U, U_lookup) - - -#define fx_cdr_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ - } - -fx_cdr_any(fx_cdr_s, s_lookup) -fx_cdr_any(fx_cdr_t, t_lookup) -fx_cdr_any(fx_cdr_u, u_lookup) -fx_cdr_any(fx_cdr_v, v_lookup) -fx_cdr_any(fx_cdr_o, o_lookup) -fx_cdr_any(fx_cdr_T, T_lookup) -fx_cdr_any(fx_cdr_U, U_lookup) - - -#define fx_cadr_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return(((is_pair(val)) && (is_pair(cdr(val)))) ? cadr(val) : g_cadr(sc, set_plist_1(sc, val))); \ - } - -fx_cadr_any(fx_cadr_s, s_lookup) -fx_cadr_any(fx_cadr_t, t_lookup) -fx_cadr_any(fx_cadr_u, u_lookup) -fx_cadr_any(fx_cadr_o, o_lookup) - - -#define fx_cddr_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return(((is_pair(val)) && (is_pair(cdr(val)))) ? cddr(val) : g_cddr(sc, set_plist_1(sc, val))); \ - } - -fx_cddr_any(fx_cddr_s, s_lookup) -fx_cddr_any(fx_cddr_t, t_lookup) -fx_cddr_any(fx_cddr_u, u_lookup) -fx_cddr_any(fx_cddr_o, o_lookup) - - -#define fx_add_s1_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) + 1)); \ - return(g_add_x1_1(sc, x, 1)); /* arg=(+ x 1) */ \ - } - -fx_add_s1_any(fx_add_s1, s_lookup) -fx_add_s1_any(fx_add_t1, t_lookup) -fx_add_s1_any(fx_add_u1, u_lookup) -fx_add_s1_any(fx_add_v1, v_lookup) -fx_add_s1_any(fx_add_T1, T_lookup) -fx_add_s1_any(fx_add_U1, U_lookup) -fx_add_s1_any(fx_add_V1, V_lookup) - - -static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y) -{ - if ((S7_DEBUGGING) && (is_t_integer(val))) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val)); - switch (type(val)) - { - case T_REAL: return(make_boolean(sc, real(val) == y)); - case T_RATIO: - case T_COMPLEX: return(sc->F); -#if WITH_GMP - case T_BIG_INTEGER: return(make_boolean(sc, mpz_cmp_si(big_integer(val), y) == 0)); - case T_BIG_REAL: return(make_boolean(sc, mpfr_cmp_si(big_real(val), y) == 0)); - case T_BIG_RATIO: - case T_BIG_COMPLEX: return(sc->F); -#endif - default: return(method_or_bust_pp(sc, val, sc->num_eq_symbol, val, cadr(args), a_number_string, 1)); - } - return(sc->T); -} - -static s7_pointer fx_num_eq_s0f(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, cadr(arg)); - if (is_t_real(val)) return(make_boolean(sc, real(val) == 0.0)); - return(make_boolean(sc, num_eq_b_7pp(sc, val, real_zero))); -} - -#define fx_num_eq_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer args = cdr(arg); \ - s7_pointer val = Lookup(sc, car(args), arg); \ - s7_int y = integer(cadr(args)); \ - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : \ - ((is_t_real(val)) ? make_boolean(sc, real(val) == y) : fx_num_eq_xi_1(sc, args, val, y))); \ -} - -fx_num_eq_si_any(fx_num_eq_si, s_lookup) -fx_num_eq_si_any(fx_num_eq_ti, t_lookup) -fx_num_eq_si_any(fx_num_eq_ui, u_lookup) -fx_num_eq_si_any(fx_num_eq_vi, v_lookup) -fx_num_eq_si_any(fx_num_eq_Ti, T_lookup) -fx_num_eq_si_any(fx_num_eq_oi, o_lookup) - -#define fx_num_eq_s0_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : fx_num_eq_xi_1(sc, cdr(arg), val, 0)); \ - } - -fx_num_eq_s0_any(fx_num_eq_s0, s_lookup) -fx_num_eq_s0_any(fx_num_eq_t0, t_lookup) -fx_num_eq_s0_any(fx_num_eq_u0, u_lookup) -fx_num_eq_s0_any(fx_num_eq_v0, v_lookup) - -static s7_pointer fx_num_eq_0s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, caddr(arg)); - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : g_num_eq(sc, set_plist_2(sc, val, int_zero))); -} - - -static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg) -{ -#if WITH_GMP - return(g_random_i(sc, cdr(arg))); -#else - return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state)))); -#endif -} - -#if (!WITH_GMP) -static s7_pointer fx_add_i_random(s7_scheme *sc, s7_pointer arg) -{ - s7_int x = integer(cadr(arg)); - s7_int y = opt3_int(cdr(arg)); /* cadadr */ - return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ -} -#endif - -static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));} -static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));} - -#define fx_add_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) \ - { \ - if (HAVE_OVERFLOW_CHECKS) \ - { \ - s7_int val; \ - if (!add_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ - return(make_integer(sc, val)); \ - } \ - else return(make_integer(sc, integer(x) + integer(opt2_con(cdr(arg))))); \ - } \ - return(add_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ - } - -fx_add_si_any(fx_add_si, s_lookup) -fx_add_si_any(fx_add_ti, t_lookup) - -static s7_pointer fx_add_ss(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, s_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_ts(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_tu(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_ut(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_uv(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_us(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_vu(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, v_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} - -#define fx_subtract_s1_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \ - return(minus_c1(sc, x)); \ - } - -fx_subtract_s1_any(fx_subtract_s1, s_lookup) -fx_subtract_s1_any(fx_subtract_t1, t_lookup) -fx_subtract_s1_any(fx_subtract_u1, u_lookup) -fx_subtract_s1_any(fx_subtract_v1, v_lookup) -fx_subtract_s1_any(fx_subtract_T1, T_lookup) -fx_subtract_s1_any(fx_subtract_U1, U_lookup) - - -#define fx_subtract_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) \ - { \ - if (HAVE_OVERFLOW_CHECKS) \ - { \ - s7_int val; \ - if (!subtract_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ - return(make_integer(sc, val)); \ - } \ - else return(make_integer(sc, integer(x) - integer(opt2_con(cdr(arg))))); \ - } \ - return(subtract_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ - } - -fx_subtract_si_any(fx_subtract_si, s_lookup) -fx_subtract_si_any(fx_subtract_ti, t_lookup) -fx_subtract_si_any(fx_subtract_ui, u_lookup) - - -#define fx_subtract_sf_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_real(x)) \ - return(make_real(sc, real(x) - real(opt2_con(cdr(arg))))); /* caddr(arg) */ \ - return(g_subtract_2f(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_subtract_sf_any(fx_subtract_sf, s_lookup) -fx_subtract_sf_any(fx_subtract_tf, t_lookup) - - -#define fx_subtract_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) {return(subtract_p_pp(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg)));} - -fx_subtract_ss_any(fx_subtract_ss, s_lookup, s_lookup) -fx_subtract_ss_any(fx_subtract_ts, t_lookup, s_lookup) -fx_subtract_ss_any(fx_subtract_tu, t_lookup, u_lookup) -fx_subtract_ss_any(fx_subtract_ut, u_lookup, t_lookup) -fx_subtract_ss_any(fx_subtract_us, u_lookup, s_lookup) - - -static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg) -{ - s7_double n = real(cadr(arg)); - s7_pointer x = lookup(sc, opt2_sym(cdr(arg))); /* caddr(arg) */ - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, n - integer(x))); - case T_RATIO: return(make_real(sc, n - fraction(x))); - case T_REAL: return(make_real(sc, n - real(x))); - case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, cadr(arg), x)); -#endif - default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2)); - } - return(x); -} - -#define fx_is_eq_sc_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(make_boolean(sc, Lookup(sc, cadr(arg), arg) == opt2_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ \ - } - -fx_is_eq_sc_any(fx_is_eq_sc, s_lookup) -fx_is_eq_sc_any(fx_is_eq_tc, t_lookup) -fx_is_eq_sc_any(fx_is_eq_uc, u_lookup) - - -#define fx_is_eq_car_sq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer a = cdr(arg); \ - s7_pointer lst = Lookup(sc, opt3_sym(a), arg); \ - return(make_boolean(sc, (is_pair(lst)) ? (car(lst) == opt2_con(a)) : s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt2_con(a)))); \ - } - -fx_is_eq_car_sq_any(fx_is_eq_car_sq, s_lookup) -fx_is_eq_car_sq_any(fx_is_eq_car_tq, t_lookup) - - -static s7_pointer fx_is_eq_caar_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer a = cdr(arg); - s7_pointer lst = lookup(sc, opt3_sym(a)); - if ((is_pair(lst)) && (is_pair(car(lst)))) - return(make_boolean(sc, caar(lst) == opt2_con(a))); - return(make_boolean(sc, s7_is_eq(g_caar(sc, set_plist_1(sc, lst)), opt2_con(a)))); -} - -static s7_pointer fx_not_is_eq_car_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer lst = lookup(sc, opt1_sym(cdr(arg))); - if (is_pair(lst)) - return(make_boolean(sc, car(lst) != opt3_con(cdr(arg)))); - return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_con(cdr(arg))))); -} - -#define fx_is_pair_car_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return((is_pair(p)) ? make_boolean(sc, is_pair(car(p))) : g_is_pair(sc, set_plist_1(sc, g_car(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_car_s_any(fx_is_pair_car_s, s_lookup) -fx_is_pair_car_s_any(fx_is_pair_car_t, t_lookup) - - -#define fx_is_pair_cdr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return((is_pair(p)) ? make_boolean(sc, is_pair(cdr(p))) : g_is_pair(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_cdr_s_any(fx_is_pair_cdr_s, s_lookup) -fx_is_pair_cdr_s_any(fx_is_pair_cdr_t, t_lookup) -fx_is_pair_cdr_s_any(fx_is_pair_cdr_u, u_lookup) - - -#define fx_is_pair_cadr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cadr(p))) : g_is_pair(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_cadr_s_any(fx_is_pair_cadr_s, s_lookup) -fx_is_pair_cadr_s_any(fx_is_pair_cadr_t, t_lookup) - - -#define fx_is_pair_cddr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cddr(p))) : g_is_pair(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_cddr_s_any(fx_is_pair_cddr_s, s_lookup) -fx_is_pair_cddr_s_any(fx_is_pair_cddr_t, t_lookup) - - -#define fx_is_null_cdr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return((is_pair(p)) ? make_boolean(sc, is_null(cdr(p))) : g_is_null(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_null_cdr_s_any(fx_is_null_cdr_s, s_lookup) -fx_is_null_cdr_s_any(fx_is_null_cdr_t, t_lookup) - - -#define fx_is_null_cadr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cadr(p))) : g_is_null(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_null_cadr_s_any(fx_is_null_cadr_s, s_lookup) -fx_is_null_cadr_s_any(fx_is_null_cadr_t, t_lookup) - - -#define fx_is_null_cddr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cddr(p))) : g_is_null(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_null_cddr_s_any(fx_is_null_cddr_s, s_lookup) -fx_is_null_cddr_s_any(fx_is_null_cddr_t, t_lookup) - - -#define fx_is_symbol_cadr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_symbol(cadr(p))) : g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_s, s_lookup) -fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_t, t_lookup) - -static s7_pointer fx_is_symbol_car_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = t_lookup(sc, opt2_sym(cdr(arg)), arg); - return(make_boolean(sc, (is_pair(val)) ? is_symbol(car(val)) : is_symbol(g_car(sc, set_plist_1(sc, val))))); -} - -static s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = lookup(sc, opt2_sym(cdr(arg))); -#if WITH_GMP - if ((is_t_big_integer(p)) && - (mpz_cmp_ui(big_integer(p), 0) >= 0)) /* p >= 0 */ - { - mpz_sqrt(sc->mpz_1, big_integer(p)); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (!is_negative_b_7p(sc, p)) - return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_location(sc, p, sc->sqrt_symbol))))); -#endif - return(floor_p_p(sc, sqrt_p_p(sc, p))); -} - - -static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = u_lookup(sc, cadr(arg), arg); - if (is_t_integer(p1)) return(make_boolean(sc, integer(p1) > 0)); - return(make_boolean(sc, is_positive_b_7p(sc, p1))); -} - -static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_zero_b_7p(sc, u_lookup(sc, cadr(arg), arg))));} - -#define fx_real_part_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer z = Lookup(sc, cadr(arg), arg); \ - return((is_t_complex(z)) ? make_real(sc, real_part(z)) : real_part_p_p(sc, z)); \ - } - -fx_real_part_s_any(fx_real_part_s, s_lookup) -fx_real_part_s_any(fx_real_part_t, t_lookup) - -#define fx_imag_part_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer z = Lookup(sc, cadr(arg), arg); \ - return((is_t_complex(z)) ? make_real(sc, imag_part(z)) : imag_part_p_p(sc, z)); \ - } - -fx_imag_part_s_any(fx_imag_part_s, s_lookup) -fx_imag_part_s_any(fx_imag_part_t, t_lookup) /* not used in current timing tests */ - -#define fx_iterate_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer iter = Lookup(sc, cadr(arg), arg); \ - if (is_iterator(iter)) \ - return((iterator_next(iter))(sc, iter)); \ - return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); \ - } - -fx_iterate_s_any(fx_iterate_s, s_lookup) -fx_iterate_s_any(fx_iterate_o, o_lookup) -fx_iterate_s_any(fx_iterate_T, T_lookup) - - -static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, lookup(sc, cadr(arg))));} -static s7_pointer fx_length_t(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, t_lookup(sc, cadr(arg), arg)));} - -static s7_pointer fx_num_eq_length_i(s7_scheme *sc, s7_pointer arg) -{ - /* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */ - s7_int ilen = integer(opt2_con(cdr(arg))); /* is_t_integer checked in fx_choose */ - s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); - - switch (type(val)) - { - case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) == ilen)); - case T_NIL: return(make_boolean(sc, ilen == 0)); - case T_STRING: return(make_boolean(sc, string_length(val) == ilen)); - case T_HASH_TABLE: return(make_boolean(sc, (hash_table_mask(val) + 1) == ilen)); - case T_C_OBJECT: return(make_boolean(sc, c_object_length_to_int(sc, val) == ilen)); - case T_LET: return(make_boolean(sc, let_length(sc, val) == ilen)); - - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(make_boolean(sc, vector_length(val) == ilen)); - - case T_ITERATOR: - { - s7_pointer len = s7_length(sc, iterator_sequence(val)); - return(make_boolean(sc, (is_t_integer(len)) && (integer(len) == ilen))); - } - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (has_active_methods(sc, val)) - return(make_boolean(sc, closure_length(sc, val) == ilen)); - /* fall through */ - - default: - sole_arg_wrong_type_error_nr(sc, sc->length_symbol, val, a_sequence_string); - /* here we already lost because we checked for the length above */ - } - return(sc->F); -} - -static s7_pointer fx_less_length_i(s7_scheme *sc, s7_pointer arg) -{ - s7_int ilen = integer(opt2_con(cdr(arg))); /* caddr(arg) */ - s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */ - - switch (type(val)) - { - case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) < ilen)); - case T_NIL: return(make_boolean(sc, ilen > 0)); - case T_STRING: return(make_boolean(sc, string_length(val) < ilen)); - case T_HASH_TABLE: return(make_boolean(sc, (hash_table_mask(val) + 1) < ilen)); /* was <=? -- changed 15-Dec-15, then again 6-Jan-17: mask is len-1 */ - case T_C_OBJECT: return(make_boolean(sc, c_object_length_to_int(sc, val) < ilen)); - case T_LET: return(make_boolean(sc, let_length(sc, val) < ilen)); /* this works because let_length handles the length method itself! */ - - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(make_boolean(sc, vector_length(val) < ilen)); - - case T_ITERATOR: - { - s7_pointer len = s7_length(sc, iterator_sequence(val)); - return(make_boolean(sc, (is_t_integer(len)) && (integer(len) < ilen))); - } - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (has_active_methods(sc, val)) - return(make_boolean(sc, closure_length(sc, val) < ilen)); - /* fall through */ - - default: - sole_arg_wrong_type_error_nr(sc, sc->length_symbol, val, a_sequence_string); /* no check method here because we checked above */ - } - return(sc->F); -} - -static s7_pointer fx_is_null_s(s7_scheme *sc, s7_pointer arg) {return((is_null(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_o(s7_scheme *sc, s7_pointer arg) {return((is_null(o_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} /* very few hits */ -static s7_pointer fx_is_null_t(s7_scheme *sc, s7_pointer arg) {return((is_null(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_u(s7_scheme *sc, s7_pointer arg) {return((is_null(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_v(s7_scheme *sc, s7_pointer arg) {return((is_null(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_T(s7_scheme *sc, s7_pointer arg) {return((is_null(T_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_symbol_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer arg) {return((is_symbol(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_symbol_u(s7_scheme *sc, s7_pointer arg) {return((is_symbol(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_eof_s(s7_scheme *sc, s7_pointer arg) {return((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F);} -static s7_pointer fx_is_eof_t(s7_scheme *sc, s7_pointer arg) {return((t_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);} -static s7_pointer fx_is_eof_u(s7_scheme *sc, s7_pointer arg) {return((u_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);} -static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(lookup(sc, cadr(arg)))));} -static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(t_lookup(sc, cadr(arg), arg))));} -static s7_pointer fx_is_type_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(u_lookup(sc, cadr(arg), arg))));} -#if WITH_GMP -static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((s7_is_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -#else -static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) {return((is_t_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((is_t_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -#endif -static s7_pointer fx_is_string_s(s7_scheme *sc, s7_pointer arg) {return((is_string(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_string_t(s7_scheme *sc, s7_pointer arg) {return((is_string(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_procedure_s(s7_scheme *sc, s7_pointer arg) {return((is_procedure(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_procedure_t(s7_scheme *sc, s7_pointer arg) {return((is_procedure(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_keyword_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol_and_keyword(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_vector_s(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_vector_t(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_proper_list_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_proper_list(sc, lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_not_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, lookup(sc, cadr(arg)))));} -static s7_pointer fx_not_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, t_lookup(sc, cadr(arg), arg))));} -static s7_pointer fx_not_o(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, o_lookup(sc, cadr(arg), arg))));} -static s7_pointer fx_not_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_null_s(s7_scheme *sc, s7_pointer arg) {return((is_null(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_null_t(s7_scheme *sc, s7_pointer arg) {return((is_null(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_null_u(s7_scheme *sc, s7_pointer arg) {return((is_null(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_symbol_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_symbol_t(s7_scheme *sc, s7_pointer arg) {return((is_symbol(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} - -#define fx_c_sc_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, Lookup(sc, cadr(arg), arg)); \ - set_car(sc->t2_2, opt2_con(cdr(arg))); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_sc_any(fx_c_sc, s_lookup) -fx_c_sc_any(fx_c_tc, t_lookup) -fx_c_sc_any(fx_c_uc, u_lookup) /* few hits */ -fx_c_sc_any(fx_c_vc, v_lookup) -fx_c_sc_any(fx_c_oc, o_lookup) - - -static s7_pointer fx_c_sc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_c_si_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg)))));} -static s7_pointer fx_c_ti_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} -static s7_pointer fx_c_ti_remainder(s7_scheme *sc, s7_pointer arg) {return(remainder_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} -static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));} -static s7_pointer fx_vector_ref_tc(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} - /* tc happens a lot, but others almost never */ - -static s7_pointer fx_memq_sc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_memq_sc_3(s7_scheme *sc, s7_pointer arg) {return(memq_3_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_memq_tc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));} -static s7_pointer fx_leq_sc(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_lt_sc(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_gt_sc(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_geq_sc(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} - -#define fx_char_eq_sc_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer c = Lookup(sc, cadr(arg), arg); \ - if (c == opt2_con(cdr(arg))) return(sc->T); \ - if (is_character(c)) return(sc->F); \ - return(method_or_bust(sc, cadr(arg), sc->char_eq_symbol, cdr(arg), sc->type_names[T_CHARACTER], 1)); \ - } - -fx_char_eq_sc_any(fx_char_eq_sc, s_lookup) -fx_char_eq_sc_any(fx_char_eq_tc, t_lookup) - - -#define fx_c_cs_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, opt1_con(cdr(arg))); /* cadr(arg) or cadadr */ \ - set_car(sc->t2_2, Lookup(sc, opt2_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_cs_any(fx_c_cs, s_lookup) -fx_c_cs_any(fx_c_ct, t_lookup) -fx_c_cs_any(fx_c_cu, u_lookup) - - -static s7_pointer fx_c_ct_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, opt1_con(cdr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg))); -} - -static s7_pointer fx_cons_cs(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_ct(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} - - -#define fx_c_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(arg)), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ -} - -fx_c_ss_any(fx_c_ss, s_lookup, s_lookup) -fx_c_ss_any(fx_c_st, s_lookup, t_lookup) -fx_c_ss_any(fx_c_ts, t_lookup, s_lookup) -fx_c_ss_any(fx_c_tu, t_lookup, u_lookup) -fx_c_ss_any(fx_c_uv, u_lookup, v_lookup) -fx_c_ss_any(fx_c_tU, t_lookup, U_lookup) - -static s7_pointer fx_memq_ss(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_memq_tu(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_assq_ss(s7_scheme *sc, s7_pointer arg) {return(assq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_vref_ss(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_vref_st(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_ts(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_tu(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_ot(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_gt(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_string_ref_ss(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_ss(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_st(s7_scheme *sc, s7_pointer arg) {return(cons(sc, s_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_cons_ts(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_tu(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_cons_tU(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), U_lookup(sc, caddr(arg), arg)));} -/* static s7_pointer fx_cons_Ts(s7_scheme *sc, s7_pointer arg) {return(cons(sc, T_lookup(sc, cadr(arg), arg), s_lookup(sc, caddr(arg), arg)));} */ - -#define fx_c_ss_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \ - } - -fx_c_ss_direct_any(fx_c_ss_direct, s_lookup, s_lookup) -fx_c_ss_direct_any(fx_c_ts_direct, t_lookup, s_lookup) -fx_c_ss_direct_any(fx_c_tu_direct, t_lookup, u_lookup) -fx_c_ss_direct_any(fx_c_st_direct, s_lookup, t_lookup) -fx_c_ss_direct_any(fx_c_gt_direct, g_lookup, t_lookup) -fx_c_ss_direct_any(fx_c_tU_direct, t_lookup, U_lookup) - -static s7_pointer fx_multiply_ss(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_multiply_ts(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -/* static s7_pointer fx_multiply_Ts(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, T_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} */ -static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));} -static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_tf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_ui(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, u_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, opt2_sym(cdr(arg))), integer(cadr(arg)), 2));} -static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} - -static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x) -{ - if (is_t_real(x)) return(make_real(sc, real(x) * real(x))); - -#if WITH_GMP - return(multiply_p_pp(sc, x, x)); -#else - switch (type(x)) - { -#if HAVE_OVERFLOW_CHECKS - case T_INTEGER: - { - s7_int val; - if (multiply_overflow(integer(x), integer(x), &val)) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer sqr overflow: (* %" ld64 " %" ld64 ")\n", integer(x), integer(x)); - return(make_real(sc, (long_double)integer(x) * (long_double)integer(x))); - } - return(make_integer(sc, val)); - } - case T_RATIO: - { - s7_int num, den; - if ((multiply_overflow(numerator(x), numerator(x), &num)) || - (multiply_overflow(denominator(x), denominator(x), &den))) - return(make_real(sc, fraction(x) * fraction(x))); - return(make_ratio_with_div_check(sc, sc->multiply_symbol, num, den)); - } -#else - case T_INTEGER: return(make_integer(sc, integer(x) * integer(x))); - case T_RATIO: return(make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x))); -#endif - case T_REAL: return(make_real(sc, real(x) * real(x))); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x))); - default: return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, x, a_number_string, 1)); - } - return(x); -#endif -} - -static s7_pointer fx_sqr_s(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, lookup(sc, cadr(arg))));} -static s7_pointer fx_sqr_t(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, t_lookup(sc, cadr(arg), arg)));} - -static s7_pointer fx_add_sqr_sqr(s7_scheme *sc, s7_pointer arg) /* tbig -- need t case here */ -{ - sc->temp5 = fx_sqr_1(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */ - return(add_p_pp(sc, sc->temp5, fx_sqr_1(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */ -} - -static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer arg) /* call */ -{ - set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt2_sym(cdr(arg))))); /* cadaddr(arg) */ - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */ -{ - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt1_sym(cdr(arg))))); /* cadaddr(arg) */ - set_car(sc->t2_1, cadr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_geq_ss(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_st(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, u_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_vs(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_tT(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_geq_TU(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, T_lookup(sc, cadr(arg), arg), U_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_geq_to(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_geq_vo(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_geq_ot(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} - -static s7_pointer fx_gt_ss(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_gt_ts(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_gt_to(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_gt_ut(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_gt_tg(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), global_value(opt2_sym(cdr(arg)))));} - -static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = t_lookup(sc, cadr(arg), arg); - s7_pointer p2 = T_lookup(sc, caddr(arg), arg); - return(((is_t_integer(p1)) && (is_t_integer(p2))) ? make_boolean(sc, integer(p1) > integer(p2)) : gt_p_pp(sc, p1, p2)); -} - -#define fx_gt_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(opt2_con(cdr(arg))))); \ - if (is_t_real(x)) return(make_boolean(sc, real(x) > integer(opt2_con(cdr(arg))))); \ - return(g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_gt_si_any(fx_gt_si, s_lookup) -fx_gt_si_any(fx_gt_ti, t_lookup) -fx_gt_si_any(fx_gt_ui, u_lookup) - -static s7_pointer fx_leq_ss(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_leq_ts(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_leq_tu(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} - -#define fx_leq_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) <= integer(opt2_con(cdr(arg))))); \ - return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_leq_si_any(fx_leq_si, s_lookup) -fx_leq_si_any(fx_leq_ti, t_lookup) -fx_leq_si_any(fx_leq_ui, u_lookup) -fx_leq_si_any(fx_leq_vi, v_lookup) - -static s7_pointer fx_lt_ss(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_lt_sg(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup_global(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_lt_tg(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup_global(sc, opt2_sym(cdr(arg)))));} - -static s7_pointer fx_lt_gsg(s7_scheme *sc, s7_pointer arg) /* gsg is much faster than sss */ -{ - s7_pointer v1 = lookup_global(sc, cadr(arg)); - s7_pointer v2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */ - s7_pointer v3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */ - if ((is_t_integer(v1)) && (is_t_integer(v2)) && (is_t_integer(v3))) - return(make_boolean(sc, ((integer(v1) < integer(v2)) && (integer(v2) < integer(v3))))); - if (!is_real(v3)) - wrong_type_error_nr(sc, sc->lt_symbol, 3, v3, sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */ - return(make_boolean(sc, (lt_b_7pp(sc, v1, v2)) && (lt_b_7pp(sc, v2, v3)))); -} - -static s7_pointer fx_lt_ts(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_lt_tT(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, opt2_sym(cdr(arg)), cadr(arg))));} -static s7_pointer fx_lt_tu(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_lt_tU(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), U_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_lt_ut(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, caddr(arg), arg)));} - -static s7_pointer fx_lt_tf(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_real(x)) return(make_boolean(sc, real(x) < real(opt2_con(cdr(arg))))); - return(g_less_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ -} - -#define fx_lt_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt2_con(cdr(arg))))); \ - return(g_less_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_lt_si_any(fx_lt_si, s_lookup) -fx_lt_si_any(fx_lt_ti, t_lookup) - -static s7_pointer fx_lt_t0(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 0)); - return(g_less_xi(sc, set_plist_2(sc, x, int_zero))); -} - -static s7_pointer fx_lt_t1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 1)); - return(g_less_xi(sc, set_plist_2(sc, x, int_one))); -} - -static s7_pointer fx_lt_t2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 2)); - return(g_less_xi(sc, set_plist_2(sc, x, int_two))); -} - -static s7_pointer fx_geq_tf(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_real(x)) return(make_boolean(sc, real(x) >= real(opt2_con(cdr(arg))))); - return(g_geq_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ -} - -#define fx_geq_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt2_con(cdr(arg))))); \ - return(g_geq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_geq_si_any(fx_geq_si, s_lookup) -fx_geq_si_any(fx_geq_ti, t_lookup) - -static s7_pointer fx_geq_t0(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= 0)); - return(g_geq_xi(sc, set_plist_2(sc, x, int_zero))); -} - -#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup1(sc, cadr(arg), arg); \ - s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y))); \ - } - -fx_num_eq_ss_any(fx_num_eq_ss, s_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_ts, t_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_to, t_lookup, o_lookup) -fx_num_eq_ss_any(fx_num_eq_tg, t_lookup, g_lookup) -fx_num_eq_ss_any(fx_num_eq_tT, t_lookup, T_lookup) -fx_num_eq_ss_any(fx_num_eq_tu, t_lookup, u_lookup) -fx_num_eq_ss_any(fx_num_eq_tv, t_lookup, v_lookup) -fx_num_eq_ss_any(fx_num_eq_ut, u_lookup, t_lookup) -fx_num_eq_ss_any(fx_num_eq_us, u_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_vs, v_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_uU, u_lookup, U_lookup) -fx_num_eq_ss_any(fx_num_eq_vU, v_lookup, U_lookup) - - -#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup1(sc, cadr(arg), arg); \ - s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \ - } - -fx_is_eq_ss_any(fx_is_eq_ss, s_lookup, s_lookup) -fx_is_eq_ss_any(fx_is_eq_ts, t_lookup, s_lookup) -fx_is_eq_ss_any(fx_is_eq_tu, t_lookup, u_lookup) -fx_is_eq_ss_any(fx_is_eq_to, t_lookup, o_lookup) - - -static s7_pointer fx_not_is_eq_ss(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = lookup(sc, opt3_sym(arg)); - s7_pointer y = lookup(sc, opt1_sym(cdr(arg))); - return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); -} - -static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = lookup(sc, opt2_sym(cdr(arg))); - s7_pointer y = opt3_con(cdr(arg)); - return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); -} - -static s7_pointer x_hash_table_ref_ss(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return((is_hash_table(table)) ? hash_entry_value((*hash_table_checker(table))(sc, table, key)) : g_hash_table_ref(sc, set_plist_2(sc, table, key))); -} - -static s7_pointer fx_hash_table_ref_ss(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_hash_table_ref_st(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_hash_table_ref_TV(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, T_lookup(sc, cadr(arg), arg), V_lookup(sc, opt2_sym(cdr(arg)), arg)));} - -static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer table = lookup(sc, cadr(arg)); - s7_pointer lst = lookup(sc, opt2_sym(cdr(arg))); - if (!is_pair(lst)) - sole_arg_wrong_type_error_nr(sc, sc->car_symbol, lst, sc->type_names[T_PAIR]); - return((is_hash_table(table)) ? hash_entry_value((*hash_table_checker(table))(sc, table, car(lst))) : g_hash_table_ref(sc, set_plist_2(sc, table, car(lst)))); -} - - -static inline s7_pointer fx_hash_table_increment_1(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer arg) -{ - hash_entry_t *val; - if (!is_hash_table(table)) - return(mutable_method_or_bust_ppp(sc, table, sc->hash_table_set_symbol, table, key, fx_call(sc, cdddr(arg)), sc->type_names[T_HASH_TABLE], 1)); - val = (*hash_table_checker(table))(sc, table, key); - if (val != sc->unentry) - { - if (!is_t_integer(hash_entry_value(val))) - sole_arg_wrong_type_error_nr(sc, sc->add_symbol, cadddr(arg), sc->type_names[T_INTEGER]); - hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1)); - return(hash_entry_value(val)); - } - s7_hash_table_set(sc, table, key, int_one); - return(int_one); -} - -static s7_pointer fx_hash_table_increment(s7_scheme *sc, s7_pointer arg) -{ - return(fx_hash_table_increment_1(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)), arg)); -} - - -static s7_pointer fx_lint_let_ref_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer sym; - s7_pointer lt = s_lookup(sc, opt2_sym(arg), arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ - if (!is_pair(lt)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~S should be (cons name let), but it is ~S", 42), opt2_sym(arg), lt)); - lt = cdr(lt); - if (!is_let(lt)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); - sym = opt2_sym(cdr(arg)); /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */ - for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - return(lint_let_ref_p_pp(sc, let_outlet(lt), sym)); -} - -static s7_pointer fx_memq_sq_2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = opt2_con(cdr(arg)); - s7_pointer obj = lookup(sc, cadr(arg)); - if (obj == car(p)) return(p); - return((obj == cadr(p)) ? cdr(p) : sc->F); -} - -static s7_pointer fx_c_cq(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t2(cadr(arg), opt2_con(cdr(arg)))));} - -#define fx_c_sss_any(Name, Lookup1, Lookup2, Lookup3) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - set_car(sc->t3_3, Lookup3(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_sss_any(fx_c_sss, s_lookup, s_lookup, s_lookup) -fx_c_sss_any(fx_c_sts, s_lookup, t_lookup, s_lookup) -fx_c_sss_any(fx_c_tus, t_lookup, u_lookup, s_lookup) -fx_c_sss_any(fx_c_tuv, t_lookup, u_lookup, v_lookup) - - -static s7_pointer fx_c_sss_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg))), lookup(sc, opt2_sym(cdr(arg))))); -} - -static s7_pointer fx_c_tuv_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt1_sym(cdr(arg)), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg))); -} - -static s7_pointer fx_vset_sts(s7_scheme *sc, s7_pointer arg) -{ - return(vector_set_p_ppp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt1_sym(cdr(arg)), arg), lookup(sc, opt2_sym(cdr(arg))))); -} - -static s7_pointer fx_vset_oto(s7_scheme *sc, s7_pointer arg) -{ - return(vector_set_p_ppp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt1_sym(cdr(arg)), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg))); -} - -#define fx_c_scs_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_scs_any(fx_c_scs, s_lookup, s_lookup) -fx_c_scs_any(fx_c_tcs, t_lookup, s_lookup) - - -#define fx_c_scs_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), opt1_con(cdr(arg)), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \ - } - -fx_c_scs_direct_any(fx_c_scs_direct, s_lookup, s_lookup) -fx_c_scs_direct_any(fx_c_tcu_direct, t_lookup, u_lookup) -fx_c_scs_direct_any(fx_c_tcs_direct, t_lookup, s_lookup) -fx_c_scs_direct_any(fx_c_TcU_direct, T_lookup, U_lookup) - - -static s7_pointer fx_c_scc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ - set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ - return(fn_proc(arg)(sc, sc->t3_1)); -} - -#define fx_c_css_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_2, Lookup1(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ - set_car(sc->t3_1, cadr(arg)); \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_css_any(fx_c_css, s_lookup, s_lookup) -fx_c_css_any(fx_c_ctv, t_lookup, v_lookup) - -static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */ - set_car(sc->t3_1, opt3_con(cdr(arg))); /* cadr(arg) or maybe cadadr if quoted? */ - set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_ccs(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, lookup(sc, opt1_sym(cdr(arg)))); /* cadddr(arg) */ - set_car(sc->t3_1, cadr(arg)); /* maybe opt3_con? */ - set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */ - return(fn_proc(arg)(sc, sc->t3_1)); -} - -#define fx_c_ssc_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_ssc_any(fx_c_ssc, s_lookup, s_lookup) -fx_c_ssc_any(fx_c_tuc, t_lookup, u_lookup) - -static s7_pointer fx_c_opncq(s7_scheme *sc, s7_pointer arg) -{ - return(fn_proc(arg)(sc, with_list_t1(fc_call(sc, cadr(arg))))); -} - -#define fx_c_opsq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t1_1, fn_proc(largs)(sc, with_list_t1(Lookup(sc, cadr(largs), largs)))); \ - return(fn_proc(arg)(sc, sc->t1_1)); \ - } - -fx_c_opsq_any(fx_c_opsq, s_lookup) -fx_c_opsq_any(fx_c_optq, t_lookup) - -static s7_pointer fx_c_optq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)))); -} - -#define fx_c_car_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - set_car(sc->t1_1, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ - return(fn_proc(arg)(sc, sc->t1_1)); \ - } - -fx_c_car_s_any(fx_c_car_s, s_lookup) -fx_c_car_s_any(fx_c_car_t, t_lookup) -fx_c_car_s_any(fx_c_car_u, u_lookup) - -#define fx_c_cdr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - set_car(sc->t1_1, (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ - return(fn_proc(arg)(sc, sc->t1_1)); \ - } - -fx_c_cdr_s_any(fx_c_cdr_s, s_lookup) -fx_c_cdr_s_any(fx_c_cdr_t, t_lookup) - -#define fx_is_type_opsq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t1_1, Lookup(sc, opt2_sym(cdr(arg)), arg)); \ - return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(fn_proc(cadr(arg))(sc, sc->t1_1)))); \ - } - -fx_is_type_opsq_any(fx_is_type_opsq, s_lookup) -fx_is_type_opsq_any(fx_is_type_optq, t_lookup) - -static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, opt2_sym(cdr(arg))); - return(make_boolean(sc, (is_pair(val)) ? - ((uint8_t)(opt3_byte(cdr(arg))) == type(car(val))) : - ((uint8_t)(opt3_byte(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val)))))); -} - -static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer func, val = t_lookup(sc, opt2_sym(cdr(arg)), arg); - if (is_pair(val)) - return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val)))); - if (!has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */ - wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); - func = find_method_with_let(sc, val, sc->car_symbol); - if (func == sc->undefined) - wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); - return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); -} - -static s7_pointer fx_eq_weak1_type_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer func, val = lookup(sc, opt2_sym(cdr(arg))); - if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */ - return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_pointer_weak1(val)))); - if (!has_active_methods(sc, val)) /* calling g_c_pointer_weak1 here instead is much slower, error by itself is much faster! splitting out does not help */ - wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]); - func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol); - if (func == sc->undefined) - wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]); - return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); -} - -#define fx_not_opsq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t1_1, Lookup(sc, cadr(largs), arg)); \ - return((fn_proc(largs)(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); \ - } - -fx_not_opsq_any(fx_not_opsq, s_lookup) -fx_not_opsq_any(fx_not_optq, t_lookup) - -static s7_pointer fx_not_car_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr */ - s7_pointer res = (is_pair(p)) ? car(p) : g_car(sc, set_plist_1(sc, p)); - return((res == sc->F) ? sc->T : sc->F); -} - - -#define fx_c_opssq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, Lookup1(sc, opt3_sym(arg), arg)); \ - set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* or opt2_sym */ \ - return(fn_proc(arg)(sc, with_list_t1(fn_proc(cadr(arg))(sc, sc->t2_1)))); \ - } - -fx_c_opssq_any(fx_c_opssq, s_lookup, s_lookup) -fx_c_opssq_any(fx_c_optuq, t_lookup, u_lookup) -fx_c_opssq_any(fx_c_opstq, s_lookup, t_lookup) - - -#define fx_c_opssq_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, \ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt3_sym(arg), arg), Lookup2(sc, opt1_sym(cdr(arg)), arg)))); \ - } - -fx_c_opssq_direct_any(fx_c_opssq_direct, s_lookup, s_lookup) -fx_c_opssq_direct_any(fx_c_opstq_direct, s_lookup, t_lookup) -fx_c_opssq_direct_any(fx_c_optuq_direct, t_lookup, u_lookup) - - -#define fx_not_opssq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer larg = cadr(arg); \ - set_car(sc->t2_1, Lookup1(sc, cadr(larg), larg)); \ - set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(larg)), larg)); \ - return((fn_proc(larg)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \ - } - -fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup) -fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup) - - -static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer y = u_lookup(sc, opt3_sym(arg), arg); - s7_pointer x = t_lookup(sc, opt1_sym(cdr(arg)), arg); - return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(y) >= integer(x)) : geq_b_7pp(sc, y, x))); -} - -static s7_pointer fx_is_zero_remainder_car(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg); - s7_pointer u = u_lookup(sc, opt3_sym(arg), arg); - u = (is_pair(u)) ? car(u) : g_car(sc, set_plist_1(sc, u)); /* g_car much less overhead than car_p_p or simple_error(?) */ - if ((is_t_integer(u)) && (is_t_integer(t))) - return(make_boolean(sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0)); - return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t)))); -} - -static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer s = o_lookup(sc, opt3_sym(arg), arg); - s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg); - if ((is_t_integer(s)) && (is_t_integer(t))) - return(make_boolean(sc, remainder_i_7ii(sc, integer(s), integer(t)) == 0)); - return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, s, t)))); -} - -#define fx_c_opscq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t2_1, Lookup(sc, cadr(largs), largs)); \ - set_car(sc->t2_2, opt2_con(cdr(largs))); \ - return(fn_proc(arg)(sc, with_list_t1(fn_proc(largs)(sc, sc->t2_1)))); \ - } - -fx_c_opscq_any(fx_c_opscq, s_lookup) -fx_c_opscq_any(fx_c_optcq, t_lookup) - -static s7_pointer fx_is_zero_remainder_ti(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer larg = cdadr(arg); - s7_pointer t = t_lookup(sc, car(larg), arg); - s7_int u = integer(cadr(larg)); - if (is_t_integer(t)) return(make_boolean(sc, (integer(t) % u) == 0)); - return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pi(sc, t, u)))); -} - -static s7_pointer fx_not_opscq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - return((fn_proc(largs)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_c_opcsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - return(fn_proc(arg)(sc, with_list_t1(fn_proc(largs)(sc, sc->t2_1)))); -} - -static s7_pointer fx_c_opcsq_c(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, caddr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opcsq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, caddr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, caddr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), - lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - s7_pointer a = lookup(sc, car(largs)); - s7_pointer b = lookup(sc, opt2_sym(largs)); - s7_pointer c = lookup(sc, caddr(arg)); - if ((is_t_integer(a)) && (is_t_integer(b)) && (is_t_integer(c))) -#if HAVE_OVERFLOW_CHECKS - { - s7_int val; - if ((multiply_overflow(integer(a), integer(b), &val)) || - (add_overflow(val, integer(c), &val))) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply/add overflow: (+ (* %" ld64 " %" ld64 ") %" ld64 ")\n", integer(a), integer(b), integer(c)); - return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c))); - } - return(make_integer(sc, val)); - } -#else - return(make_integer(sc, (integer(a) * integer(b)) + integer(c))); -#endif - return(add_p_pp(sc, multiply_p_pp(sc, a, b), c)); -} - -static s7_pointer fx_add_vref_s(s7_scheme *sc, s7_pointer arg) -{ - return(add_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_add_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(add_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_subtract_vref_s(s7_scheme *sc, s7_pointer arg) -{ - return(subtract_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_subtract_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(subtract_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_multiply_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(multiply_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_cons_cons_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - return(cons_unchecked(sc, cons(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); -} - -#define fx_add_sqr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p1 = Lookup(sc, car(opt3_pair(arg)), arg); \ - s7_pointer p3 = lookup(sc, caddr(arg)); \ - if ((is_t_complex(p1)) && (is_t_complex(p3))) \ - { \ - s7_double r = real_part(p1), i = imag_part(p1); \ - return(make_complex(sc, real_part(p3) + r * r - i * i, imag_part(p3) + 2.0 * r * i)); \ - } \ - return(add_p_pp(sc, fx_sqr_1(sc, p1), p3)); \ - } - -fx_add_sqr_s_any(fx_add_sqr_s, s_lookup) -fx_add_sqr_s_any(fx_add_sqr_T, T_lookup) - -static s7_pointer fx_add_sub_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - s7_pointer p1 = lookup(sc, car(largs)); - s7_pointer p2 = lookup(sc, opt2_sym(largs)); - s7_pointer p3 = lookup(sc, caddr(arg)); - if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) return(make_real(sc, real(p3) + real(p1) - real(p2))); - return(add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3)); -} - -static s7_pointer fx_add_sub_tu_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = t_lookup(sc, car(cdadr(arg)), arg); - s7_pointer p2 = u_lookup(sc, cadr(cdadr(arg)), arg); - s7_pointer p3 = lookup(sc, caddr(arg)); - if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) return(make_real(sc, real(p3) + real(p1) - real(p2))); - return(add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3)); -} - -static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - s7_pointer x1 = lookup(sc, car(largs)); - s7_pointer x2 = lookup(sc, opt2_sym(largs)); - s7_pointer x3 = lookup(sc, caddr(arg)); - if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) return(make_boolean(sc, (real(x1) + real(x2)) > real(x3))); - return(gt_p_pp(sc, add_p_pp(sc, x1, x2), x3)); -} - -static s7_pointer fx_gt_add_tu_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x1 = t_lookup(sc, car(cdadr(arg)), arg); - s7_pointer x2 = u_lookup(sc, cadr(cdadr(arg)), arg); - s7_pointer x3 = lookup(sc, caddr(arg)); - if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) return(make_boolean(sc, (real(x1) + real(x2)) > real(x3))); - return(gt_p_pp(sc, add_p_pp(sc, x1, x2), x3)); -} - -static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg) -{ - return(gt_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(geq_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(make_boolean(sc, lookup(sc, cadr(arg)) == vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(hash_table_ref_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(let_ref(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), add_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer p1, s7_pointer p2) -{ - if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) - { - s7_int i1 = integer(p1), i2 = integer(p2); - if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1))) - { - s7_pointer v2 = vector_element(v1, i1); - if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i2 < vector_length(v2))) - return(vector_element(v2, i2)); - }} - return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2)); -} - -#define fx_vref_vref_ss_s_any(Name, Lookup1, Lookup2, Lookup3) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(fx_vref_vref_3(sc, Lookup1(sc, car(opt3_pair(arg)), arg), Lookup2(sc, opt2_sym(opt3_pair(arg)), arg), Lookup3(sc, caddr(arg), arg))); \ - } - -fx_vref_vref_ss_s_any(fx_vref_vref_ss_s, s_lookup, s_lookup, s_lookup) -fx_vref_vref_ss_s_any(fx_vref_vref_gs_t, g_lookup, s_lookup, t_lookup) -fx_vref_vref_ss_s_any(fx_vref_vref_go_t, g_lookup, o_lookup, t_lookup) -fx_vref_vref_ss_s_any(fx_vref_vref_tu_v, t_lookup, u_lookup, v_lookup) - -static s7_pointer fx_vref_vref_3_no_let(s7_scheme *sc, s7_pointer code) /* out one level from vref_vref_tu_v */ -{ - return(fx_vref_vref_3(sc, lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)))); -} - -static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, caddr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t2_1, Lookup1(sc, cadr(largs), largs)); \ - set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(largs)), largs)); \ - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); \ - set_car(sc->t2_2, opt3_con(cdr(arg))); /* caddr */ \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_opssq_c_any(fx_c_opssq_c, s_lookup, s_lookup) -fx_c_opssq_c_any(fx_c_opstq_c, s_lookup, t_lookup) - - -static s7_pointer fx_c_opstq_c_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - return(((s7_p_pp_t)opt3_direct(arg))(sc, fn_proc(largs)(sc, set_plist_2(sc, lookup(sc, cadr(largs)), t_lookup(sc, caddr(largs), arg))), opt3_con(cdr(arg)))); -} - -static s7_pointer fx_is_eq_vref_opotq_c(s7_scheme *sc, s7_pointer arg) /* experiment, (eqv? <> char) is <>==char without error checks? */ -{ - s7_pointer largs = cdadr(arg); - return(make_boolean(sc, vector_ref_p_pp(sc, o_lookup(sc, car(largs), largs), t_lookup(sc, cadr(largs), arg)) == opt3_con(cdr(arg)))); -} - -#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t2_1, fn_proc(largs)(sc, with_list_t1(Lookup1(sc, cadr(largs), arg)))); /* also opt1_sym(cdr(arg)) */ \ - set_car(sc->t2_2, Lookup2(sc, opt3_sym(arg), arg)); /* caddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_opsq_s_any(fx_c_opsq_s, s_lookup, s_lookup) -fx_c_opsq_s_any(fx_c_optq_s, t_lookup, s_lookup) -fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup) - - -#define fx_c_opsq_s_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, \ - ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt1_sym(cdr(arg)), arg)), \ - Lookup2(sc, opt3_sym(arg), arg))); \ - } - -fx_c_opsq_s_direct_any(fx_c_opsq_s_direct, s_lookup, s_lookup) -fx_c_opsq_s_direct_any(fx_c_optq_s_direct, t_lookup, s_lookup) -fx_c_opsq_s_direct_any(fx_c_opuq_t_direct, u_lookup, t_lookup) - -#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ - if (is_pair(p)) return(cons(sc, car(p), Lookup2(sc, opt3_sym(arg), arg))); \ - return(cons(sc, car_p_p(sc, p), Lookup2(sc, opt3_sym(arg), arg))); \ - } - -fx_cons_car_s_s_any(fx_cons_car_s_s, s_lookup, s_lookup) -fx_cons_car_s_s_any(fx_cons_car_t_s, t_lookup, s_lookup) -fx_cons_car_s_s_any(fx_cons_car_t_v, t_lookup, v_lookup) -fx_cons_car_s_s_any(fx_cons_car_u_t, u_lookup, t_lookup) - - -static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer arg) -{ - return(cons(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, u_lookup(sc, opt1_sym(cdr(arg)), arg)), t_lookup(sc, opt3_sym(arg), arg))); -} - -#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup1(sc, opt3_sym(cdr(arg)), arg)))); /* cadadr(arg); */ \ - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ \ - set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg); */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_opsq_cs_any(fx_c_opsq_cs, s_lookup, s_lookup) -fx_c_opsq_cs_any(fx_c_optq_cu, t_lookup, u_lookup) - - -#define fx_c_opsq_c_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup(sc, opt1_sym(cdr(arg)), arg)))); /* cadadr */ \ - set_car(sc->t2_2, opt2_con(cdr(arg))); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_opsq_c_any(fx_c_opsq_c, s_lookup) -fx_c_opsq_c_any(fx_c_optq_c, t_lookup) - - -static s7_pointer fx_c_optq_c_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), opt2_con(cdr(arg)))); -} - -static s7_pointer fx_c_optq_i_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ii_t)opt3_direct(arg))(sc, ((s7_i_7p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), integer(opt2_con(cdr(arg))))); -} - -static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = opt2_con(cdr(arg)); - s7_pointer obj = lookup(sc, opt1_sym(cdr(arg))); - obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); - while (true) LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - return(sc->F); -} - -static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = opt2_con(cdr(arg)); - s7_pointer obj = lookup(sc, opt1_sym(cdr(arg))); - obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); - if (obj == car(x)) return(x); - return((obj == cadr(x)) ? cdr(x) : sc->F); -} - -static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t2(lookup(sc, cadr(largs)), lookup(sc, opt2_sym(cdr(largs)))))); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = opt3_pair(arg); /* cdaddr(arg) */ \ - arg = cdr(arg); \ - return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), \ - ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), Lookup2(sc, opt2_sym(largs), largs)))); \ - } - -fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup) -fx_c_s_opssq_direct_any(fx_c_s_opstq_direct, s_lookup, t_lookup) -fx_c_s_opssq_direct_any(fx_c_t_opsuq_direct, t_lookup, u_lookup) - -static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), t_lookup(sc, opt2_sym(opt3_pair(arg)), arg)))); -} - -static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t2(lookup(sc, cadr(largs)), lookup(sc, opt2_sym(cdr(largs)))))); - set_car(sc->t2_1, cadr(arg)); /* currently ( 'a ) goes to safe_c_ca so this works by inadvertence */ - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), /* see above */ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg)))))); -} - -static s7_pointer fx_c_nc_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */ -{ - s7_double x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, opt3_sym(arg)), real_to_double(sc, lookup(sc, opt1_sym(cdr(arg))), __func__)); - return(((s7_p_dd_t)opt2_direct(cdr(arg)))(sc, real_to_double(sc, cadr(arg), __func__), x2)); -} - -static s7_pointer fx_multiply_c_opssq(s7_scheme *sc, s7_pointer arg) /* (* c=float (* x1 x2))! */ -{ - s7_pointer x1 = lookup(sc, opt3_sym(arg)); - s7_pointer x2 = lookup(sc, opt1_sym(cdr(arg))); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(cadr(arg)) * real(x1) * real(x2))); - return(multiply_p_pp(sc, cadr(arg), multiply_p_pp(sc, x1, x2))); -} - -#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = caddr(arg); \ - set_car(sc->t2_1, Lookup2(sc, cadr(largs), arg)); \ - set_car(sc->t2_2, opt2_con(cdr(largs))); \ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_s_opscq_any(fx_c_s_opscq, s_lookup, s_lookup) -fx_c_s_opscq_any(fx_c_u_optcq, u_lookup, t_lookup) -/* also fx_c_T_optcq */ - -static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg))))); -} - -static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), integer(opt1_con(cdr(arg)))))); -} - -static s7_pointer fx_c_u_optiq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); -} - -static s7_pointer fx_c_t_opoiq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, o_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); -} - -static s7_pointer fx_vref_p1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer i = lookup(sc, opt3_sym(arg)); - s7_pointer v = lookup(sc, cadr(arg)); - if ((is_t_integer(i)) && (is_normal_vector(v)) && (vector_rank(v) == 1)) - { - s7_int index = integer(i) + 1; - if ((index >= 0) && (vector_length(v) > index)) - return(vector_element(v, index)); - } - return(vector_ref_p_pp(sc, v, g_add_xi(sc, i, 1, 2))); -} - -static s7_pointer fx_num_eq_add_s_si(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer i1 = lookup(sc, cadr(arg)); - s7_pointer i2 = lookup(sc, opt3_sym(arg)); - if ((is_t_integer(i1)) && (is_t_integer(i2))) - return(make_boolean(sc, integer(i1) == (integer(i2) + integer(opt1_con(cdr(arg)))))); - return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_add_xi(sc, i2, integer(opt1_con(cdr(arg))), 2)))); -} - -static s7_pointer fx_num_eq_subtract_s_si(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer i1 = lookup(sc, cadr(arg)); - s7_pointer i2 = lookup(sc, opt3_sym(arg)); - if ((is_t_integer(i1)) && (is_t_integer(i2))) - return(make_boolean(sc, integer(i1) == (integer(i2) - integer(opt1_con(cdr(arg)))))); - return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_sub_xi(sc, i2, integer(opt1_con(cdr(arg))))))); -} - -#define fx_c_t_opscq_direct_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), \ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), opt1_con(cdr(arg))))); \ - } - -fx_c_t_opscq_direct_any(fx_c_t_opscq_direct, s_lookup) -fx_c_t_opscq_direct_any(fx_c_t_opucq_direct, u_lookup) - - -static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_s_opsq_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - arg = cdr(arg); \ - return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_p_t)opt3_direct(arg))(sc, Lookup2(sc, opt1_sym(arg), arg)))); /* cadadr */ \ - } - -fx_c_s_opsq_direct_any(fx_c_s_opsq_direct, s_lookup, s_lookup) -fx_c_s_opsq_direct_any(fx_c_t_opsq_direct, t_lookup, s_lookup) -fx_c_s_opsq_direct_any(fx_c_t_opuq_direct, t_lookup, u_lookup) -fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup) - -#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_s_car_s_any(fx_c_s_car_s, s_lookup, s_lookup) -fx_c_s_car_s_any(fx_c_s_car_t, s_lookup, t_lookup) -fx_c_s_car_s_any(fx_c_t_car_u, t_lookup, u_lookup) -fx_c_s_car_s_any(fx_c_t_car_v, t_lookup, v_lookup) - - -#define fx_add_s_car_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val1 = Lookup1(sc, cadr(arg), arg); \ - s7_pointer val2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - val2 = (is_pair(val2)) ? car(val2) : g_car(sc, set_plist_1(sc, val2)); \ - return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2)); \ - } - -fx_add_s_car_s_any(fx_add_s_car_s, s_lookup, s_lookup) -fx_add_s_car_s_any(fx_add_u_car_t, u_lookup, t_lookup) -fx_add_s_car_s_any(fx_add_t_car_v, t_lookup, v_lookup) - - -static s7_pointer fx_cons_s_cdr_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, opt2_sym(cdr(arg))); - val = (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val)); - return(cons(sc, lookup(sc, cadr(arg)), val)); -} - -static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = caddr(outer); - set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args))))); - set_car(sc->t2_1, lookup(sc, cadr(outer))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(outer)(sc, sc->t2_1)))); -} - -static s7_pointer fx_not_op_s_opsqq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = caddr(outer); - set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args))))); - set_car(sc->t2_1, lookup(sc, cadr(outer))); - return(((fn_proc(outer)(sc, sc->t2_1)) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = cadr(outer); - set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args))))); - set_car(sc->t2_2, lookup(sc, caddr(outer))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(outer)(sc, sc->t2_1)))); -} - -static s7_pointer fx_not_op_optq_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = cadr(outer); - set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(t_lookup(sc, cadr(args), arg)))); - set_car(sc->t2_2, lookup(sc, caddr(outer))); - return((fn_proc(outer)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* caddr(arg); */ - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, cadr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_c_opsq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))))); -} - -/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */ - -static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs))))); - largs = cadr(largs); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(arg))(sc, - ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadadr(arg))), /* no free field in arg or cdr(arg) */ - ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */ -} - -static s7_pointer fx_c_optq_optq_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr and cadaddr */ - return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, x), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, x))); -} - -#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p1 = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ - s7_pointer p2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); /* cadaddr(arg) */ \ - return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)), \ - (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)))); \ - } - -fx_car_s_car_s_any(fx_car_s_car_s, s_lookup, s_lookup) -fx_car_s_car_s_any(fx_car_t_car_u, t_lookup, u_lookup) - - -static s7_pointer fx_cdr_s_cdr_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = lookup(sc, opt1_sym(cdr(arg))); - s7_pointer p2 = lookup(sc, opt2_sym(cdr(arg))); /* cadaddr(arg) */ - return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? cdr(p1) : g_cdr(sc, set_plist_1(sc, p1)), - (is_pair(p2)) ? cdr(p2) : g_cdr(sc, set_plist_1(sc, p2)))); -} - -static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = t_lookup(sc, opt1_sym(cdr(arg)), arg); - s7_pointer p2 = u_lookup(sc, opt2_sym(cdr(arg)), arg); - p1 = (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)); - p2 = (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)); - return(make_boolean(sc, (p1 == p2) || ((is_unspecified(p1)) && (is_unspecified(p2))))); -} - -static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs))))); - largs = cadr(largs); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); /* caddr(largs) */ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opsq_optuq_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - return(((s7_p_pp_t)opt3_direct(arg))(sc, - ((s7_p_p_t)opt2_direct(largs))(sc, lookup(sc, cadar(largs))), - ((s7_p_pp_t)opt3_direct(largs))(sc, t_lookup(sc, opt2_sym(cdr(largs)), arg), u_lookup(sc, opt1_sym(largs), arg)))); -} - -static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); - s7_pointer p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); - s7_pointer p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); - if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3))) - return(make_boolean(sc, integer(p1) == (integer(p2) + integer(p3)))); - return(make_boolean(sc, num_eq_b_7pp(sc, p1, add_p_pp(sc, p2, p3)))); -} - -static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); - s7_pointer p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); - s7_pointer p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); - if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3))) - return(make_boolean(sc, integer(p1) == (integer(p2) - integer(p3)))); - return(make_boolean(sc, num_eq_b_7pp(sc, p1, subtract_p_pp(sc, p2, p3)))); -} - -static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - set_car(sc->t2_1, lookup(sc, cadar(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs)))); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1)); - largs = cadr(largs); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - set_car(sc->t2_1, lookup(sc, cadar(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs)))); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1)); - largs = cadr(largs); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer arg) /* (- (* s1 s2) (* s3 s4)) */ -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - s7_pointer s1 = lookup(sc, car(a1)); - s7_pointer s2 = lookup(sc, cadr(a1)); - s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */ - s7_pointer s3 = lookup(sc, car(a2)); - s7_pointer s4 = lookup(sc, cadr(a2)); - if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4))) - return(make_real(sc, (real(s3) * real(s4)) - (real(s1) * real(s2)))); - sc->temp5 = multiply_p_pp(sc, s1, s2); - return(subtract_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->temp5)); -} - -static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* s1 s2) (* s3 s4)) */ -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - s7_pointer s1 = lookup(sc, car(a1)); - s7_pointer s2 = lookup(sc, cadr(a1)); - s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ - s7_pointer s3 = lookup(sc, car(a2)); - s7_pointer s4 = lookup(sc, cadr(a2)); - if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4))) - return(make_real(sc, (real(s3) * real(s4)) + (real(s1) * real(s2)))); - sc->temp5 = multiply_p_pp(sc, s1, s2); - return(add_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->temp5)); -} - -static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- s1 s2) (- s3 s4)) */ -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - s7_pointer s1 = lookup(sc, car(a1)); - s7_pointer s2 = lookup(sc, cadr(a1)); - s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ - s7_pointer s3 = lookup(sc, car(a2)); - s7_pointer s4 = lookup(sc, cadr(a2)); - if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4))) - return(make_real(sc, (real(s3) - real(s4)) * (real(s1) - real(s2)))); - sc->temp5 = subtract_p_pp(sc, s1, s2); - return(multiply_p_pp(sc, subtract_p_pp(sc, s3, s4), sc->temp5)); -} - -static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - sc->temp5 = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); - a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */ - return(lt_p_pp(sc, subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->temp5)); -} - -static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer a1 = cdadr(arg); - s7_pointer v1 = lookup(sc, car(a1)); - s7_pointer p1 = lookup(sc, cadr(a1)); - s7_pointer p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg)); */ - if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) - { - s7_int i1 = integer(p1), i2 = integer(p2); - if ((i1 >= 0) && (i1 <= vector_length(v1)) && (i2 >= 0) && (i2 < vector_length(v1))) - return(subtract_p_pp(sc, vector_ref_p_pi(sc, v1, i1), vector_ref_p_pi(sc, v1, i2))); - } - return(subtract_p_pp(sc, vector_ref_p_pp(sc, v1, p1), vector_ref_p_pp(sc, v1, p2))); -} - -static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code) -{ - set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(code)))))); - set_car(sc->t1_1, fn_proc(cadr(code))(sc, sc->t1_1)); - return(fn_proc(code)(sc, sc->t1_1)); -} - -static s7_pointer fx_not_op_opsqq(s7_scheme *sc, s7_pointer code) -{ - set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(code)))))); - return((fn_proc(cadr(code))(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_not_is_pair_opsq(s7_scheme *sc, s7_pointer code) -{ - return(make_boolean(sc, !is_pair(fn_proc(opt3_pair(code))(sc, set_plist_1(sc, lookup(sc, opt3_sym(cdr(code)))))))); -} - -static s7_pointer fx_string_ref_t_last(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_plast(sc, t_lookup(sc, cadr(arg), arg), int_zero));} - -static s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg) -{ - return(fn_proc(arg)(sc, with_list_t1(fx_call(sc, cdr(arg))))); -} - -static s7_pointer fx_c_a_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt3_direct(arg))(sc, fx_call(sc, cdr(arg))));} -static s7_pointer fx_not_a(s7_scheme *sc, s7_pointer arg) {return((fx_call(sc, cdr(arg)) == sc->F) ? sc->T : sc->F);} - -static s7_pointer fx_c_saa(s7_scheme *sc, s7_pointer arg) -{ - gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -#define fx_c_ssa_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg));\ - set_car(sc->t3_2, Lookup2(sc, car(opt3_pair(arg)), arg)); \ - return(fn_proc(arg)(sc, sc->t3_1));\ - } - -fx_c_ssa_any(fx_c_ssa, s_lookup, s_lookup) -fx_c_ssa_any(fx_c_tsa, t_lookup, s_lookup) -fx_c_ssa_any(fx_c_sta, s_lookup, t_lookup) - -static s7_pointer fx_c_ssa_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ppp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, car(opt3_pair(arg))), fx_call(sc, cdr(opt3_pair(arg))))); -} - -static s7_pointer fx_c_ass(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, fx_call(sc, cdr(arg))); - set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); - set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_agg(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, fx_call(sc, cdr(arg))); - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_sas(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_sca(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, car(opt3_pair(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_Tca(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, T_lookup(sc, cadr(arg), arg)); - set_car(sc->t3_2, car(opt3_pair(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_csa(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, cadr(arg)); - set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_cac(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_1, cadr(arg)); - set_car(sc->t3_3, cadr(opt3_pair(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg) -{ - /* check_stack_size(sc); */ - gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ - set_car(sc->t2_1, T_Ext(stack_protected1(sc))); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, opt3_con(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, opt3_con(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_ac_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), opt3_con(arg)));} - -static s7_pointer fx_is_eq_ac(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer y = opt3_con(arg); - s7_pointer x = fx_call(sc, cdr(arg)); - return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); -} - -#define fx_c_sa_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_2, fx_call(sc, cddr(arg))); \ - set_car(sc->t2_1, Lookup(sc, opt3_sym(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_sa_any(fx_c_sa, s_lookup) -fx_c_sa_any(fx_c_ta, t_lookup) -fx_c_sa_any(fx_c_ua, u_lookup) - -static s7_pointer fx_c_za(s7_scheme *sc, s7_pointer arg) /* "z"=unsafe_s */ -{ - s7_pointer val = lookup_checked(sc, cadr(arg)); /* this can call an autoload function that steps on sc->t2_1 */ - set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t2_1, val); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_sa_direct_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), fx_call(sc, cddr(arg)))); \ - } - -fx_c_sa_direct_any(fx_c_sa_direct, s_lookup) -fx_c_sa_direct_any(fx_c_ua_direct, u_lookup) - -static s7_pointer fx_cons_ca(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt3_con(arg), fx_call(sc, cddr(arg))));} -static s7_pointer fx_cons_ac(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), opt3_con(arg)));} -static s7_pointer fx_cons_sa(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));} -static s7_pointer fx_cons_as(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg))));} -static s7_pointer fx_cons_aa(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));} - -#define fx_c_as_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, fx_call(sc, cdr(arg))); \ - set_car(sc->t2_2, Lookup(sc, opt3_sym(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_as_any(fx_c_as, s_lookup) -fx_c_as_any(fx_c_at, t_lookup) - -static s7_pointer fx_c_as_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg)))); -} - -static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x1 = fx_call(sc, cdr(arg)); - s7_pointer x2 = lookup(sc, opt3_sym(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) + real(x2))); - return(add_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x1 = lookup(sc, cadr(arg)); - s7_pointer x2 = fx_call(sc, cddr(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2))); - return(multiply_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_subtract_aa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x2; - s7_pointer x1 = fx_call(sc, cdr(arg)); - sc->value = x1; - x2 = fx_call(sc, opt3_pair(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) - real(x2))); - return(subtract_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_add_aa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x2; - s7_pointer x1 = fx_call(sc, cdr(arg)); - sc->value = x1; - x2 = fx_call(sc, opt3_pair(arg)); - if (is_t_real(x1)) {if (is_t_real(x2)) return(make_real(sc, real(x1) + real(x2)));} - else if ((is_t_integer(x1)) && (is_t_integer(x2))) return(make_integer(sc, integer(x1) + integer(x2))); - /* maybe use add_if_overflow_to_real_or_big_integer, but that seems unnecessary currently */ - return(add_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_multiply_aa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x2; - s7_pointer x1 = fx_call(sc, cdr(arg)); - sc->value = x1; - x2 = fx_call(sc, opt3_pair(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2))); - return(multiply_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_add_sa(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));} -static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg) {return(number_to_string_p_pp(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));} - -static s7_pointer fx_c_3g(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, fx_call(sc, cdr(arg))); - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg) -{ - /* check_stack_size(sc); */ - gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_2, stack_protected2(sc)); - set_car(sc->t3_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_gac(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, cadr(opt3_pair(arg))); - set_car(sc->t3_1, lookup_global(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(fx_call(sc, cdadr(arg))))); - set_car(sc->t2_2, lookup_checked(sc, caddr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_s_opaq(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_2, fn_proc(caddr(arg))(sc, with_list_t1(fx_call(sc, opt3_pair(arg))))); /* cdaddr(arg); */ - set_car(sc->t2_1, lookup_checked(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opaq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cadr(arg); - set_car(sc->t1_1, fx_call(sc, cdr(p))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t1_1)))); -} - -static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cadr(arg); - /* check_stack_size(sc); */ - gc_protect_via_stack(sc, fx_call(sc, cdr(p))); - set_car(sc->t2_2, fx_call(sc, cddr(p))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t2_1)))); -} - -static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cadr(arg); - set_car(sc->t2_2, fx_call(sc, cddr(p))); - set_car(sc->t2_1, lookup(sc, cadr(p))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t2_1)))); -} - -static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = cadr(code); - gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, stack_protected1(sc)); - set_car(sc->t3_2, stack_protected2(sc)); - unstack(sc); - return(fn_proc(code)(sc, with_list_t1(fn_proc(arg)(sc, sc->t3_1)))); -} - -static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = caddr(code); - gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, stack_protected1(sc)); - set_car(sc->t2_2, fn_proc(arg)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(code))); - unstack(sc); - return(fn_proc(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer res = cdr(code); - check_stack_size(sc); /* t718 pp cycles #f */ - gc_protect_2_via_stack(sc, fx_call(sc, res), fx_call(sc, cdr(res))); - res = cddr(res); - set_stack_protected3(sc, fx_call(sc, res)); - set_car(sc->t3_3, fx_call(sc, cdr(res))); - set_car(sc->t3_2, stack_protected3(sc)); - set_car(sc->t3_1, stack_protected2(sc)); - set_car(sc->t4_1, stack_protected1(sc)); - unstack(sc); - res = fn_proc(code)(sc, sc->t4_1); - set_car(sc->t4_1, sc->F); - return(res); -} - -static s7_pointer fx_c_4g(s7_scheme *sc, s7_pointer code) -{ /* all opts in use for code, opt1 free cdr(code), code opt3 is line_number, cdr(code) opt3 is arglen?? */ - s7_pointer res = cdr(code); - set_car(sc->t4_1, fx_call(sc, res)); - set_car(sc->t3_1, fx_call(sc, cdr(res))); - set_car(sc->t3_2, fx_call(sc, opt3_pair(code))); /* cddr(res) */ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(code)))); /* cdddr(res) */ - res = fn_proc(code)(sc, sc->t4_1); - set_car(sc->t4_1, sc->F); - return(res); -} - -static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, cadr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = opt1_pair(cdr(code)); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); - set_car(sc->t2_1, fn_proc(cadr(code))(sc, with_list_t1(fn_proc(arg)(sc, sc->t2_1)))); - set_car(sc->t2_2, lookup(sc, caddr(code))); - return(fn_proc(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = opt1_pair(cdr(code)); - return(((s7_p_pp_t)opt3_direct(code))(sc, - ((s7_p_p_t)opt2_direct(cdr(code)))(sc, - ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)))), - lookup(sc, caddr(code)))); -} - -static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1, lst = safe_list_if_possible(sc, opt3_arglen(cdr(arg))); - if (in_heap(lst)) gc_protect_via_stack(sc, lst); - for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, lookup(sc, car(args))); - p1 = fn_proc(arg)(sc, lst); - if (in_heap(lst)) unstack(sc); - else clear_list_in_use(lst); - return(p1); -} - -static s7_pointer fx_list_ns(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer lst = make_list(sc, opt3_arglen(cdr(arg)), sc->unused); - for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, lookup(sc, car(args))); - return(lst); -} - -static s7_pointer fx_c_all_ca(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p1, lst = safe_list_if_possible(sc, opt3_arglen(cdr(code))); - if (in_heap(lst)) gc_protect_via_stack(sc, lst); - for (s7_pointer args = cdr(code), p = lst; is_pair(args); args = cdr(args), p = cddr(p)) - { - set_car(p, opt2_con(args)); - args = cdr(args); - set_car(cdr(p), fx_call(sc, args)); - } - p1 = fn_proc(code)(sc, lst); - if (in_heap(lst)) unstack(sc); - else clear_list_in_use(lst); - return(p1); -} - -static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) -{ - s7_pointer new_e, sp = NULL; - int64_t id; - - new_cell(sc, new_e, T_LET | T_SAFE_PROCEDURE); - let_set_slots(new_e, slot_end(sc)); /* needed by add_slot_unchecked */ - let_set_outlet(new_e, sc->nil); - gc_protect_via_stack(sc, new_e); - - /* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let - * but don't set its id yet, and don't set local_slot until end either because fx_call might refer to same-name symbol in outer let. - * That is, symbol_id=outer_let_id so lookup->local_slot, so we better not set local_slot ahead of time here. - * As far as I can tell, this is the only place we do fx_call at the time of new_slot with new let id unset. - */ - for (s7_pointer x = cdr(code); is_pair(x); x = cddr(x)) - { - s7_pointer symbol = car(x), value; - symbol = (is_symbol_and_keyword(symbol)) ? keyword_symbol(symbol) : cadr(symbol); /* (inlet ':allow-other-keys 3) */ - if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ - { - unstack(sc); - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - } - value = fx_call(sc, cdr(x)); /* it's necessary to do this first, before add_slot_unchecked */ - if (!sp) - { - add_slot_unchecked_no_local(sc, new_e, symbol, value); - sp = let_slots(new_e); - } - else sp = add_slot_at_end_no_local(sc, sp, symbol, value); - } - id = ++sc->let_number; - let_set_id(new_e, id); - for (s7_pointer x = let_slots(new_e); tis_slot(x); x = next_slot(x)) - symbol_set_local_slot_unincremented(slot_symbol(x), id, x); /* was symbol_set_id(slot_symbol(x), id) */ - unstack(sc); - return(new_e); -} - -static s7_pointer fx_c_na(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer args, p, val = safe_list_if_possible(sc, opt3_arglen(cdr(arg))); - if (in_heap(val)) gc_protect_via_stack(sc, val); - for (args = cdr(arg), p = val; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - p = fn_proc(arg)(sc, val); - if (in_heap(val)) unstack(sc); - else clear_list_in_use(val); - return(p); -} - -static s7_pointer fx_vector_ns(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer args = cdr(arg); - s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(arg))); - s7_pointer *els = (s7_pointer *)vector_elements(vec); - for (s7_int i = 0; is_pair(args); args = cdr(args), i++) - els[i] = lookup(sc, car(args)); - return(vec); -} - -static s7_pointer fx_vector_na(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer args = cdr(arg); - s7_pointer v = make_simple_vector(sc, opt3_arglen(cdr(arg))); /* was s7_make_vector */ - s7_pointer *els = vector_elements(v); - gc_protect_via_stack(sc, v); - normal_vector_fill(v, sc->nil); /* fx_calls below can trigger GC, so all elements of v must be legit */ - for (s7_int i = 0; is_pair(args); args = cdr(args), i++) - els[i] = fx_call(sc, args); - sc->value = v; /* full-s7test 12262 list_p_p case */ - unstack(sc); - return(v); -} - -static s7_pointer fx_if_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_true(sc, fx_call(sc, cdr(arg)))) ? fx_call(sc, opt1_pair(arg)) : sc->unspecified); -} - -static s7_pointer fx_if_not_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : sc->unspecified); -} - -static s7_pointer fx_if_a_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_true(sc, fx_call(sc, cdr(arg)))) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); -} - -#define fx_if_s_a_a_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return((Lookup(sc, cadr(arg), arg) != sc->F) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); \ - } - -fx_if_s_a_a_any(fx_if_s_a_a, s_lookup) -fx_if_s_a_a_any(fx_if_o_a_a, o_lookup) /* diff s->o of ca 3 */ - - -static s7_pointer fx_if_and2_s_a(s7_scheme *sc, s7_pointer arg) -{ - return(((fx_call(sc, opt1_pair(arg)) == sc->F) || (fx_call(sc, opt2_pair(arg)) == sc->F)) ? fx_call(sc, cdddr(arg)) : lookup(sc, opt3_sym(arg))); -} - -static s7_pointer fx_if_not_a_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : fx_call(sc, opt3_pair(arg))); -} - -static s7_pointer fx_if_a_c_c(s7_scheme *sc, s7_pointer arg) {return((is_true(sc, fx_call(sc, cdr(arg)))) ? opt1_con(arg) : opt2_con(arg));} - -static s7_pointer fx_if_is_type_s_a_a(s7_scheme *sc, s7_pointer arg) -{ - if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(arg))), opt3_byte(cdr(arg)))) - return(fx_call(sc, cddr(arg))); - return(fx_call(sc, opt2_pair(arg))); /* cdddr(arg) */ -} - -static inline s7_pointer fx_and_2a(s7_scheme *sc, s7_pointer arg) /* arg is the full expr: (and ...) */ -{ - return((fx_call(sc, cdr(arg)) == sc->F) ? sc->F : fx_call(sc, cddr(arg))); -} - -static inline s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg) */ - return((fn_proc(cadr(arg))(sc, sc->t1_1) == sc->F) ? sc->F : fn_proc(caddr(arg))(sc, sc->t1_1)); -} - -static s7_pointer fx_and_or_2a_vref(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer or1 = cadr(arg); - s7_pointer arg11 = cdadr(or1); - s7_pointer v = lookup(sc, cadar(arg11)); - if ((is_normal_vector(v)) && (vector_rank(v) == 1)) - { - s7_pointer ip = lookup(sc, opt3_sym(or1)); - s7_pointer jp = lookup(sc, opt1_sym(or1)); - if ((is_t_integer(ip)) && (is_t_integer(jp))) - { - s7_int i = integer(ip), j = integer(jp); - if ((i >= 0) && (j >= 0) && - (i < vector_length(v)) && (j < vector_length(v)) && - (is_t_real(vector_element(v, i))) && (is_t_real(vector_element(v, j)))) - { - s7_pointer xp = lookup(sc, cadr(arg11)); - if (is_t_real(xp)) - { - s7_double vi = real(vector_element(v, i)), vj = real(vector_element(v, j)), xf = real(xp); - return(make_boolean(sc, ((vi > xf) || (xf >= vj)) && ((vj > xf) || (xf >= vi)))); - }}}} - return(fx_and_2a(sc, arg)); -} - -static s7_pointer fx_len2_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* isn't this unprotected from mock pair? */ /* opt1_sym == cadadr(arg) */ - return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_null(cddr(val))))); -} - -static s7_pointer fx_len3_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = t_lookup(sc, opt1_sym(cdr(arg)), arg); - return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_pair(cddr(val))))); -} - -static s7_pointer fx_and_3a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - if (fx_call(sc, p) == sc->F) return(sc->F); - p = cdr(p); - if (fx_call(sc, p) == sc->F) return(sc->F); - return(fx_call(sc, cdr(p))); -} - -static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = sc->T; - for (s7_pointer p = cdr(arg); (is_pair(p)) && (x != sc->F); p = cdr(p)) /* in lg, 5/6 args appears to predominate */ - x = fx_call(sc, p); - return(x); -} - -static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - return((val != sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg) -{ - /* the "s" is looked up once here -- not obvious how to use fx_call anyway */ - s7_pointer x = fn_proc(cadr(arg))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg); */ - return((x != sc->F) ? x : fn_proc(caddr(arg))(sc, sc->t1_1)); -} - -static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */ - return(make_boolean(sc, (type(x) == opt3_int(arg)) || (type(x) == opt2_int(cdr(arg))))); -} - -static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, opt3_sym(arg)); - return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val)))); -} - -static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - if (val != sc->F) return(val); - p = opt3_pair(arg); /* cdadr(p); */ - val = fx_call(sc, p); - return((val == sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_and_3a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - if (val != sc->F) return(val); - p = opt3_pair(arg); /* cdadr(p); */ - val = fx_call(sc, p); - if (val == sc->F) return(val); - p = cdr(p); - val = fx_call(sc, p); - return((val == sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_3a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - if (val != sc->F) return(val); - p = cdr(p); - val = fx_call(sc, p); - return((val != sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = sc->F; - for (s7_pointer p = cdr(arg); (is_pair(p)) && (x == sc->F); p = cdr(p)) - x = fx_call(sc, p); - return(x); -} - -static s7_pointer fx_begin_aa(s7_scheme *sc, s7_pointer arg) -{ - fx_call(sc, cdr(arg)); - return(fx_call(sc, cddr(arg))); -} - -static s7_pointer fx_begin_na(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p; - for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); -} - -static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer f = opt1_lambda(code), result; - gc_protect_via_stack(sc, sc->curlet); - set_curlet(sc, closure_let(f)); - result = fx_call(sc, closure_body(f)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ -{ - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), t_lookup(sc, opt2_sym(code), code)); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) -{ - return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, with_list_t1(lookup(sc, opt2_sym(arg))))); -} - -static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_2, opt3_con(cdr(arg))); - set_car(sc->t2_1, lookup(sc, opt2_sym(arg))); - return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); -} - -static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, opt2_sym(arg)), opt3_con(cdr(arg))));} - -static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = lookup(sc, opt2_sym(arg)); - if ((!WITH_GMP) && (is_t_integer(p))) - return(make_integer(sc, integer(p) - 1)); - return(minus_c1(sc, p)); -} - -static s7_pointer fx_safe_closure_s_to_add1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = lookup(sc, opt2_sym(arg)); - if ((!WITH_GMP) && (is_t_integer(p))) - return(make_integer(sc, integer(p) + 1)); - return(g_add_x1_1(sc, p, 1)); -} - -static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer x = fx_proc(cdar(p))(sc, car(p)); - sc->value = x; - set_car(sc->t2_2, fx_proc(cdadr(p))(sc, cadr(p))); - set_car(sc->t2_1, x); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, opt3_con(cdr(arg))); - return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); -} - -static s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));} - -static s7_pointer fx_safe_closure_s_and_2a(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2a */ -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - code = cdar(closure_body(opt1_lambda(code))); - result = fx_call(sc, code); /* have to unwind the stack so this can't return */ - if (result != sc->F) - result = fx_call(sc, cdr(code)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_s_and_pair(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2a with is_pair as first clause */ -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - code = cdar(closure_body(opt1_lambda(code))); - result = (is_pair(t_lookup(sc, cadar(code), code))) ? fx_call(sc, cdr(code)) : sc->F; /* pair? arg = func par, pair? is global, symbol_id=0 */ - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer code) -{ - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_a_sqr(s7_scheme *sc, s7_pointer code) {return(fx_sqr_1(sc, fx_call(sc, cdr(code))));} -static s7_pointer fx_safe_closure_s_sqr(s7_scheme *sc, s7_pointer code) {return(fx_sqr_1(sc, lookup(sc, opt2_sym(code))));} - -static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer and_arg = cdar(closure_body(opt1_lambda(code))); - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - result = fx_call(sc, and_arg); - if (result != sc->F) result = fx_call(sc, cdr(and_arg)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) -{ - sc->curlet = update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) -{ - sc->curlet = update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p = cdr(code); - s7_pointer f = opt1_lambda(code); - gc_protect_2_via_stack(sc, sc->curlet, fx_call(sc, cdr(p))); /* this is needed even if one of the args is a symbol */ - sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), stack_protected2(sc)); - p = fx_call(sc, closure_body(f)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(p); -} - -static inline s7_pointer fx_cond_na_na(s7_scheme *sc, s7_pointer code) /* all tests are fxable, results are all fx, no =>, no missing results */ -{ - for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) - if (is_true(sc, fx_call(sc, car(p)))) - { - for (p = cdar(p); is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); - } - return(sc->unspecified); -} - -static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice); - -static s7_pointer fx_implicit_s7_starlet_ref_s(s7_scheme *sc, s7_pointer arg) {return(s7_starlet(sc, opt3_int(arg)));} -static s7_pointer fx_implicit_s7_starlet_print_length(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->print_length));} -static s7_pointer fx_implicit_s7_starlet_safety(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->safety));} - -static s7_function *fx_function = NULL; - -static bool is_fxable(s7_scheme *sc, s7_pointer p) -{ - if (!is_pair(p)) return(true); - if ((is_optimized(p)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */ - (fx_function[optimize_op(p)])) - return(true); - return(is_proper_quote(sc, p)); -} - -static bool is_gxable(s7_pointer p) -{ - opcode_t op; - if (!is_optimized(p)) return(false); - op = optimize_op(p); - return((is_symbol(car(p))) && (symbol_ctr(car(p)) == 1) && - (op < FIRST_UNHOPPABLE_OP) && - (op > OP_GC_PROTECT) && - (fx_function[op | 1])); -} - -static int32_t fx_count(s7_scheme *sc, s7_pointer x) -{ - int32_t count = 0; - for (s7_pointer p = cdr(x); is_pair(p); p = cdr(p)) - if (is_fxable(sc, car(p))) - count++; - return(count); -} - -static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (car(p) == sc->quote_symbol) : is_constant(sc, p));} - -static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code); - -static s7_p_dd_t s7_p_dd_function(s7_pointer f); -static s7_p_pi_t s7_p_pi_function(s7_pointer f); -static s7_p_ii_t s7_p_ii_function(s7_pointer f); - -#define is_unchanged_global(P) \ - ((is_symbol(P)) && (is_global(P)) && (symbol_id(P) == 0) && \ - (is_slot(initial_slot(P))) && \ - (initial_value(P) == global_value(P))) - -#define is_global_and_has_func(P, Func) ((is_unchanged_global(P)) && (Func(global_value(P)))) /* Func = s7_p_pp_function and friends */ - -static bool fx_matches(s7_pointer symbol, s7_pointer target_symbol) {return((symbol == target_symbol) && (is_unchanged_global(symbol)));} - -typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer e); - -/* #define fx_choose(Sc, Holder, E, Checker) fx_choose_1(Sc, Holder, E, Checker, __func__, __LINE__) */ -static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer cur_env, safe_sym_t *checker) /* , const char *func, int32_t line) */ -{ - s7_pointer arg = car(holder); - if (!is_pair(arg)) - { - if (is_symbol(arg)) - { - if ((is_keyword(arg)) || ((arg == sc->else_symbol) && (is_global(arg)))) return(fx_c); - return((is_global(arg)) ? fx_g : ((checker(sc, arg, cur_env)) ? fx_s : fx_unsafe_s)); - } - return(fx_c); - } - if (is_optimized(arg)) - { - switch (optimize_op(arg)) - { - case HOP_SAFE_C_NC: -#if (!WITH_GMP) - if (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); -#endif - return((fn_proc(arg) == g_random_i) ? fx_random_i : ((fn_proc(arg) == g_cons) ? fx_cons_cc : fx_c_nc)); - - case OP_OR_2A: - if (fx_proc(cddr(arg)) == fx_and_2a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_2a);} - if (fx_proc(cddr(arg)) == fx_and_3a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_3a);} - if ((fx_proc(cdr(arg)) == fx_not_is_symbol_s) && (fx_proc(cddr(arg)) == fx_is_keyword_s) && (cadr(cadadr(arg)) == cadaddr(arg))) - { - /* (or (not (symbol? body)) (keyword? body)) */ - set_opt3_sym(arg, cadaddr(arg)); - return(fx_not_symbol_or_keyword); - } - return(fx_or_2a); - - case OP_AND_2A: - if ((fx_proc(cdr(arg)) == fx_or_2a) && (fx_proc(cddr(arg)) == fx_or_2a)) - { - s7_pointer o1 = cadr(arg), o2 = caddr(arg); - if ((fx_proc(cdr(o1)) == fx_gt_vref_s) && - (fx_proc(cddr(o1)) == fx_geq_s_vref) && - (fx_proc(cdr(o2)) == fx_gt_vref_s) && - (fx_proc(cddr(o2)) == fx_geq_s_vref)) - { - s7_pointer v = cadr(cadadr(o1)); - if ((v == cadr(cadadr(o2))) && (v == (cadr(caddaddr(o1)))) && (v == (cadr(caddaddr(o2))))) - { - s7_pointer x = caddadr(o1); - if ((x == caddadr(o2)) && (x == cadaddr(o1)) && (x == cadaddr(o2))) - { - s7_pointer i = caddr(cadadr(o1)), j = caddaddr(caddr(o1)); - if ((j == caddr(cadadr(o2))) && (i == caddaddr(caddr(o2)))) - { - set_opt1_sym(o1, j); - set_opt3_sym(o1, i); - return(fx_and_or_2a_vref); - }}}}} - return(fx_and_2a); - - case HOP_SAFE_C_S: - if (is_unchanged_global(car(arg))) /* mus-copy would work here but in tgen (for example) it's loading generators.scm with local mus-copy methods */ - { - uint8_t typ; - if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); - if (car(arg) == sc->car_symbol) return(fx_car_s); - if (car(arg) == sc->cadr_symbol) return(fx_cadr_s); - if (car(arg) == sc->cddr_symbol) return(fx_cddr_s); - if (car(arg) == sc->is_null_symbol) return(fx_is_null_s); - if (car(arg) == sc->is_pair_symbol) return(fx_is_pair_s); - if (car(arg) == sc->is_symbol_symbol) return(fx_is_symbol_s); - if (car(arg) == sc->is_eof_object_symbol) return(fx_is_eof_s); - if (car(arg) == sc->is_integer_symbol) return(fx_is_integer_s); - if (car(arg) == sc->is_string_symbol) return(fx_is_string_s); - if (car(arg) == sc->not_symbol) return(fx_not_s); - if (car(arg) == sc->is_proper_list_symbol) return(fx_is_proper_list_s); - if (car(arg) == sc->is_vector_symbol) return(fx_is_vector_s); - if (car(arg) == sc->is_keyword_symbol) return(fx_is_keyword_s); - if (car(arg) == sc->is_procedure_symbol) return(fx_is_procedure_s); - if (car(arg) == sc->length_symbol) return(fx_length_s); - /* not read_char here... */ - typ = symbol_type(car(arg)); - if (typ > 0) - { - set_opt3_byte(cdr(arg), typ); - return(fx_is_type_s); - } - /* car_p_p (et al) does not look for a method so in: - * (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p))))) - * "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it. - */ - if (symbol_id(c_function_name_to_symbol(sc, global_value(car(arg)))) == 0) - { - s7_p_p_t f = s7_p_p_function(global_value(car(arg))); - if (f) - { - set_opt2_direct(cdr(arg), (s7_pointer)f); - if (f == real_part_p_p) return(fx_real_part_s); - if (f == imag_part_p_p) return(fx_imag_part_s); - if (f == iterate_p_p) return(fx_iterate_s); - if (f == car_p_p) return(fx_car_s); /* can happen if (define var-name car) etc */ - return((is_global(cadr(arg))) ? fx_c_g_direct : fx_c_s_direct); - }}} - return((is_global(cadr(arg))) ? fx_c_g : fx_c_s); - - case HOP_SAFE_C_SS: - if (fn_proc(arg) == g_cons) return(fx_cons_ss); - if (fx_matches(car(arg), sc->num_eq_symbol)) return(fx_num_eq_ss); - if (fn_proc(arg) == g_geq_2) return(fx_geq_ss); - if (fn_proc(arg) == g_greater_2) return(fx_gt_ss); - if (fn_proc(arg) == g_leq_2) return(fx_leq_ss); - if (fn_proc(arg) == g_less_2) return((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); - if ((fx_matches(car(arg), sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_ss); - if (fn_proc(arg) == g_is_eq) return(fx_is_eq_ss); - if (fn_proc(arg) == g_add_2) return(fx_add_ss); - if (fn_proc(arg) == g_subtract_2) return(fx_subtract_ss); - if (fn_proc(arg) == g_hash_table_ref_2) return(fx_hash_table_ref_ss); - - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - if (car(arg) == sc->assq_symbol) return(fx_assq_ss); - if (car(arg) == sc->memq_symbol) return(fx_memq_ss); - if (car(arg) == sc->vector_ref_symbol) return(fx_vref_ss); - if (car(arg) == sc->string_ref_symbol) return(fx_string_ref_ss); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return(fx_c_ss_direct); - } - /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ - return(fx_c_ss); - - case HOP_SAFE_C_NS: - if (fn_proc(arg) == g_list) return(fx_list_ns); /* it is no faster here to divide out the big list cases!? */ - return((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); - - case HOP_SAFE_C_opSq_S: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_p_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - return(((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->car_symbol)) ? fx_cons_car_s_s : fx_c_opsq_s_direct); - } - return(fx_c_opsq_s); - - case HOP_SAFE_C_SSS: - if ((fn_proc(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg); - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_sss_direct); - } - return(fx_c_sss); - - case HOP_SAFE_C_SSA: - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_ssa_direct); - } - return(fx_c_ssa); - - case HOP_SAFE_C_SCS: - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_scs_direct); - } - return(fx_c_scs); - - case HOP_SAFE_C_AAA: - if ((fx_proc(cdr(arg)) == fx_g) && (fx_proc(cdddr(arg)) == fx_c)) return(fx_c_gac); - if ((is_unquoted_pair(cadr(arg))) || (is_unquoted_pair(caddr(arg))) || (is_unquoted_pair(cadddr(arg)))) return(fx_c_aaa); - return(fx_c_3g); - - case HOP_SAFE_C_4A: - set_opt3_pair(arg, cdddr(arg)); - for (s7_pointer p = cdr(arg); is_pair(p); p = cdr(p)) - if (is_unquoted_pair(car(p))) - return(fx_c_4a); - return(fx_c_4g); /* fx_c_ssaa doesn't save much */ - - case HOP_SAFE_C_S_opSSq: - { - s7_pointer s2 = caddr(arg); - if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); - - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(car(s2), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(s2))))); - set_opt3_pair(arg, cdr(s2)); - if (car(s2) == sc->vector_ref_symbol) - { - if (car(arg) == sc->add_symbol) return(fx_add_s_vref); - if (car(arg) == sc->subtract_symbol) return(fx_subtract_s_vref); - if (car(arg) == sc->multiply_symbol) return(fx_multiply_s_vref); - if (car(arg) == sc->geq_symbol) return(fx_geq_s_vref); - if (car(arg) == sc->is_eq_symbol) return(fx_is_eq_s_vref); - if (car(arg) == sc->hash_table_ref_symbol) return(fx_href_s_vref); - if (car(arg) == sc->let_ref_symbol) return(fx_lref_s_vref); - if ((is_global(cadr(arg))) && (is_global(cadr(s2))) && (car(arg) == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); - } - if ((car(arg) == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); - return(fx_c_s_opssq_direct); - } - return(fx_c_s_opssq); - } - - case HOP_SAFE_C_opSSq_S: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_pp_function))) - { - /* op_c_opgsq_t */ - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); - set_opt3_pair(arg, cdadr(arg)); - if (caadr(arg) == sc->vector_ref_symbol) - { - if (car(arg) == sc->subtract_symbol) return(fx_subtract_vref_s); - if (car(arg) == sc->gt_symbol) return(fx_gt_vref_s); - if (car(arg) == sc->vector_ref_symbol) return(fx_vref_vref_ss_s); - if (car(arg) == sc->add_symbol) return(fx_add_vref_s); - } - if (car(arg) == sc->add_symbol) - { - if ((caadr(arg) == sc->multiply_symbol) && (cadadr(arg) == caddadr(arg))) return(fx_add_sqr_s); - if (caadr(arg) == sc->subtract_symbol) return(fx_add_sub_s); - } - if ((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->cons_symbol)) return(fx_cons_cons_s); - /* also div(sub)[2] mul(div) */ - return(((car(arg) == sc->gt_symbol) && (caadr(arg) == sc->add_symbol)) ? fx_gt_add_s : - (((car(arg) == sc->add_symbol) && (caadr(arg) == sc->multiply_symbol)) ? fx_add_mul_opssq_s : fx_c_opssq_s_direct)); - } - return(fx_c_opssq_s); - - case HOP_SAFE_C_opSSq_opSSq: - { - s7_pointer s1 = cadr(arg), s2 = caddr(arg); - set_opt3_pair(arg, cdr(s2)); - if ((fx_matches(car(s1), sc->multiply_symbol)) && (car(s2) == sc->multiply_symbol)) - { - set_opt1_pair(cdr(arg), cdr(s1)); - if (car(arg) == sc->subtract_symbol) return(fx_sub_mul_mul); - if (car(arg) == sc->add_symbol) - return(((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) ? fx_add_sqr_sqr : fx_add_mul_mul); - } - if ((fx_matches(car(s1), sc->subtract_symbol)) && (car(s2) == sc->subtract_symbol)) - { - set_opt1_pair(cdr(arg), cdr(s1)); - if (car(arg) == sc->multiply_symbol) return(fx_mul_sub_sub); - if (car(arg) == sc->lt_symbol) return(fx_lt_sub2); - } - if ((fx_matches(car(arg), sc->subtract_symbol)) && - (fx_matches(car(s1), sc->vector_ref_symbol)) && - (car(s2) == sc->vector_ref_symbol) && - (cadr(s1) == cadr(s2))) - { - set_opt3_sym(arg, cadr(cdaddr(arg))); - return(fx_sub_vref2); - } - return(fx_c_opssq_opssq); - } - - case HOP_SAFE_C_opSq: - if (is_unchanged_global(caadr(arg))) - { - if (fx_matches(car(arg), sc->is_pair_symbol)) - { - if (caadr(arg) == sc->car_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_car_s);} - if (caadr(arg) == sc->cdr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cdr_s);} - if (caadr(arg) == sc->cadr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cadr_s);} - if (caadr(arg) == sc->cddr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cddr_s);} - } - if (fx_matches(car(arg), sc->is_null_symbol)) - { - if (caadr(arg) == sc->cdr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cdr_s);} - if (caadr(arg) == sc->cadr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cadr_s);} - if (caadr(arg) == sc->cddr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cddr_s);} - } - if ((fx_matches(car(arg), sc->is_symbol_symbol)) && - (caadr(arg) == sc->cadr_symbol)) - {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_symbol_cadr_s);} - - if (fx_matches(car(arg), sc->not_symbol)) - { - if (caadr(arg) == sc->is_pair_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_pair_s);} - if (caadr(arg) == sc->is_null_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_null_s);} - if (caadr(arg) == sc->is_symbol_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_symbol_s);} - return(fx_not_opsq); - } - if ((fx_matches(car(arg), sc->floor_symbol)) && (caadr(arg) == sc->sqrt_symbol)) - {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_floor_sqrt_s);} - } - if (is_unchanged_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ - { /* other possibility: fx_c_a */ - uint8_t typ = symbol_type(car(arg)); - if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ - { - set_opt2_sym(cdr(arg), cadadr(arg)); - set_opt3_byte(cdr(arg), typ); - if (fn_proc(cadr(arg)) == (s7_function)g_c_pointer_weak1) - return(fx_eq_weak1_type_s); - return(fx_matches(caadr(arg), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); - }} - /* this should follow the is_type* check above */ - if (fx_matches(caadr(arg), sc->car_symbol)) - { - set_opt2_sym(cdr(arg), cadadr(arg)); - return(fx_c_car_s); - } - if (fx_matches(caadr(arg), sc->cdr_symbol)) - { - set_opt2_sym(cdr(arg), cadadr(arg)); - return(fx_c_cdr_s); - } - return(fx_c_opsq); - - case HOP_SAFE_C_SC: - if (is_unchanged_global(car(arg))) - { - if (car(arg) == sc->add_symbol) - { - if (is_t_real(caddr(arg))) return(fx_add_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_add_s1 : fx_add_si); - } - if (car(arg) == sc->subtract_symbol) - { - if (is_t_real(caddr(arg))) return(fx_subtract_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_subtract_s1 : fx_subtract_si); - } - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(caddr(arg))) return(fx_multiply_sf); - if (is_t_integer(caddr(arg))) return(fx_multiply_si); - } - if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); - if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); - - if ((is_t_integer(caddr(arg))) && (s7_p_pi_function(global_value(car(arg))))) - { - if (car(arg) == sc->num_eq_symbol) return((integer(caddr(arg)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - if (car(arg) == sc->lt_symbol) return(fx_lt_si); - if (car(arg) == sc->leq_symbol) return(fx_leq_si); - if (car(arg) == sc->gt_symbol) return(fx_gt_si); - if (car(arg) == sc->geq_symbol) return(fx_geq_si); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); - return(fx_c_si_direct); - } - if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0) && (car(arg) == sc->num_eq_symbol)) return(fx_num_eq_s0f); - if ((s7_p_pp_function(global_value(car(arg)))) && (fn_proc(arg) != g_divide_by_2)) - { - if (car(arg) == sc->memq_symbol) - { - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) return(fx_memq_sc_3); - return(fx_memq_sc); - } - if ((car(arg) == sc->char_eq_symbol) && (is_character(caddr(arg)))) return(fx_char_eq_sc); /* maybe fx_char_eq_newline */ - if (car(arg) == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ - if (car(arg) == sc->leq_symbol) return(fx_leq_sc); - if (car(arg) == sc->gt_symbol) return(fx_gt_sc); - if (car(arg) == sc->geq_symbol) return(fx_geq_sc); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return(fx_c_sc_direct); - }} - return(fx_c_sc); - - case HOP_SAFE_C_CS: - if (is_unchanged_global(car(arg))) - { - if (car(arg) == sc->cons_symbol) return(fx_cons_cs); - if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) return(fx_add_fs); - if ((car(arg) == sc->subtract_symbol) && (is_t_real(cadr(arg)))) return(fx_subtract_fs); - if ((car(arg) == sc->num_eq_symbol) && (cadr(arg) == int_zero)) return(fx_num_eq_0s); - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(cadr(arg))) return(fx_multiply_fs); - if (is_t_integer(cadr(arg))) return(fx_multiply_is); - }} - return(fx_c_cs); - - case HOP_SAFE_C_S_opSq: - if (fx_matches(car(caddr(arg)), sc->car_symbol)) - { - set_opt2_sym(cdr(arg), cadaddr(arg)); - if (fx_matches(car(arg), sc->hash_table_ref_symbol)) return(fx_hash_table_ref_car); - return(fx_matches(car(arg), sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); - } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_p_function))) - { - if ((car(arg) == sc->cons_symbol) && (caaddr(arg) == sc->cdr_symbol)) {set_opt2_sym(cdr(arg), cadaddr(arg)); return(fx_cons_s_cdr_s);} - set_opt1_sym(cdr(arg), cadaddr(arg)); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); - return(fx_c_s_opsq_direct); - } - return(fx_c_s_opsq); - - case HOP_SAFE_C_C_opSq: - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - s7_pointer arg2 = caddr(arg); - if (is_global_and_has_func(car(arg2), s7_p_p_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(car(arg2))))); - set_opt1_sym(cdr(arg), cadr(arg2)); - return(fx_c_c_opsq_direct); - }} - return(fx_c_c_opsq); - - case HOP_SAFE_C_opSq_C: - if (is_unchanged_global(car(arg))) - { - if ((car(arg) == sc->memq_symbol) && - (fx_matches(caadr(arg), sc->car_symbol)) && - (is_proper_quote(sc, caddr(arg))) && - (is_pair(cadaddr(arg)))) - return((s7_list_length(sc, opt2_con(cdr(arg))) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); - - if (car(arg) == sc->is_eq_symbol) - { - if (((fx_matches(caadr(arg), sc->car_symbol)) || (fx_matches(caadr(arg), sc->caar_symbol))) && - (is_proper_quote(sc, caddr(arg)))) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), cadaddr(arg)); - return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_sq : fx_is_eq_caar_sq); - }} - if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) && - (is_t_integer(caddr(arg))) && - (fx_matches(caadr(arg), sc->length_symbol))) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), caddr(arg)); - return((car(arg) == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i); - }} - set_opt1_sym(cdr(arg), cadadr(arg)); - return(fx_c_opsq_c); - - case HOP_SAFE_C_op_opSqq: - return((fx_matches(car(arg), sc->not_symbol)) ? ((fn_proc(cadr(arg)) == g_is_pair) ? fx_not_is_pair_opsq : fx_not_op_opsqq) : fx_c_op_opsqq); - - case HOP_SAFE_C_opSCq: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fn_proc(cadr(arg)) == g_is_eq) - { - set_opt2_sym(cdr(arg), cadadr(arg)); - set_opt3_con(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); - return(fx_not_is_eq_sq); - } - return(fx_not_opscq); - } - return(fx_c_opscq); - - case HOP_SAFE_C_S_opSCq: - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - s7_pointer arg2 = caddr(arg); - if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) && - (is_t_integer(caddr(arg2)))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg2))))); - set_opt3_sym(arg, cadr(arg2)); - set_opt1_con(cdr(arg), caddr(arg2)); - if (car(arg) == sc->num_eq_symbol) - { - if (car(arg2) == sc->add_symbol) return(fx_num_eq_add_s_si); - if (car(arg2) == sc->subtract_symbol) return(fx_num_eq_subtract_s_si); - } - if ((car(arg) == sc->vector_ref_symbol) && (car(arg2) == sc->add_symbol) && (integer(caddr(arg2)) == 1)) - return(fx_vref_p1); - return(fx_c_s_opsiq_direct); - } - if (is_global_and_has_func(car(arg2), s7_p_pp_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg2))))); - set_opt3_sym(arg, cadr(arg2)); - set_opt1_con(cdr(arg), (is_pair(caddr(arg2))) ? cadaddr(arg2) : caddr(arg2)); - return(fx_c_s_opscq_direct); - }} - return(fx_c_s_opscq); - - case HOP_SAFE_C_opSSq: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fn_proc(cadr(arg)) == g_is_eq) return(fx_not_is_eq_ss); - return(fx_not_opssq); - } - if ((is_global_and_has_func(car(arg), s7_p_p_function)) && - (is_global_and_has_func(caadr(arg), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); - return(fx_c_opssq_direct); - } - return(fx_c_opssq); - - case HOP_SAFE_C_C_opSSq: - { - s7_pointer s2 = caddr(arg); - if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) - return(fx_c_c_sqr); - } - if ((is_small_real(cadr(arg))) && - (is_global_and_has_func(car(arg), s7_p_dd_function)) && - (is_global_and_has_func(caaddr(arg), s7_d_pd_function))) /* not * currently (this is for clm) */ - { - set_opt3_direct(cdr(arg), s7_d_pd_function(global_value(caaddr(arg)))); - set_opt2_direct(cdr(arg), s7_p_dd_function(global_value(car(arg)))); - set_opt3_sym(arg, cadaddr(arg)); - set_opt1_sym(cdr(arg), caddaddr(arg)); - return(fx_c_nc_opssq_direct); - } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caaddr(arg))))); - set_opt3_sym(arg, cadaddr(arg)); - set_opt1_sym(cdr(arg), caddaddr(arg)); - if ((is_t_real(cadr(arg))) && (car(arg) == caaddr(arg)) && (car(arg) == sc->multiply_symbol)) return(fx_multiply_c_opssq); - return(fx_c_c_opssq_direct); - } - return(fx_c_c_opssq); - - case HOP_SAFE_C_opSq_opSq: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_p_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_p_function))) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); - if ((caadr(arg) == caaddr(arg)) && ((caadr(arg) == sc->cdr_symbol) || (caadr(arg) == sc->car_symbol))) - { - set_opt1_sym(cdr(arg), cadadr(arg)); - set_opt2_sym(cdr(arg), cadaddr(arg)); /* usable because we know func is cdr|car */ - return((caadr(arg) == sc->cdr_symbol) ? fx_cdr_s_cdr_s : fx_car_s_car_s); - } - set_opt1_sym(cdr(arg), cadaddr(arg)); /* opt2 is taken by second func */ - return(fx_c_opsq_opsq_direct); - } - return(fx_c_opsq_opsq); - - case HOP_SAFE_C_op_S_opSqq: - return((fx_matches(car(arg), sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); - - case HOP_SAFE_C_op_opSSqq_S: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_p_function)) && - (is_global_and_has_func(car(cadadr(arg)), s7_p_pp_function))) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(cadr(arg)))))); - return(fx_c_op_opssqq_s_direct); - } - return(fx_c_op_opssqq_s); - - case HOP_SAFE_C_A: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fx_proc(cdr(arg)) == fx_is_eq_car_sq) - { - set_opt1_sym(cdr(arg), cadadr(cadr(arg))); - set_opt3_con(cdr(arg), cadaddr(cadr(arg))); - return(fx_not_is_eq_car_sq); - } - return(fx_not_a); - } - if (is_global_and_has_func(car(arg), s7_p_p_function)) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_p_function(global_value(car(arg))))); - return(fx_c_a_direct); - } - return(fx_c_a); - - case HOP_SAFE_C_AC: - if (fn_proc(arg) == g_cons) return(fx_cons_ac); - if (fx_matches(car(arg), sc->is_eq_symbol)) return(fx_is_eq_ac); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - if ((opt3_direct(cdr(arg)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) - set_opt3_direct(cdr(arg), string_ref_p_p0); - if (opt3_direct(cdr(arg)) == (s7_pointer)memq_p_pp) - { - if (fn_proc(arg) == g_memq_2) - set_opt3_direct(cdr(arg), (s7_pointer)memq_2_p_pp); - else - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) - set_opt3_direct(cdr(arg), memq_3_p_pp); - else - if (fn_proc(arg) == g_memq_4) - set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ - } - return(fx_c_ac_direct); - } - return(fx_c_ac); - - case HOP_SAFE_C_CA: - return((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); - - case HOP_SAFE_C_SA: - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_sa); - if (fn_proc(arg) == g_add_2) return(fx_add_sa); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return((fn_proc(arg) == g_cons) ? fx_cons_sa : fx_c_sa_direct); - } - return(fx_c_sa); - - case HOP_SAFE_C_AS: - if (fn_proc(arg) == g_add_2) return(fx_add_as); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return((fn_proc(arg) == g_cons) ? fx_cons_as : fx_c_as_direct); - } - return(fx_c_as); - - case HOP_SAFE_C_AA: /* (* wr (float-vector-ref rl 0 j)) (* wr (block-ref (vector-ref rl j) 0)) (- (float-vector-ref rl 0 i) tempr) */ - if (fn_proc(arg) == g_add_2) return(fx_add_aa); - if (fn_proc(arg) == g_subtract_2) return(fx_subtract_aa); - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_aa); - if (fn_proc(arg) == g_number_to_string) return(fx_number_to_string_aa); - if (fn_proc(arg) == g_cons) return(fx_cons_aa); - /* we can get here from gx_annotate which does not call fx_tree, where A=fx_unsafe_s */ - if (fx_proc(cdr(arg)) == fx_unsafe_s) return(fx_c_za); - return(fx_c_aa); - - case HOP_SAFE_C_opAAq: - return((fx_proc(cdadr(arg)) == fx_s) ? fx_c_opsaq : fx_c_opaaq); - - case HOP_SAFE_C_NA: - return((fn_proc(arg) == g_vector) ? fx_vector_na : fx_c_na); - - case HOP_SAFE_C_ALL_CA: - return((fn_proc(arg) == g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca); - - case HOP_SAFE_CLOSURE_S_A: - { - s7_pointer body = car(closure_body(opt1_lambda(arg))); - if (is_pair(body)) - { - if (optimize_op(body) == OP_AND_2A) - { - if ((fx_matches(caadr(body), sc->is_pair_symbol)) && - (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - return(fx_safe_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ - return(fx_safe_closure_s_and_2a); - } - if (optimize_op(body) == HOP_SAFE_C_opSq_C) - { - if ((fn_proc(body) == g_lint_let_ref) && - (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - { - set_opt2_sym(cdr(arg), cadaddr(body)); - return(fx_lint_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */ - }}} - return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_s_sqr : fx_safe_closure_s_a); - } - - case HOP_SAFE_CLOSURE_S_TO_SC: - { - s7_pointer body = car(closure_body(opt1_lambda(arg))); - if (fn_proc(body) == g_vector_ref_2) return(fx_safe_closure_s_to_vref); - if ((is_t_integer(caddr(body))) && (integer(caddr(body)) == 1)) - { - if (car(body) == sc->subtract_symbol) return(fx_safe_closure_s_to_sub1); - if (car(body) == sc->add_symbol) return(fx_safe_closure_s_to_add1); - } - return(fx_safe_closure_s_to_sc); - } - - case HOP_SAFE_CLOSURE_A_TO_SC: - return((fn_proc(car(closure_body(opt1_lambda(arg)))) == g_vector_ref_2) ? fx_safe_closure_a_to_vref : fx_safe_closure_a_to_sc); - - case HOP_SAFE_CLOSURE_A_A: - if (fx_proc(closure_body(opt1_lambda(arg))) == fx_and_2a) - return(fx_safe_closure_a_and_2a); - return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_a_sqr : fx_safe_closure_a_a); - - case HOP_SAFE_CLOSURE_3S_A: - if (fx_proc(closure_body(opt1_lambda(arg))) == fx_vref_vref_tu_v) return(fx_vref_vref_3_no_let); - return(fx_function[optimize_op(arg)]); - - case OP_IMPLICIT_S7_STARLET_REF_S: - if (opt3_int(arg) == SL_PRINT_LENGTH) return(fx_implicit_s7_starlet_print_length); - if (opt3_int(arg) == SL_SAFETY) return(fx_implicit_s7_starlet_safety); - return(fx_implicit_s7_starlet_ref_s); - - case HOP_C: - if ((is_unchanged_global(car(arg))) && (car(arg) == sc->curlet_symbol)) return(fx_curlet); - /* fall through */ - - default: - /* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ - return(fx_function[optimize_op(arg)]); - }} /* is_optimized */ - - if ((car(arg) == sc->quote_symbol) && - (is_global(sc->quote_symbol))) - { - check_quote(sc, arg); - return(fx_q); - } - return(NULL); -} - -#if S7_DEBUGGING -#define with_fx(P, F) with_fx_1(sc, P, F) -static bool with_fx_1(s7_scheme *sc, s7_pointer p, s7_function f) /* sc needed for set_opt2 under debugger = set_opt2_1(sc,...) */ -#else -static bool with_fx(s7_pointer p, s7_function f) -#endif -{ - set_fx_direct(p, f); - return(true); -} - -static bool o_var_ok(s7_pointer p, s7_pointer var1, s7_pointer var2, s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));} - -static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool unused_more_vars) -{ - s7_pointer p = car(tree); -#if 0 - if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) - fprintf(stderr, "%s[%d] %s %s %s %d %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", - has_fx(tree), unused_more_vars, display(p)); -#endif - if (is_symbol(p)) - { - if ((fx_proc(tree) == fx_s) || (fx_proc(tree) == fx_o)) - { - if (p == var1) return(with_fx(tree, fx_T)); - if (p == var2) return(with_fx(tree, fx_U)); - if (p == var3) return(with_fx(tree, fx_V)); - } - return(false); - } - if ((is_pair(p)) && (is_pair(cdr(p)))) - { - if (cadr(p) == var1) - { - if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ - if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_T)); - if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_T)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_T)); - if (fx_proc(tree) == fx_iterate_o) return(with_fx(tree, fx_iterate_T)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_T1)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_T1)); - if (fx_proc(tree) == fx_c_sca) return(with_fx(tree, fx_c_Tca)); - if ((fx_proc(tree) == fx_num_eq_si) || (fx_proc(tree) == fx_num_eq_s0) || (fx_proc(tree) == fx_num_eq_oi)) return(with_fx(tree, fx_num_eq_Ti)); - /* if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_Ts)); */ /* can be fooled -- there is no fx_cons_us etc -- need fx_cons_os */ - /* if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ - if ((fx_proc(tree) == fx_c_scs_direct) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_TcU_direct)); - if ((fx_proc(tree) == fx_hash_table_ref_ss) && (var3 == caddr(p))) return(with_fx(tree, fx_hash_table_ref_TV)); - if ((fx_proc(tree) == fx_geq_ss) && (var2 == caddr(p))) return(with_fx(tree, fx_geq_TU)); - } - else - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_U1)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_U1)); - if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_U)); - if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_U)); - } - else - if (cadr(p) == var3) - { - if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_V)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_V1)); - } - else - if (is_pair(cddr(p))) - { - if (caddr(p) == var1) - { - if ((fx_proc(tree) == fx_num_eq_ts) || (fx_proc(tree) == fx_num_eq_to)) return(with_fx(tree, fx_num_eq_tT)); - if ((fx_proc(tree) == fx_gt_ts) || (fx_proc(tree) == fx_gt_to)) return(with_fx(tree, fx_gt_tT)); - if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tT)); - if ((fx_proc(tree) == fx_geq_ts) || (fx_proc(tree) == fx_geq_to)) return(with_fx(tree, fx_geq_tT)); - } - else - if (caddr(p) == var2) - { - if (fx_proc(tree) == fx_c_ts) return(with_fx(tree, fx_c_tU)); - if (fx_proc(tree) == fx_cons_ts) return(with_fx(tree, fx_cons_tU)); - if (fx_proc(tree) == fx_c_ts_direct) return(with_fx(tree, fx_c_tU_direct)); - if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tU)); - if (fx_proc(tree) == fx_num_eq_us) return(with_fx(tree, fx_num_eq_uU)); - if (fx_proc(tree) == fx_num_eq_vs) return(with_fx(tree, fx_num_eq_vU)); - } - else - if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1)) return(with_fx(tree, fx_add_sqr_T)); - }} -#if 0 - if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) - fprintf(stderr, "%s[%d] %s %s %s %d %d: %s %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", - has_fx(tree), unused_more_vars, display(p), op_names[optimize_op(p)]); -#endif - return(false); -} - -static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) -{ - if ((!is_pair(tree)) || - ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) || - (is_syntax(car(tree)))) - return; - if ((!has_fx(tree)) || - (!fx_tree_out(sc, tree, var1, var2, var3, more_vars))) - fx_tree_outer(sc, car(tree), var1, var2, var3, more_vars); - fx_tree_outer(sc, cdr(tree), var1, var2, var3, more_vars); -} - -static s7_b_7p_t s7_b_7p_function(s7_pointer f); - -static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) -{ - s7_pointer p = car(tree); -#if 0 - /* if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) */ - fprintf(stderr, "fx_tree_in %s %s %s %s: %s, treed: %d\n", op_names[optimize_op(p)], - display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(p), is_fx_treed(tree)); -#endif - if (is_symbol(p)) - { - if (fx_proc(tree) == fx_s) - { - if (p == var1) return(with_fx(tree, fx_t)); - if (p == var2) return(with_fx(tree, fx_u)); - if (p == var3) return(with_fx(tree, fx_v)); - if (is_global(p)) return(with_fx(tree, fx_g)); - if (!more_vars) return(with_fx(tree, fx_o)); - } - return(false); - } - if ((!is_pair(p)) || (is_fx_treed(tree)) || (!has_fx(tree))) return(false); - set_fx_treed(tree); - switch (optimize_op(p)) - { - case HOP_SAFE_C_S: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_t)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, (opt2_direct(cdr(p)) == (s7_pointer)cddr_p_p) ? fx_cddr_t : fx_c_t_direct)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_t)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_t)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_t)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_t)); - if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_t)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_t)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_t)); - if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_t)); - if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_t)); - if (fx_proc(tree) == fx_is_string_s) return(with_fx(tree, fx_is_string_t)); - if (fx_proc(tree) == fx_is_vector_s) return(with_fx(tree, fx_is_vector_t)); - if (fx_proc(tree) == fx_is_integer_s) return(with_fx(tree, fx_is_integer_t)); - if (fx_proc(tree) == fx_is_procedure_s) return(with_fx(tree, fx_is_procedure_t)); - if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_t)); - if (fx_proc(tree) == fx_length_s) return(with_fx(tree, fx_length_t)); - if (fx_proc(tree) == fx_real_part_s) return(with_fx(tree, fx_real_part_t)); - if (fx_proc(tree) == fx_imag_part_s) return(with_fx(tree, fx_imag_part_t)); - return(false); - } - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_c_s) - { - if (is_global_and_has_func(car(p), s7_p_p_function)) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); - return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : - ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : - ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); - } - return(with_fx(tree, fx_c_u)); - } - if (fx_proc(tree) == fx_c_s_direct) - return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : - ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : - ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); - - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_u)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_u)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_u)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_u)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_u)); - if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_u)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_u)); - if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_u)); - if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_u)); - return(false); - } - if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_v)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); - return(false); - } - if (!more_vars) - { - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_o)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); - if (fx_proc(tree) == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); - if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_o)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_o)); - } - break; - - case HOP_SAFE_C_SC: - if (cadr(p) == var1) - { - if ((fx_proc(tree) == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc)); - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_tc)); - if (fx_proc(tree) == fx_add_sf) return(with_fx(tree, fx_add_tf)); - if (fn_proc(p) == g_less_xf) return(with_fx(tree, fx_lt_tf)); - if (fn_proc(p) == g_less_x0) return(with_fx(tree, fx_lt_t0)); - if (fn_proc(p) == g_less_xi) - return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); - if (fn_proc(p) == g_geq_xf) return(with_fx(tree, fx_geq_tf)); - if (fn_proc(p) == g_geq_xi) return(with_fx(tree, (integer(caddr(p)) == 0) ? fx_geq_t0 : fx_geq_ti)); - if (fn_proc(p) == g_leq_xi) return(with_fx(tree, fx_leq_ti)); - if (fn_proc(p) == g_greater_xi) return(with_fx(tree, fx_gt_ti)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ti)); - if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ti)); - - if (fx_proc(tree) == fx_c_sc_direct) /* p_pp cases */ - { - if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) - return(with_fx(tree, fx_vector_ref_tc)); - if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(p))) && (integer(caddr(p)) == 0)) - set_opt3_direct(cdr(p), string_ref_p_p0); - return(with_fx(tree, fx_c_tc_direct)); - } - if (fx_proc(tree) == fx_c_si_direct) /* p_pi cases */ - { - if (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pi) - return(with_fx(tree, fx_vector_ref_tc)); - if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pi) && (integer(caddr(p)) == 0)) - set_opt3_direct(cdr(p), string_ref_p_p0); - return(with_fx(tree, (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pi) ? fx_c_ti_remainder : fx_c_ti_direct)); - } - - if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_tc)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_t1)); - if (fx_proc(tree) == fx_add_si) return(with_fx(tree, fx_add_ti)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1)); - if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ti)); - if (fx_proc(tree) == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf)); - if (fx_proc(tree) == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf)); - if (fx_proc(tree) == fx_lt_si) /* is this ever hit? */ - return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ti)); - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_t0)); - if (fx_proc(tree) == fx_memq_sc) return(with_fx(tree, fx_memq_tc)); - return(false); - } - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_uc)); - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_u0)); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ui)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_u1)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); - if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ui)); - if (fx_proc(tree) == fx_multiply_si) return(with_fx(tree, fx_multiply_ui)); - if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_uc)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ui)); - if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ui)); - return(false); - } - if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_v1)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_v1)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_vi)); - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_vc)); - return(false); - } - if (!more_vars) - { - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_oi)); - if ((fx_proc(tree) == fx_c_sc) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_c_oc)); - } - break; - - case HOP_SAFE_C_CS: - if (caddr(p) == var1) - { - if ((car(p) == sc->cons_symbol) && (is_unchanged_global(sc->cons_symbol))) return(with_fx(tree, fx_cons_ct)); - if (fx_proc(tree) == fx_c_cs) - { - if (is_global_and_has_func(car(p), s7_p_pp_function)) - { - if (fn_proc(p) == g_tree_set_memq_1) - set_opt3_direct(cdr(p), (s7_pointer)tree_set_memq_direct); - else set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_fx_direct(tree, fx_c_ct_direct); - } - else set_fx_direct(tree, fx_c_ct); - return(true); - }} - if ((caddr(p) == var2) && (fx_proc(tree) == fx_c_cs)) return(with_fx(tree, fx_c_cu)); - break; - - case HOP_SAFE_C_SS: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu : fx_c_ts)); - if (fx_proc(tree) == fx_c_ss_direct) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu_direct : fx_c_ts_direct)); - if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_add_tu : fx_add_ts)); - if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_subtract_tu : fx_subtract_ts)); - if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_cons_tu : fx_cons_ts)); - if (caddr(p) == var2) - { - if (fx_proc(tree) == fx_gt_ss) return(with_fx(tree, fx_gt_tu)); - if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_tu)); - if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_tu)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_tu)); - if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_tu)); - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_tu)); - if (fx_proc(tree) == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); - } - if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); - if (fx_proc(tree) == fx_num_eq_ss) - { - if (caddr(p) == var3) return(with_fx(tree, fx_num_eq_tv)); - if (is_global(caddr(p))) return(with_fx(tree, fx_num_eq_tg)); - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); - return(with_fx(tree, fx_num_eq_ts)); - } - if (fx_proc(tree) == fx_geq_ss) - { - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_to)); - return(with_fx(tree, fx_geq_ts)); - } - if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); - if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); - if (fx_proc(tree) == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); - if (fx_proc(tree) == fx_gt_ss) - { - if (is_global(caddr(p))) return(with_fx(tree, fx_gt_tg)); - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_gt_to)); - return(with_fx(tree, fx_gt_ts)); - } - if (fx_proc(tree) == fx_sqr_s) return(with_fx(tree, fx_sqr_t)); - if (fx_proc(tree) == fx_is_eq_ss) - { - if (caddr(p) == var2) return(with_fx(tree, fx_is_eq_tu)); - if ((!more_vars) && (caddr(p) != var3) && (caddr(p) != var1)) return(with_fx(tree, fx_is_eq_to)); - return(with_fx(tree, fx_is_eq_ts)); - } - if (fx_proc(tree) == fx_vref_ss) - { - if (caddr(p) == var2) return(with_fx(tree, fx_vref_tu)); - return(with_fx(tree, fx_vref_ts)); - }} - if (caddr(p) == var1) - { - if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, fx_c_st)); - if (fx_proc(tree) == fx_c_ss_direct) {return(with_fx(tree, (is_global(cadr(p))) ? fx_c_gt_direct : fx_c_st_direct));} - if (fx_proc(tree) == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); - if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_st)); - if (fx_proc(tree) == fx_vref_ss) - { - if (is_global(cadr(p))) return(with_fx(tree, fx_vref_gt)); - if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3)) return(with_fx(tree, fx_vref_ot)); - return(with_fx(tree, fx_vref_st)); - } - if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_gt_ut)); - if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_lt_ut)); - if ((fx_proc(tree) == fx_geq_ss)) - { - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); - return(with_fx(tree, fx_geq_st)); - }} - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_num_eq_ut : fx_num_eq_us)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_us)); - if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_add_ut : ((caddr(p) == var3) ? fx_add_uv : fx_add_us))); - if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_subtract_ut : fx_subtract_us)); - if (caddr(p) == var3) return(with_fx(tree, fx_c_uv)); - } - if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_vs)); - if ((fx_proc(tree) == fx_add_ss) && (caddr(p) == var2)) return(with_fx(tree, fx_add_vu)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) ? fx_geq_vo : fx_geq_vs)); - } - break; - - case HOP_SAFE_C_AS: - if (caddr(p) == var1) return(with_fx(tree, fx_c_at)); - break; - - case HOP_SAFE_C_SA: - if (cadr(p) == var1) - { - if ((fx_proc(cddr(p)) == fx_c_opsq_c) && - (cadadr(caddr(p)) == var1) && - (is_t_integer(caddaddr(p))) && - (integer(caddaddr(p)) == 1) && - (car(p) == sc->string_ref_symbol) && - (caaddr(p) == sc->subtract_symbol) && -#if (!WITH_PURE_S7) - ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol))) -#else - (caadr(caddr(p)) == sc->length_symbol)) -#endif - return(with_fx(tree, fx_string_ref_t_last)); - return(with_fx(tree, fx_c_ta)); - } - if (cadr(p) == var2) return(with_fx(tree, (fx_proc(tree) == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); - break; - - case HOP_SAFE_C_SCS: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_scs) return(with_fx(tree, fx_c_tcs)); - if (fx_proc(tree) == fx_c_scs_direct) return(with_fx(tree, (cadddr(p) == var2) ? fx_c_tcu_direct : fx_c_tcs_direct)); - } - break; - - case HOP_SAFE_C_SSC: - if ((cadr(p) == var1) && (caddr(p) == var2)) return(with_fx(tree, fx_c_tuc)); - break; - - case HOP_SAFE_C_CSS: - if ((caddr(p) == var1) && (cadddr(p) == var3)) return(with_fx(tree, fx_c_ctv)); - break; - - case HOP_SAFE_C_SSS: - if ((cadr(p) == var1) && ((caddr(p) == var2) && ((fx_proc(tree) == fx_c_sss) || (fx_proc(tree) == fx_c_sss_direct)))) - return(with_fx(tree, (cadddr(p) == var3) ? ((fx_proc(tree) == fx_c_sss_direct) ? fx_c_tuv_direct : fx_c_tuv) : fx_c_tus)); - if (caddr(p) == var1) - { - if (car(p) == sc->vector_set_symbol) - { - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)) && (o_var_ok(cadddr(p), var1, var2, var3))) return(with_fx(tree, fx_vset_oto)); - return(with_fx(tree, fx_vset_sts)); - } - return(with_fx(tree, fx_c_sts)); - } - break; - - case HOP_SAFE_C_SSA: - if (cadr(p) == var1) return(with_fx(tree, fx_c_tsa)); /* tua is hit but not called much */ - if (caddr(p) == var1) return(with_fx(tree, fx_c_sta)); - break; - - case HOP_SAFE_C_opSq: - if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_is_pair_car_s) return(with_fx(tree, fx_is_pair_car_t)); - if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_t)); - if (fx_proc(tree) == fx_is_pair_cadr_s) return(with_fx(tree, fx_is_pair_cadr_t)); - if (fx_proc(tree) == fx_is_symbol_cadr_s) return(with_fx(tree, fx_is_symbol_cadr_t)); - if (fx_proc(tree) == fx_is_pair_cddr_s) return(with_fx(tree, fx_is_pair_cddr_t)); - if (fx_proc(tree) == fx_is_null_cdr_s) return(with_fx(tree, fx_is_null_cdr_t)); - if (fx_proc(tree) == fx_is_null_cadr_s) return(with_fx(tree, fx_is_null_cadr_t)); - if (fx_proc(tree) == fx_is_null_cddr_s) return(with_fx(tree, fx_is_null_cddr_t)); - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_t)); - if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_t)); - if (fx_proc(tree) == fx_not_is_symbol_s) return(with_fx(tree, fx_not_is_symbol_t)); - if (fx_proc(tree) == fx_is_type_car_s) - return(with_fx(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : fx_is_type_car_t)); - if (fx_proc(tree) == fx_c_opsq) - { - set_opt1_sym(cdr(p), cadadr(p)); - if ((is_global_and_has_func(car(p), s7_p_p_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, fx_c_optq_direct)); - } - return(with_fx(tree, fx_c_optq)); - } - if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_t)); - if (fx_proc(tree) == fx_c_cdr_s) return(with_fx(tree, fx_c_cdr_t)); - if (fx_proc(tree) == fx_is_type_opsq) return(with_fx(tree, fx_is_type_optq)); - if (fx_proc(tree) == fx_not_opsq) - { - set_opt1_sym(cdr(p), cadadr(p)); - return(with_fx(tree, (caadr(p) == sc->car_symbol) ? fx_not_car_t : fx_not_optq)); - }} - if (cadadr(p) == var2) - { - if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_u)); - if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_u)); - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_u)); - if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_u)); - } - if (cadadr(p) == var3) - { - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_v)); - } - break; - - case HOP_SAFE_C_opSq_S: - if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_c_opsq_s) - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, fx_c_optq_s_direct)); - } - return(with_fx(tree, fx_c_optq_s)); - } - if (fx_proc(tree) == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); - if (fx_proc(tree) == fx_cons_car_s_s) - { - set_opt1_sym(cdr(p), var1); - return(with_fx(tree, (caddr(p) == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); - }} - if (cadadr(p) == var2) - { - if ((fx_proc(tree) == fx_c_opsq_s) && (caddr(p) == var1)) - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) /* (memq (car sequence) items) lint */ - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, (car(p) == sc->cons_symbol) ? - ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); - } - return(with_fx(tree, fx_c_opuq_t)); - } - if (((fx_proc(tree) == fx_c_opsq_s_direct) || (fx_proc(tree) == fx_cons_car_s_s)) && - (caddr(p) == var1)) - return(with_fx(tree, (car(p) == sc->cons_symbol) ? - ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); - } - break; - - case HOP_SAFE_C_S_opSq: - if (cadr(p) == var1) - { - if (cadaddr(p) == var2) - { - if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_u)); - if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opuq_direct)); - } - if (cadaddr(p) == var3) - { - if (fx_proc(tree) == fx_add_s_car_s) return(with_fx(tree, fx_add_t_car_v)); - if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ - } - if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opsq_direct)); - } - if (cadr(p) == var2) - { - if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_fx(tree, fx_add_u_car_t)); - if ((fx_proc(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); - } - if ((cadaddr(p) == var1) && (fx_proc(tree) == fx_c_s_car_s)) return(with_fx(tree, fx_c_s_car_t)); - break; - - case HOP_SAFE_C_opSq_opSq: - if ((fx_proc(tree) == fx_c_opsq_opsq_direct) && (cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) - { - set_opt1_sym(cdr(p), cadadr(p)); - return(with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ - } - if (((fx_proc(tree) == fx_c_opsq_opsq_direct) || (fx_proc(tree) == fx_car_s_car_s)) && - ((caadr(p) == sc->car_symbol) && (caadr(p) == caaddr(p)))) - { - set_opt1_sym(cdr(p), cadadr(p)); - set_opt2_sym(cdr(p), cadaddr(p)); - return(with_fx(tree, ((cadadr(p) == var1) && (cadaddr(p) == var2)) ? - ((opt3_direct(p) == (s7_pointer)is_eq_p_pp) ? fx_is_eq_car_car_tu : fx_car_t_car_u) : fx_car_s_car_s)); - } - break; - - case HOP_SAFE_C_opSq_C: - if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_is_eq_car_sq) return(with_fx(tree, fx_is_eq_car_tq)); - if ((fx_proc(tree) == fx_c_opsq_c) || (fx_proc(tree) == fx_c_optq_c)) - { - if (fn_proc(p) != g_lint_let_ref) /* don't step on opt3_sym */ - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - if (fn_proc(p) == g_memq_2) - set_opt3_direct(p, (s7_pointer)memq_2_p_pp); - else set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - set_fx_direct(tree, fx_c_optq_c_direct); - return(true); - } - if ((is_t_integer(caddr(p))) && - (is_global_and_has_func(caadr(p), s7_i_7p_function)) && - (is_global_and_has_func(car(p), s7_p_ii_function))) - { - set_opt3_direct(p, (s7_pointer)(s7_p_ii_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_i_7p_function(global_value(caadr(p))))); - set_fx_direct(tree, fx_c_optq_i_direct); - } - else set_fx_direct(tree, fx_c_optq_c); - } - return(true); - }} - break; - - case HOP_SAFE_C_opSSq: - if (fx_proc(tree) == fx_c_opssq) - { - if (caddadr(p) == var1) return(with_fx(tree, fx_c_opstq)); - if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq)); - } - if (fx_proc(tree) == fx_c_opssq_direct) - { - if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq_direct)); - if (caddadr(p) == var1) - { - if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp) && - (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) - return(with_fx(tree, fx_is_zero_remainder_o)); - return(with_fx(tree, fx_c_opstq_direct)); - }} - if ((cadadr(p) == var2) && (fx_proc(tree) == fx_not_opssq) && (caddadr(p) == var1)) - { - set_fx_direct(tree, (fn_proc(cadr(p)) == g_less_2) ? fx_not_lt_ut : fx_not_oputq); - return(true); - } - break; - - case HOP_SAFE_C_opSCq: - if (cadadr(p) == var1) - { - if ((fn_proc(p) == g_is_zero) && (fn_proc(cadr(p)) == g_remainder) && - (is_t_integer(caddadr(p))) && (integer(caddadr(p)) > 1)) - return(with_fx(tree, fx_is_zero_remainder_ti)); - return(with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ - } - break; - - case HOP_SAFE_C_opSSq_C: - if ((fx_proc(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) - { - if (is_global_and_has_func(car(p), s7_p_pp_function)) - { - if ((car(p) == sc->is_eq_symbol) && (!is_unspecified(caddr(p))) && (caadr(p) == sc->vector_ref_symbol) && - (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) - return(with_fx(tree, fx_is_eq_vref_opotq_c)); - set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - return(with_fx(tree, fx_c_opstq_c_direct)); - } - return(with_fx(tree, fx_c_opstq_c)); - } - break; - - case HOP_SAFE_C_S_opSCq: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_s_opscq_direct) return(with_fx(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); - if ((fx_proc(tree) == fx_c_s_opsiq_direct) && (!more_vars) && (o_var_ok(cadaddr(p), var1, var2, var3))) return(with_fx(tree, fx_c_t_opoiq_direct)); - } - else - if ((cadr(p) == var2) && (cadaddr(p) == var1)) - { - if (fx_proc(tree) == fx_c_s_opsiq_direct) return(with_fx(tree, fx_c_u_optiq_direct)); - if (fx_proc(tree) == fx_c_s_opscq) return(with_fx(tree, fx_c_u_optcq)); - } - break; - - case HOP_SAFE_C_opSq_CS: - if ((cadadr(p) == var1) && (fx_proc(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_optq_cu)); - break; - - case HOP_SAFE_C_opSq_opSSq: - if ((fx_proc(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1) && (caddaddr(p) == var2) && - (is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function)) && - (is_global_and_has_func(caaddr(p), s7_p_pp_function))) - { - set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(caaddr(p))))); - set_opt1_sym(cdr(p), var2); /* caddaddr(p) */ - - set_opt2_sym(cddr(p), var1); - if ((car(p) == sc->num_eq_symbol) && (caadr(p) == sc->car_symbol) && (cadadr(p) == var3)) - { - if (caaddr(p) == sc->add_symbol) return(with_fx(tree, fx_num_eq_car_v_add_tu)); - if (caaddr(p) == sc->subtract_symbol) return(with_fx(tree, fx_num_eq_car_v_subtract_tu)); - } - return(with_fx(tree, fx_c_opsq_optuq_direct)); - } - break; - - case HOP_SAFE_C_opSSq_S: - if (fx_proc(tree) == fx_vref_vref_ss_s) - { - if ((caddr(p) == var1) && (is_global(cadadr(p)))) - { - if ((!more_vars) && (o_var_ok(caddadr(p), var1, var2, var3))) return(with_fx(tree, fx_vref_vref_go_t)); - return(with_fx(tree, fx_vref_vref_gs_t)); - } - if ((cadadr(p) == var1) && (caddadr(p) == var2) && (caddr(p) == var3)) return(with_fx(tree, fx_vref_vref_tu_v)); - } - if ((fx_proc(tree) == fx_gt_add_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) - return(with_fx(tree, fx_gt_add_tu_s)); - if ((fx_proc(tree) == fx_add_sub_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) - return(with_fx(tree, fx_add_sub_tu_s)); - break; - - case HOP_SAFE_C_S_opSSq: - if (caddaddr(p) == var1) - { - if ((fn_proc(p) == g_vector_ref_2) && (is_global(cadr(p)) && (is_global(cadaddr(p))))) - { - set_opt3_pair(p, cdaddr(p)); - return(with_fx(tree, fx_vref_g_vref_gt)); - } - if (fx_proc(tree) == fx_c_s_opssq_direct) return(with_fx(tree, fx_c_s_opstq_direct)); - } - if ((fx_proc(tree) == fx_c_s_opssq_direct) && (cadr(p) == var1) && (caddaddr(p) == var2)) return(with_fx(tree, fx_c_t_opsuq_direct)); - break; - - case HOP_SAFE_C_op_opSq_Sq: - if ((car(p) == sc->not_symbol) && (is_global(sc->not_symbol)) && (var1 == cadr(cadadr(p)))) - return(with_fx(tree, fx_not_op_optq_sq)); - break; - - case HOP_SAFE_C_AC: - if (((fx_proc(tree) == fx_c_ac) || (fx_proc(tree) == fx_c_ac_direct)) && (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero) && - (fx_proc(cdr(p)) == fx_c_opuq_t_direct) && (caadr(p) == sc->remainder_symbol) && (fn_proc(cadadr(p)) == g_car)) - { - set_opt3_sym(p, cadr(cadadr(p))); - set_opt1_sym(cdr(p), caddadr(p)); - return(with_fx(tree, fx_is_zero_remainder_car)); - } - break; - - case HOP_SAFE_CLOSURE_S_A: - if ((cadr(p) == var1) && (fx_proc(tree) == fx_safe_closure_s_a)) return(with_fx(tree, fx_safe_closure_t_a)); - break; - - case OP_IF_S_A_A: - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_if_o_a_a)); - break; - - case OP_AND_3A: - if ((fx_proc(tree) == fx_and_3a) && - (is_pair(cadr(p))) && - (is_pair(cdadr(p))) && (cadadr(p) == var1) && /* so "s" below is "t" */ - (((fx_proc(cdr(p)) == fx_is_pair_t) && (fx_proc(cddr(p)) == fx_is_pair_cdr_t)) || - ((fx_proc(cdr(p)) == fx_is_pair_s) && (fx_proc(cddr(p)) == fx_is_pair_cdr_s)))) - { - set_opt1_sym(cdr(p), cadadr(p)); - if ((fx_proc(cdddr(p)) == fx_is_null_cddr_t) || (fx_proc(cdddr(p)) == fx_is_null_cddr_s)) - return(with_fx(tree, fx_len2_t)); - if ((fx_proc(cdddr(p)) == fx_is_pair_cddr_t) || (fx_proc(cdddr(p)) == fx_is_pair_cddr_s)) - return(with_fx(tree, fx_len3_t)); - } - break; - } -#if 0 - if ((var3) && ((s7_tree_memq(sc, var1, car(tree))) || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) && (s7_tree_memq(sc, var3, car(tree)))))) - fprintf(stderr, "fx_tree_in %s %s %s: %s %s\n", - display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(car(tree)), op_names[optimize_op(car(tree))]); -#endif - return(false); -} - -static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) -{ - /* if (is_pair(tree)) fprintf(stderr, "fx_tree %s %d %d\n", display(tree), has_fx(tree), is_syntax(car(tree))); */ - if (!is_pair(tree)) return; - if ((is_symbol(car(tree))) && - (is_definer_or_binder(car(tree)))) - { - if ((car(tree) == sc->let_symbol) && (is_pair(cdr(tree))) && (is_pair(cadr(tree))) && - (is_null(cdadr(tree))) && (is_pair(caadr(tree)))) /* (let (a) ...) */ - fx_tree(sc, cddr(tree), caaadr(tree), NULL, NULL, more_vars); - return; - } - if (is_syntax(car(tree))) return; /* someday let #_when/#_if etc through -- the symbol 'if, for example, is not syntax */ - - if ((!has_fx(tree)) || - (!fx_tree_in(sc, tree, var1, var2, var3, more_vars))) - fx_tree(sc, car(tree), var1, var2, var3, more_vars); - fx_tree(sc, cdr(tree), var1, var2, var3, more_vars); -} - -/* -------------------------------------------------------------------------------- */ -static opt_funcs_t *alloc_semipermanent_opt_func(s7_scheme *sc) -{ - if (sc->alloc_opt_func_k == ALLOC_FUNCTION_SIZE) - { - sc->alloc_opt_func_cells = (opt_funcs_t *)Malloc(ALLOC_FUNCTION_SIZE * sizeof(opt_funcs_t)); - add_saved_pointer(sc, sc->alloc_opt_func_cells); - sc->alloc_opt_func_k = 0; - } - return(&(sc->alloc_opt_func_cells[sc->alloc_opt_func_k++])); -} - -static void add_opt_func(s7_scheme *sc, s7_pointer f, opt_func_t typ, void *func) -{ - opt_funcs_t *op; -#if S7_DEBUGGING - static const char *o_names[] = {"o_d_v", "o_d_vd", "o_d_vdd", "o_d_vid", "o_d_id", "o_d_7pi", "o_d_7pii", "o_d_7piid", "o_d_7piii", "o_d_7piiid", - "o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd", "o_d_7dd", "o_d_ddd", "o_d_dddd", - "o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi", "o_i_7pii", "o_i_7_piii", "o_d_p", - "o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked", "o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd", - "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", "o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked", - "o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked", "o_p_piip", "o_b_i", "o_b_d"}; - if (!is_c_function(f)) - { - fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(f)); - if (sc->stop_at_error) abort(); - } - else - if (c_function_opt_data(f)) - for (opt_funcs_t *p = c_function_opt_data(f); p; p = p->next) - { - if (p->typ == typ) - fprintf(stderr, "%s[%d]: %s has a function of type %d (%s)\n", - __func__, __LINE__, display(f), typ, o_names[typ]); - if (p->func == func) - fprintf(stderr, "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", - __func__, __LINE__, display(f), p->typ, o_names[p->typ], typ, o_names[typ]); - } -#endif - op = alloc_semipermanent_opt_func(sc); - op->typ = typ; - op->func = func; - op->next = c_function_opt_data(f); - c_function_opt_data(f) = op; -} - -static void *opt_func(s7_pointer f, opt_func_t typ) -{ - if (is_c_function(f)) - for (opt_funcs_t *p = c_function_opt_data(f); p; p = p->next) - if (p->typ == typ) - return(p->func); - return(NULL); -} - -/* clm2xen.c */ -void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df) {add_opt_func(sc, f, o_d, (void *)df);} -s7_d_t s7_d_function(s7_pointer f) {return((s7_d_t)opt_func(f, o_d));} - -void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df) {add_opt_func(sc, f, o_d_d, (void *)df);} -s7_d_d_t s7_d_d_function(s7_pointer f) {return((s7_d_d_t)opt_func(f, o_d_d));} - -void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df) {add_opt_func(sc, f, o_d_dd, (void *)df);} -s7_d_dd_t s7_d_dd_function(s7_pointer f) {return((s7_d_dd_t)opt_func(f, o_d_dd));} - -void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df) {add_opt_func(sc, f, o_d_v, (void *)df);} -s7_d_v_t s7_d_v_function(s7_pointer f) {return((s7_d_v_t)opt_func(f, o_d_v));} - -void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df) {add_opt_func(sc, f, o_d_vd, (void *)df);} -s7_d_vd_t s7_d_vd_function(s7_pointer f) {return((s7_d_vd_t)opt_func(f, o_d_vd));} - -void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df) {add_opt_func(sc, f, o_d_vdd, (void *)df);} -s7_d_vdd_t s7_d_vdd_function(s7_pointer f) {return((s7_d_vdd_t)opt_func(f, o_d_vdd));} - -void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df) {add_opt_func(sc, f, o_d_vid, (void *)df);} -s7_d_vid_t s7_d_vid_function(s7_pointer f) {return((s7_d_vid_t)opt_func(f, o_d_vid));} - -void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df) {add_opt_func(sc, f, o_d_id, (void *)df);} -s7_d_id_t s7_d_id_function(s7_pointer f) {return((s7_d_id_t)opt_func(f, o_d_id));} - -void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df) {add_opt_func(sc, f, o_d_7pid, (void *)df);} -s7_d_7pid_t s7_d_7pid_function(s7_pointer f) {return((s7_d_7pid_t)opt_func(f, o_d_7pid));} - -void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df) {add_opt_func(sc, f, o_d_ip, (void *)df);} -s7_d_ip_t s7_d_ip_function(s7_pointer f) {return((s7_d_ip_t)opt_func(f, o_d_ip));} - -void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df) {add_opt_func(sc, f, o_d_pd, (void *)df);} -s7_d_pd_t s7_d_pd_function(s7_pointer f) {return((s7_d_pd_t)opt_func(f, o_d_pd));} - -void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df) {add_opt_func(sc, f, o_d_p, (void *)df);} -s7_d_p_t s7_d_p_function(s7_pointer f) {return((s7_d_p_t)opt_func(f, o_d_p));} - -void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df) {add_opt_func(sc, f, o_b_p, (void *)df);} -s7_b_p_t s7_b_p_function(s7_pointer f) {return((s7_b_p_t)opt_func(f, o_b_p));} - -void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df) {add_opt_func(sc, f, o_d_7pi, (void *)df);} -s7_d_7pi_t s7_d_7pi_function(s7_pointer f) {return((s7_d_7pi_t)opt_func(f, o_d_7pi));} - -static void s7_set_d_7pii_function(s7_scheme *sc, s7_pointer f, s7_d_7pii_t df) {add_opt_func(sc, f, o_d_7pii, (void *)df);} -static s7_d_7pii_t s7_d_7pii_function(s7_pointer f) {return((s7_d_7pii_t)opt_func(f, o_d_7pii));} - -static void s7_set_d_7piii_function(s7_scheme *sc, s7_pointer f, s7_d_7piii_t df) {add_opt_func(sc, f, o_d_7piii, (void *)df);} -static s7_d_7piii_t s7_d_7piii_function(s7_pointer f) {return((s7_d_7piii_t)opt_func(f, o_d_7piii));} - -void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df) {add_opt_func(sc, f, o_i_7p, (void *)df);} -s7_i_7p_t s7_i_7p_function(s7_pointer f) {return((s7_i_7p_t)opt_func(f, o_i_7p));} - -/* cload.scm */ -void s7_set_d_ddd_function(s7_scheme *sc, s7_pointer f, s7_d_ddd_t df) {add_opt_func(sc, f, o_d_ddd, (void *)df);} -s7_d_ddd_t s7_d_ddd_function(s7_pointer f) {return((s7_d_ddd_t)opt_func(f, o_d_ddd));} - -void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df) {add_opt_func(sc, f, o_d_dddd, (void *)df);} -s7_d_dddd_t s7_d_dddd_function(s7_pointer f) {return((s7_d_dddd_t)opt_func(f, o_d_dddd));} - -void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df) {add_opt_func(sc, f, o_i_i, (void *)df);} -s7_i_i_t s7_i_i_function(s7_pointer f) {return((s7_i_i_t)opt_func(f, o_i_i));} - -void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df) {add_opt_func(sc, f, o_i_ii, (void *)df);} -s7_i_ii_t s7_i_ii_function(s7_pointer f) {return((s7_i_ii_t)opt_func(f, o_i_ii));} - -void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df) {add_opt_func(sc, f, o_i_7d, (void *)df);} -s7_i_7d_t s7_i_7d_function(s7_pointer f) {return((s7_i_7d_t)opt_func(f, o_i_7d));} - -/* s7test.scm */ -void s7_set_p_d_function(s7_scheme *sc, s7_pointer f, s7_p_d_t df) {add_opt_func(sc, f, o_p_d, (void *)df);} -s7_p_d_t s7_p_d_function(s7_pointer f) {return((s7_p_d_t)opt_func(f, o_p_d));} - -static void s7_set_d_7dd_function(s7_scheme *sc, s7_pointer f, s7_d_7dd_t df) {add_opt_func(sc, f, o_d_7dd, (void *)df);} -static s7_d_7dd_t s7_d_7dd_function(s7_pointer f) {return((s7_d_7dd_t)opt_func(f, o_d_7dd));} - -static void s7_set_i_7i_function(s7_scheme *sc, s7_pointer f, s7_i_7i_t df) {add_opt_func(sc, f, o_i_7i, (void *)df);} -static s7_i_7i_t s7_i_7i_function(s7_pointer f) {return((s7_i_7i_t)opt_func(f, o_i_7i));} - -static void s7_set_i_7ii_function(s7_scheme *sc, s7_pointer f, s7_i_7ii_t df) {add_opt_func(sc, f, o_i_7ii, (void *)df);} -static s7_i_7ii_t s7_i_7ii_function(s7_pointer f) {return((s7_i_7ii_t)opt_func(f, o_i_7ii));} - -static void s7_set_i_iii_function(s7_scheme *sc, s7_pointer f, s7_i_iii_t df) {add_opt_func(sc, f, o_i_iii, (void *)df);} -s7_i_iii_t s7_i_iii_function(s7_pointer f) {return((s7_i_iii_t)opt_func(f, o_i_iii));} - -static void s7_set_p_pi_function(s7_scheme *sc, s7_pointer f, s7_p_pi_t df) {add_opt_func(sc, f, o_p_pi, (void *)df);} -static s7_p_pi_t s7_p_pi_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, o_p_pi));} - -static void s7_set_p_ppi_function(s7_scheme *sc, s7_pointer f, s7_p_ppi_t df) {add_opt_func(sc, f, o_p_ppi, (void *)df);} -static s7_p_ppi_t s7_p_ppi_function(s7_pointer f) {return((s7_p_ppi_t)opt_func(f, o_p_ppi));} - -static void s7_set_i_7pi_function(s7_scheme *sc, s7_pointer f, s7_i_7pi_t df) {add_opt_func(sc, f, o_i_7pi, (void *)df);} -static s7_i_7pi_t s7_i_7pi_function(s7_pointer f) {return((s7_i_7pi_t)opt_func(f, o_i_7pi));} - -static void s7_set_i_7pii_function(s7_scheme *sc, s7_pointer f, s7_i_7pii_t df) {add_opt_func(sc, f, o_i_7pii, (void *)df);} -static s7_i_7pii_t s7_i_7pii_function(s7_pointer f) {return((s7_i_7pii_t)opt_func(f, o_i_7pii));} - -static void s7_set_i_7piii_function(s7_scheme *sc, s7_pointer f, s7_i_7piii_t df) {add_opt_func(sc, f, o_i_7piii, (void *)df);} -static s7_i_7piii_t s7_i_7piii_function(s7_pointer f) {return((s7_i_7piii_t)opt_func(f, o_i_7piii));} - -static void s7_set_b_d_function(s7_scheme *sc, s7_pointer f, s7_b_d_t df) {add_opt_func(sc, f, o_b_d, (void *)df);} -static s7_b_d_t s7_b_d_function(s7_pointer f) {return((s7_b_d_t)opt_func(f, o_b_d));} - -static void s7_set_b_i_function(s7_scheme *sc, s7_pointer f, s7_b_i_t df) {add_opt_func(sc, f, o_b_i, (void *)df);} -static s7_b_i_t s7_b_i_function(s7_pointer f) {return((s7_b_i_t)opt_func(f, o_b_i));} - -static void s7_set_b_7p_function(s7_scheme *sc, s7_pointer f, s7_b_7p_t df) {add_opt_func(sc, f, o_b_7p, (void *)df);} -static s7_b_7p_t s7_b_7p_function(s7_pointer f) {return((s7_b_7p_t)opt_func(f, o_b_7p));} - -static void s7_set_b_pp_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp, (void *)df);} -static s7_b_pp_t s7_b_pp_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp));} - -static void s7_set_b_7pp_function(s7_scheme *sc, s7_pointer f, s7_b_7pp_t df) {add_opt_func(sc, f, o_b_7pp, (void *)df);} -static s7_b_7pp_t s7_b_7pp_function(s7_pointer f) {return((s7_b_7pp_t)opt_func(f, o_b_7pp));} - -static void s7_set_d_7d_function(s7_scheme *sc, s7_pointer f, s7_d_7d_t df) {add_opt_func(sc, f, o_d_7d, (void *)df);} -static s7_d_7d_t s7_d_7d_function(s7_pointer f) {return((s7_d_7d_t)opt_func(f, o_d_7d));} - -static void s7_set_b_pi_function(s7_scheme *sc, s7_pointer f, s7_b_pi_t df) {add_opt_func(sc, f, o_b_pi, (void *)df);} -static s7_b_pi_t s7_b_pi_function(s7_pointer f) {return((s7_b_pi_t)opt_func(f, o_b_pi));} - -static void s7_set_b_ii_function(s7_scheme *sc, s7_pointer f, s7_b_ii_t df) {add_opt_func(sc, f, o_b_ii, (void *)df);} -static s7_b_ii_t s7_b_ii_function(s7_pointer f) {return((s7_b_ii_t)opt_func(f, o_b_ii));} - -static void s7_set_b_7ii_function(s7_scheme *sc, s7_pointer f, s7_b_7ii_t df) {add_opt_func(sc, f, o_b_7ii, (void *)df);} -static s7_b_7ii_t s7_b_7ii_function(s7_pointer f) {return((s7_b_7ii_t)opt_func(f, o_b_7ii));} - -static void s7_set_b_dd_function(s7_scheme *sc, s7_pointer f, s7_b_dd_t df) {add_opt_func(sc, f, o_b_dd, (void *)df);} -static s7_b_dd_t s7_b_dd_function(s7_pointer f) {return((s7_b_dd_t)opt_func(f, o_b_dd));} - -void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df) {add_opt_func(sc, f, o_p_p, (void *)df);} -s7_p_p_t s7_p_p_function(s7_pointer f) {return((s7_p_p_t)opt_func(f, o_p_p));} - -static void s7_set_p_function(s7_scheme *sc, s7_pointer f, s7_p_t df) {add_opt_func(sc, f, o_p, (void *)df);} -static s7_p_t s7_p_function(s7_pointer f) {return((s7_p_t)opt_func(f, o_p));} - -void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df) {add_opt_func(sc, f, o_p_pp, (void *)df);} -s7_p_pp_t s7_p_pp_function(s7_pointer f) {return((s7_p_pp_t)opt_func(f, o_p_pp));} - -void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df) {add_opt_func(sc, f, o_p_ppp, (void *)df);} -s7_p_ppp_t s7_p_ppp_function(s7_pointer f) {return((s7_p_ppp_t)opt_func(f, o_p_ppp));} - -static void s7_set_p_pip_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip, (void *)df);} -static s7_p_pip_t s7_p_pip_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip));} - -static void s7_set_p_pii_function(s7_scheme *sc, s7_pointer f, s7_p_pii_t df) {add_opt_func(sc, f, o_p_pii, (void *)df);} -static s7_p_pii_t s7_p_pii_function(s7_pointer f) {return((s7_p_pii_t)opt_func(f, o_p_pii));} - -static void s7_set_p_piip_function(s7_scheme *sc, s7_pointer f, s7_p_piip_t df) {add_opt_func(sc, f, o_p_piip, (void *)df);} -static s7_p_piip_t s7_p_piip_function(s7_pointer f) {return((s7_p_piip_t)opt_func(f, o_p_piip));} - -static void s7_set_p_pi_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pi_t df) {add_opt_func(sc, f, o_p_pi_unchecked, (void *)df);} -static s7_p_pi_t s7_p_pi_unchecked_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, o_p_pi_unchecked));} - -static void s7_set_p_pip_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip_unchecked, (void *)df);} -static s7_p_pip_t s7_p_pip_unchecked_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip_unchecked));} - -static void s7_set_b_pp_unchecked_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp_unchecked, (void *)df);} -static s7_b_pp_t s7_b_pp_unchecked_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp_unchecked));} - -static void s7_set_p_i_function(s7_scheme *sc, s7_pointer f, s7_p_i_t df) {add_opt_func(sc, f, o_p_i, (void *)df);} -static s7_p_i_t s7_p_i_function(s7_pointer f) {return((s7_p_i_t)opt_func(f, o_p_i));} - -static void s7_set_p_ii_function(s7_scheme *sc, s7_pointer f, s7_p_ii_t df) {add_opt_func(sc, f, o_p_ii, (void *)df);} -static s7_p_ii_t s7_p_ii_function(s7_pointer f) {return((s7_p_ii_t)opt_func(f, o_p_ii));} - -static void s7_set_d_7piid_function(s7_scheme *sc, s7_pointer f, s7_d_7piid_t df) {add_opt_func(sc, f, o_d_7piid, (void *)df);} -static s7_d_7piid_t s7_d_7piid_function(s7_pointer f) {return((s7_d_7piid_t)opt_func(f, o_d_7piid));} - -static void s7_set_d_7piiid_function(s7_scheme *sc, s7_pointer f, s7_d_7piiid_t df) {add_opt_func(sc, f, o_d_7piiid, (void *)df);} -static s7_d_7piiid_t s7_d_7piiid_function(s7_pointer f) {return((s7_d_7piiid_t)opt_func(f, o_d_7piiid));} - -static void s7_set_p_dd_function(s7_scheme *sc, s7_pointer f, s7_p_dd_t df) {add_opt_func(sc, f, o_p_dd, (void *)df);} -static s7_p_dd_t s7_p_dd_function(s7_pointer f) {return((s7_p_dd_t)opt_func(f, o_p_dd));} - -static opt_info *alloc_opt_info(s7_scheme *sc) -{ - opt_info *o; - if (sc->pc >= OPTS_SIZE) - sc->pc = OPTS_SIZE - 1; - o = sc->opts[sc->pc++]; - o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */ - return(o); -} - -#define backup_pc(sc) sc->pc-- - -#define OPT_PRINT 0 -#if OPT_PRINT - -#define green_text "\033[32m" -#define blue_text "\033[34m" -#define red_text "\033[31m" -#define uncolor_text "\033[0m" /* yellow=33 */ - -#define return_false(Sc, Expr) return(return_false_1(Sc, Expr, __func__, __LINE__)) -static bool return_false_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) -{ - if (expr) - fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, display_80(expr)); - else fprintf(stderr, " %s%s[%d]%s: false\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - return(false); -} - -#define return_true(Sc, Expr) return(return_true_1(Sc, Expr, __func__, __LINE__)) -static bool return_true_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) -{ - if (expr) - fprintf(stderr, " %s%s[%d]%s: %s\n", blue_text, func, line, uncolor_text, display_80(expr)); - else fprintf(stderr, " %s%s[%d]%s: true\n", blue_text, func, line, uncolor_text); - return(true); -} - -#define return_success(Sc, P, Expr) return(return_success_1(Sc, P, Expr, __func__, __LINE__)) -static s7_pfunc return_success_1(s7_scheme *sc, s7_pfunc p, s7_pointer expr, const char *func, int32_t line) -{ - fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT green_text, func, line, UNBOLD_TEXT uncolor_text, display(expr)); - return(p); -} - -#define return_null(Sc, Expr) return(return_null_1(Sc, Expr, __func__, __LINE__)) -static s7_pfunc return_null_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) -{ - fprintf(stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, display_80(expr), BOLD_TEXT red_text, UNBOLD_TEXT uncolor_text); - return(NULL); -} -#else -#define return_false(Sc, Expr) return(false) -#define return_true(Sc, Expr) return(true) -#define return_success(Sc, P, Expr) return(P) -#define return_null(Sc, Expr) return(NULL) -#endif - -static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (is_t_integer(slot_value(p)))) - return(p); - } - return(NULL); -} - -static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (is_small_real(slot_value(p)))) - return(p); - } - return(NULL); -} - -static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (is_t_real(slot_value(p)))) - return(p); - } - return(NULL); -} - -static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) -{ - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (!has_methods(slot_value(p)))) - return(p); - return(NULL); -} - -static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sym) -{ - s7_pointer checker = s7_symbol_value(sc, check); - s7_pointer slot = lookup_slot_from(sym, sc->curlet); - if (is_slot(slot)) - { - s7_pointer obj = slot_value(slot); - if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T) - return(slot); - } - return(NULL); -} - -static s7_pointer opt_bool_any(s7_scheme *sc) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} -static s7_pointer opt_float_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fd(sc->opts[0]); return(NULL);} -static s7_pointer opt_int_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fi(sc->opts[0]); return(NULL);} -static s7_pointer opt_bool_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fb(sc->opts[0]); return(NULL);} -static s7_pointer opt_cell_any_nv(s7_scheme *sc) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} /* this is faster than returning null */ - -static s7_pointer opt_wrap_float(s7_scheme *sc) {return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));} -static s7_pointer opt_wrap_int(s7_scheme *sc) {return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));} -static s7_pointer opt_wrap_cell(s7_scheme *sc) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} -static s7_pointer opt_wrap_bool(s7_scheme *sc) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} - -static bool p_to_b(opt_info *o) {return(o->v[O_WRAP].fp(o) != o->sc->F);} -static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, o->v[O_WRAP].fd(o)));} -static s7_pointer d_to_p_nr(opt_info *o) {o->v[O_WRAP].fd(o); return(NULL);} -static s7_pointer i_to_p(opt_info *o) {return(make_integer(o->sc, o->v[O_WRAP].fi(o)));} -static s7_pointer i_to_p_nr(opt_info *o) {o->v[O_WRAP].fi(o); return(NULL);} - - -/* -------------------------------- int opts -------------------------------- */ -static bool int_optimize(s7_scheme *sc, s7_pointer expr); -static bool float_optimize(s7_scheme *sc, s7_pointer expr); - -static s7_int opt_i_c(opt_info *o) {return(o->v[1].i);} -static s7_int opt_i_s(opt_info *o) {return(integer(slot_value(o->v[1].p)));} - -static bool opt_int_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - opt_info *opc; - s7_pointer p; - if (is_t_integer(car_x)) - { - opc = alloc_opt_info(sc); - opc->v[1].i = integer(car_x); - opc->v[0].fi = opt_i_c; - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, car_x); - if (!p) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fi = opt_i_s; - return_true(sc, car_x); -} - -/* -------- i_i|d|p -------- */ -static s7_int opt_i_i_c(opt_info *o) {return(o->v[2].i_i_f(o->v[1].i));} -static s7_int opt_i_i_s(opt_info *o) {return(o->v[2].i_i_f(integer(slot_value(o->v[1].p))));} -static s7_int opt_i_7i_c(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[1].i));} -static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(o->sc, integer(slot_value(o->v[1].p))));} -static s7_int opt_i_7i_s_rand(opt_info *o) {return(random_i_7i(o->sc, integer(slot_value(o->v[1].p))));} -static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[1].x));} -static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));} - -static s7_int opt_i_i_f(opt_info *o) {return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));} -static s7_int opt_i_7i_f(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));} -static s7_int opt_i_7d_f(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));} -static s7_int opt_i_7p_f(opt_info *o) {return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_int opt_i_7p_f_cint(opt_info *o) {return(char_to_integer_i_7p(o->sc, o->v[4].fp(o->v[3].o1)));} - -static s7_int opt_i_i_s_abs(opt_info *o) {return(abs_i_i(integer(slot_value(o->v[1].p))));} -static s7_int opt_i_i_f_abs(opt_info *o) {return(abs_i_i(o->v[4].fi(o->v[3].o1)));} - -static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_i_i_t func = s7_i_i_function(s_func); - s7_i_7i_t func7 = NULL; - s7_i_7p_t ipf; - s7_pointer p; - int32_t start = sc->pc; - opc->v[3].o1 = sc->opts[start]; - if (!func) - func7 = s7_i_7i_function(s_func); - if ((func) || (func7)) - { - if (func) - opc->v[2].i_i_f = func; - else opc->v[2].i_7i_f = func7; - if (is_t_integer(cadr(car_x))) - { - if (opc->v[2].i_i_f == subtract_i_i) - { - opc->v[1].i = -integer(cadr(car_x)); - opc->v[0].fi = opt_i_c; - } - else - { - opc->v[1].i = integer(cadr(car_x)); - opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c; - } - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) : ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s); - return_true(sc, car_x); - } - if (int_optimize(sc, cdr(car_x))) - { - opc->v[4].fi = sc->opts[start]->v[0].fi; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : opt_i_7i_f; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (!is_t_ratio(cadr(car_x))) - { - s7_i_7d_t idf = s7_i_7d_function(s_func); - if (idf) - { - opc->v[2].i_7d_f = idf; - if (is_small_real(cadr(car_x))) - { - opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); - opc->v[0].fi = opt_i_d_c; - return_true(sc, car_x); - } - p = opt_float_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[0].fi = opt_i_d_s; - return_true(sc, car_x); - } - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fi = opt_i_7d_f; - opc->v[4].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - ipf = s7_i_7p_function(s_func); - if (ipf) - { - opc->v[2].i_7p_f = ipf; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fi = (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; - opc->v[4].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - - -/* -------- i_pi -------- */ - -static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_7pi_ss_ivref(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_7pi_ss_bvref(opt_info *o) {return(byte_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7pi_sf(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} - -static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_i_7pi_t pfunc = s7_i_7pi_function(s_func); - if (!pfunc) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if (is_pair(sig)) - { - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - int32_t start = sc->pc; - if ((is_symbol(cadr(sig))) && - (is_symbol(arg1)) && - (slot = opt_types_match(sc, cadr(sig), arg1))) - { - s7_pointer p; - opc->v[1].p = slot; - if ((s_func == global_value(sc->int_vector_ref_symbol)) && /* ivref etc */ - ((!is_int_vector(slot_value(slot))) || - (vector_rank(slot_value(slot)) > 1))) - return_false(sc, car_x); - if ((s_func == global_value(sc->byte_vector_ref_symbol)) && /* bvref etc */ - ((!is_byte_vector(slot_value(slot))) || - (vector_rank(slot_value(slot)) > 1))) - return_false(sc, car_x); - - opc->v[3].i_7pi_f = pfunc; - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - opc->v[0].fi = opt_i_7pi_ss; - if ((s_func == global_value(sc->int_vector_ref_symbol)) && - (step_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) - { - opc->v[0].fi = opt_7pi_ss_ivref; - opc->v[3].i_7pi_f = int_vector_ref_i_7pi_direct; - } - else - if ((s_func == global_value(sc->byte_vector_ref_symbol)) && - (step_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) - { - opc->v[0].fi = opt_7pi_ss_bvref; - opc->v[3].i_7pi_f = byte_vector_ref_i_7pi_direct; - } - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fi = opt_i_7pi_sf; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- i_ii -------- */ -static s7_int opt_i_ii_cc(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[2].i));} -static s7_int opt_i_ii_cs(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_cs_mul(opt_info *o) {return(o->v[1].i * integer(slot_value(o->v[2].p)));} -static s7_int opt_i_ii_sc(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} -static s7_int opt_i_ii_sc_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[2].i);} /* +1 is not faster */ -static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(o->v[1].p)) - o->v[2].i);} /* -1 is not faster */ -static s7_int opt_i_ii_ss(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_ss_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p)));} -static s7_pointer opt_p_ii_ss_add(opt_info *o) {return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_cf(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_ii_cf_mul(opt_info *o) {return(o->v[1].i * o->v[5].fi(o->v[4].o1));} -static s7_int opt_i_ii_sf(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));} -static s7_int opt_i_ii_ff(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));} -static s7_int opt_i_7ii_ff_quo(opt_info *o){return(quotient_i_7ii(o->sc,o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));} -static s7_int opt_i_ii_fc(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} -static s7_int opt_i_ii_fc_add(opt_info *o) {return(o->v[11].fi(o->v[10].o1) + o->v[2].i);} -static s7_int opt_i_ii_fc_mul(opt_info *o) {return(o->v[11].fi(o->v[10].o1) * o->v[2].i);} -/* returning s7_int so overflow->real is not doable here, so - * (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (* (lognot 4294967297) 4294967297)))) (func) (func) - * will return -12884901890 rather than -18446744086594454000.0, 4294967297 > sqrt(fixmost) - * This affects all the opt arithmetical functions. Unfortunately the gmp version also gets -12884901890! - * We need to make sure none of these are available in the gmp version. - */ -static s7_int opt_i_7ii_fc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));} -static s7_int opt_i_ii_fco(opt_info *o) {return(o->v[3].i_ii_f(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));} -static s7_int opt_i_ii_fco_ivref_add(opt_info *o){return(int_vector_ref_i_7pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);} /* tref */ -static s7_int opt_i_7ii_fco(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));} - -static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fi == opt_i_7pi_ss) || (o1->v[0].fi == opt_7pi_ss_ivref)) - { - opc->v[5].i = opc->v[2].i; /* move v2.i ("c" in fc = arg2) out of the symbols' way */ - opc->v[4].i_7pi_f = o1->v[3].i_7pi_f; - opc->v[1].p = o1->v[1].p; - opc->v[2].p = o1->v[2].p; - if (func) - opc->v[0].fi = ((opc->v[3].i_ii_f == add_i_ii) && (opc->v[4].i_7pi_f == int_vector_ref_i_7pi_direct)) ? opt_i_ii_fco_ivref_add : opt_i_ii_fco; - else opc->v[0].fi = opt_i_7ii_fco; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_int opt_i_7ii_cc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[2].i));} -static s7_int opt_i_7ii_cs(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} -static s7_int opt_i_7ii_ss(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7ii_cf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7ii_sf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} - -static s7_int opt_i_7ii_ff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[3].i_7ii_f(o->sc, i1, i2)); -} - -#if WITH_GMP -static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc)));} -static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc)) - o->v[2].i);} -#else -static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_random_state)));} -static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc->default_random_state)) - o->v[2].i);} -#endif - -static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_i_ii_t ifunc = s7_i_ii_function(s_func); - s7_i_7ii_t ifunc7 = NULL; - s7_pointer sig; - - if (!ifunc) - { - ifunc7 = s7_i_7ii_function(s_func); - if (!ifunc7) - return_false(sc, car_x); - } - sig = c_function_signature(s_func); - if (is_pair(sig)) - { - s7_pointer arg1 = cadr(car_x); - s7_pointer arg2 = caddr(car_x); - int32_t start = sc->pc; - s7_pointer p; - if (ifunc) - opc->v[3].i_ii_f = ifunc; - else opc->v[3].i_7ii_f = ifunc7; - - if (is_t_integer(arg1)) - { - opc->v[1].i = integer(arg1); - if (is_t_integer(arg2)) - { - if (opc->v[3].i_ii_f == add_i_ii) - { - opc->v[1].i = integer(arg1) + integer(arg2); /* no overflow check for sc_add case above */ - opc->v[0].fi = opt_i_c; - } - else - { - opc->v[2].i = integer(arg2); - opc->v[0].fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; - } - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; - else opc->v[0].fi = opt_i_7ii_cs; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - if (ifunc) - { - opc->v[0].fi = opt_i_ii_cf; /* sc->opts[start]->v[0].fi -> opt_i_7i_c -> same_opt->v[2].i_7i_f = random_i_7i tmap */ - if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fi == opt_i_7i_c) && - (sc->opts[start]->v[2].i_7i_f == random_i_7i)) - { - opc->v[0].fi = opt_add_i_random_i; - opc->v[2].i = sc->opts[start]->v[1].i; - backup_pc(sc); - } - else if (ifunc == multiply_i_ii) opc->v[0].fi = opt_i_ii_cf_mul; - } - else opc->v[0].fi = opt_i_7ii_cf; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 not integer */ - p = opt_integer_symbol(sc, arg1); - if (p) - { - opc->v[1].p = p; - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - if (ifunc) - { - if (opc->v[3].i_ii_f == add_i_ii) - opc->v[0].fi = opt_i_ii_sc_add; - else opc->v[0].fi = (opc->v[3].i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ - } - else opc->v[0].fi = opt_i_7ii_sc; - if ((car(car_x) == sc->modulo_symbol) && - (integer(arg2) > 1)) - opc->v[3].i_ii_f = modulo_i_ii_unchecked; - else - { - if (car(car_x) == sc->ash_symbol) - { - if (opc->v[2].i < 0) - { - opc->v[3].i_ii_f = (opc->v[2].i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - } - else - if (opc->v[2].i < S7_INT_BITS) - { - opc->v[3].i_ii_f = lsh_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - }} - else - if (opc->v[2].i > 0) - { - /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ - if (opc->v[3].i_7ii_f == quotient_i_7ii) - { - opc->v[3].i_ii_f = quotient_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - } - else - if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) - { - opc->v[3].i_ii_f = remainder_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - }}} - return_true(sc, car_x); - } - - /* arg2 not integer, arg1 is int symbol */ - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; - else opc->v[0].fi = opt_i_7ii_ss; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; - else opc->v[0].fi = opt_i_7ii_sf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 not int symbol */ - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - if (!i_ii_fc_combinable(sc, opc, ifunc)) - { - if (ifunc) - { - if (opc->v[3].i_ii_f == add_i_ii) {opc->v[0].fi = opt_i_ii_fc_add; return_true(sc, car_x);} - if (opc->v[3].i_ii_f == multiply_i_ii) {opc->v[0].fi = opt_i_ii_fc_mul; return_true(sc, car_x);} - opc->v[0].fi = opt_i_ii_fc; - - if ((opc->v[3].i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fi == opt_i_7i_c) && - (sc->opts[start]->v[2].i_7i_f == random_i_7i)) - { - opc->v[0].fi = opt_subtract_random_i_i; - opc->v[1].i = sc->opts[start]->v[1].i; - backup_pc(sc); - }} - else opc->v[0].fi = opt_i_7ii_fc; - if (opc->v[2].i > 0) - { - if (opc->v[3].i_7ii_f == quotient_i_7ii) - { - opc->v[3].i_ii_f = quotient_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_fc; - } - else - if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) - { - opc->v[3].i_ii_f = remainder_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_fc; - }}} - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 not integer or symbol, arg2 not integer */ - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[0].fi = (ifunc) ? opt_i_ii_ff : ((opc->v[3].i_7ii_f == quotient_i_7ii) ? opt_i_7ii_ff_quo : opt_i_7ii_ff); - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- i_iii -------- */ -static s7_int opt_i_iii_fff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - s7_int i3 = o->v[5].fi(o->v[4].o1); - return(o->v[3].i_iii_f(i1, i2, i3)); -} - -static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_i_iii_t ifunc = s7_i_iii_function(s_func); - if (!ifunc) - return_false(sc, car_x); - opc->v[10].o1 = sc->opts[start]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_iii_f = ifunc; - opc->v[0].fi = opt_i_iii_fff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - }}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- i_7pii -------- */ -static s7_int opt_i_7pii_ssf(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7pii_ssf_vset(opt_info *o) {return(int_vector_set_i_7pii_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7pii_ssc(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].i));} -static s7_int opt_i_7pii_sss(opt_info *o) {return(o->v[4].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))));} -static s7_int opt_i_7pii_sif(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), o->v[12].i, o->v[9].fi(o->v[8].o1)));} - -static s7_int opt_i_pii_sss_ivref_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - return(int_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); -} - -static s7_int opt_i_7pii_sff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); -} - -/* -------- i_7piii -------- */ -static s7_int opt_i_7piii_sssf(opt_info *o) -{ - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fi(o->v[10].o1))); -} - -static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - s7_int val = o->v[11].fi(o->v[10].o1); - int_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val; - return(val); -} - -static s7_int opt_i_7piii_sssc(opt_info *o) -{ - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].i)); -} - -static s7_int opt_i_7piii_ssss(opt_info *o) -{ - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), integer(slot_value(o->v[4].p)))); -} - -static s7_int opt_i_7piii_sfff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - s7_int i3 = o->v[6].fi(o->v[4].o1); - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, i3)); -} - -static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) -{ - /* opc->v[5] is the called function (int-vector-set! etc) */ - s7_pointer slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (is_t_integer(car(valp))) - { - opc->v[0].fi = opt_i_7piii_sssc; - opc->v[4].i = integer(car(valp)); - return_true(sc, NULL); - } - slot = opt_integer_symbol(sc, car(valp)); - if (slot) - { - opc->v[4].p = slot; - opc->v[0].fi = opt_i_7piii_ssss; - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fi = opt_i_7piii_sssf; - if ((opc->v[5].i_7piii_f == int_vector_set_i_7piii) && - (step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[0].fi = opt_i_7piii_sfff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */ - return_true(sc, NULL); - }}} - return_false(sc, indexp1); -} - -static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) -{ - s7_pointer settee = lookup_slot_from(v, sc->curlet); - if ((is_slot(settee)) && - (!is_immutable(slot_value(settee)))) - { - s7_pointer slot, vect = slot_value(settee); - bool int_case = (is_int_vector(vect)); - opc->v[1].p = settee; - if ((int_case) || (is_byte_vector(vect))) - { - if ((otype >= 0) && (otype != ((int_case) ? 1 : 0))) - return_false(sc, indexp1); - if ((!indexp2) && - (vector_rank(vect) == 1)) - { - opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - int32_t start = sc->pc; - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(vect))) - opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii_direct : byte_vector_set_i_7pii_direct; - if ((is_pair(valp)) && - (is_null(cdr(valp))) && - (is_t_integer(car(valp)))) - { - opc->v[4].i = integer(car(valp)); - opc->v[0].fi = opt_i_7pii_ssc; - return_true(sc, NULL); - } - if (!int_optimize(sc, valp)) - return_false(sc, NULL); - opc->v[0].fi = (opc->v[3].i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - if (opc->v[11].fi == opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ - { - opc->v[0].fi = opt_i_7pii_sif; - opc->v[12].i = opc->v[10].o1->v[1].i; - } - else opc->v[0].fi = opt_i_7pii_sff; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - if ((indexp2) && - (vector_rank(vect) == 2)) - { - opc->v[5].i_7piii_f = (int_case) ? int_vector_set_i_7piii : byte_vector_set_i_7piii; - return(opt_i_7piii_args(sc, opc, indexp1, indexp2, valp)); - }}} - return_false(sc, v); -} - -static bool is_target_or_its_alias(s7_pointer symbol, s7_pointer symfunc, s7_pointer target) -{ - return((symbol == target) || (symfunc == initial_value(target))); -} - -static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_i_7pii_t pfunc = s7_i_7pii_function(s_func); - if (!pfunc) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot, fname = car(car_x); - - if ((is_target_or_its_alias(fname, s_func, sc->int_vector_set_symbol)) || - (is_target_or_its_alias(fname, s_func, sc->byte_vector_set_symbol))) - return(opt_int_vector_set(sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); - - slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - s7_pointer arg2, p; - int32_t start = sc->pc; - opc->v[1].p = slot; - - if (((is_target_or_its_alias(fname, s_func, sc->int_vector_ref_symbol)) || - (is_target_or_its_alias(fname, s_func, sc->byte_vector_ref_symbol))) && - (vector_rank(slot_value(slot)) != 2)) - return_false(sc, car_x); - - arg2 = caddr(car_x); - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - p = opt_integer_symbol(sc, cadddr(car_x)); - if (p) - { - opc->v[3].p = p; - opc->v[4].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_sss; - if ((pfunc == int_vector_ref_i_7pii) && - (step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; - return_true(sc, car_x); - } - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_ssf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_i_7piii_t f = s7_i_7piii_function(s_func); - if ((f) && - (is_symbol(cadr(car_x)))) - { - s7_pointer settee; - if ((is_target_or_its_alias(car(car_x), s_func, sc->int_vector_set_symbol)) || - (is_target_or_its_alias(car(car_x), s_func, sc->byte_vector_set_symbol))) - return(opt_int_vector_set(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x))); - - settee = lookup_slot_from(cadr(car_x), sc->curlet); - if (is_slot(settee)) - { - s7_pointer vect = slot_value(settee); - if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) - { - opc->v[5].i_7piii_f = f; - opc->v[1].p = settee; - return(opt_i_7piii_args(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x))); - }}} - return_false(sc, car_x); -} - -/* -------- i_add|multiply_any -------- */ -static s7_int opt_i_add_any_f(opt_info *o) -{ - s7_int sum = 0; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum += o1->v[0].fi(o1); - } - return(sum); -} - -static s7_int opt_i_add2(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - return(sum + o->v[7].fi(o->v[3].o1)); -} - -static s7_int opt_i_mul2(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - return(sum * o->v[7].fi(o->v[3].o1)); -} - -static s7_int opt_i_add3(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum += o->v[7].fi(o->v[3].o1); - return(sum + o->v[8].fi(o->v[4].o1)); -} - -static s7_int opt_i_mul3(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum *= o->v[7].fi(o->v[3].o1); - return(sum * o->v[8].fi(o->v[4].o1)); -} - -static s7_int opt_i_add4(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum += o->v[7].fi(o->v[3].o1); - sum += o->v[8].fi(o->v[4].o1); - return(sum + o->v[9].fi(o->v[5].o1)); -} - -static s7_int opt_i_mul4(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum *= o->v[7].fi(o->v[3].o1); - sum *= o->v[8].fi(o->v[4].o1); - return(sum * o->v[9].fi(o->v[5].o1)); -} - -static s7_int opt_i_multiply_any_f(opt_info *o) -{ - s7_int sum = 1; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum *= o1->v[0].fi(o1); - } - return(sum); -} - -static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) -{ - s7_pointer p, head = car(car_x); - int32_t cur_len, start = sc->pc; - for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) - { - opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, p)) - break; - } - if (is_null(p)) - { - opc->v[1].i = cur_len; - if (cur_len <= 4) - for (int32_t i = 0; i < cur_len; i++) - opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi; - if (cur_len == 2) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; - else - if (cur_len == 3) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; - else - if (cur_len == 4) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; - else opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_multiply_any_f; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); -} - - -/* -------- set_i_i -------- */ -static s7_int opt_set_i_i_f(opt_info *o) -{ - s7_int x = o->v[3].fi(o->v[2].o1); - slot_set_value(o->v[1].p, make_integer(o->sc, x)); - return(x); -} - -static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where are all ints */ -{ - s7_int x = o->v[3].fi(o->v[2].o1); - integer(slot_value(o->v[1].p)) = x; - return(x); -} - -static s7_int opt_set_i_i_fo(opt_info *o) -{ - s7_int x = integer(slot_value(o->v[3].p)) + o->v[2].i; - slot_set_value(o->v[1].p, make_integer(o->sc, x)); - return(x); -} - -static bool set_i_i_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fi == opt_i_ii_sc_add) - { - /* opc->v[4].i_ii_f = o1->v[3].i_ii_f; */ - opc->v[3].p = o1->v[1].p; - opc->v[2].i = o1->v[2].i; - opc->v[0].fi = opt_set_i_i_fo; - backup_pc(sc); - return_true(sc, NULL); /* ii_sc v[1].p is a slot */ - }} - return_false(sc, NULL); -} - -static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - if ((car(car_x) == sc->set_symbol) && - (len == 3)) - { - opt_info *opc = alloc_opt_info(sc); - if (is_symbol(cadr(car_x))) /* (set! i 3) */ - { - s7_pointer settee; - if (is_immutable(cadr(car_x))) - return_false(sc, car_x); - settee = lookup_slot_from(cadr(car_x), sc->curlet); - if ((is_slot(settee)) && - (is_t_integer(slot_value(settee))) && - (!is_immutable(settee)) && - ((!slot_has_setter(settee)) || - ((is_c_function(slot_setter(settee))) && - ((slot_setter(settee) == initial_value(sc->is_integer_symbol)) || - (c_function_call(slot_setter(settee)) == b_is_integer_setter))))) - /* opt set! won't change type, and it is an integer now (and we might not hit opt_cell_set) */ - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[1].p = settee; - if (int_optimize(sc, cddr(car_x))) - { - if (set_i_i_f_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fi = (is_mutable_integer(slot_value(opc->v[1].p))) ? opt_set_i_i_fm : opt_set_i_i_f; - opc->v[2].o1 = o1; - opc->v[3].fi = o1->v[0].fi; - return_true(sc, car_x); /* or OO_I? */ - }}} - else - if ((is_pair(cadr(car_x))) && /* if is_pair(settee) get setter */ - (is_symbol(caadr(car_x))) && - (is_pair(cdadr(car_x)))) - { - if (is_null(cddadr(car_x))) - return(opt_int_vector_set(sc, -1, opc, caadr(car_x), cdadr(car_x), NULL, cddr(car_x))); - if (is_null(cdddr(cadr(car_x)))) - return(opt_int_vector_set(sc, -1, opc, caadr(car_x), cdadr(car_x), cddadr(car_x), cddr(car_x))); - }} - return_false(sc, car_x); -} - -static bool i_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) -{ - s7_pointer obj = slot_value(s_slot); - if ((is_int_vector(obj)) || (is_byte_vector(obj))) - { - bool int_case = is_int_vector(obj); - s7_pointer slot; - - if ((len == 2) && - (vector_rank(obj) == 1)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[0].fi = opt_i_7pi_ss; - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(obj))) - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi_direct : byte_vector_ref_i_7pi_direct; - /* not opc->v[0].fi = opt_7pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[0].fi = opt_i_7pi_sf; - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - if ((len == 3) && - (vector_rank(obj) == 2)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (!slot) - return_false(sc, car_x); - opc->v[4].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - opc->v[3].p = slot; - opc->v[0].fi = opt_i_7pii_sss; - if ((int_case) && - (step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[3].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - opc->v[0].fi = opt_i_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - - -/* ------------------------------------- float opts ------------------------------------------- */ -static s7_double opt_d_c(opt_info *o) {return(o->v[1].x);} -static s7_double opt_d_s(opt_info *o) {return(real(slot_value(o->v[1].p)));} - -static s7_double opt_D_s(opt_info *o) -{ - s7_pointer x = slot_value(o->v[1].p); - return((is_t_integer(x)) ? (s7_double)(integer(x)) : s7_number_to_real(o->sc, x)); -} - -static bool opt_float_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - s7_pointer p; - if (is_small_real(car_x)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].x = s7_number_to_real(sc, car_x); - opc->v[0].fd = opt_d_c; - return_true(sc, car_x); - } - p = opt_real_symbol(sc, car_x); - if (p) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fd = (is_t_real(slot_value(p))) ? opt_d_s : opt_D_s; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- d -------- */ -static s7_double opt_d_f(opt_info *o) {return(o->v[1].d_f());} - -static bool d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func) /* (f): (mus-srate) */ -{ - s7_d_t func = s7_d_function(s_func); - if (!func) - return_false(sc, NULL); - opc->v[0].fd = opt_d_f; - opc->v[1].d_f = func; - return_true(sc, NULL); -} - -/* -------- d_d -------- */ -static s7_double opt_d_d_c(opt_info *o) {return(o->v[3].d_d_f(o->v[1].x));} -static s7_double opt_d_d_s(opt_info *o) {return(o->v[3].d_d_f(real(slot_value(o->v[1].p))));} -static s7_double opt_d_d_s_abs(opt_info *o) {return(abs_d_d(real(slot_value(o->v[1].p))));} -static s7_double opt_d_7d_c(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[1].x));} -static s7_double opt_d_7d_s(opt_info *o) {return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));} -static s7_double opt_d_d_f(opt_info *o) {return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_d_f_abs(opt_info *o) {return(abs_d_d(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_d_f_sin(opt_info *o) {return(sin_d_d(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_d_f_cos(opt_info *o) {return(cos_d_d(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7d_f(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7d_f_divide(opt_info *o) {return(divide_d_7d(o->sc, o->v[5].fd(o->v[4].o1)));} - -static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o); -static s7_double opt_abs_d_ss_fvref(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - return(abs_d_d(float_vector(slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p))))); -} - -static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7d_t func7 = NULL; - int32_t start = sc->pc; - s7_d_d_t func = s7_d_d_function(s_func); - if (!func) func7 = s7_d_7d_function(s_func); - if ((func) || (func7)) - { - s7_pointer p; - if (func) - opc->v[3].d_d_f = func; - else opc->v[3].d_7d_f = func7; - if (is_small_real(cadr(car_x))) - { - if ((!is_t_real(cadr(car_x))) && /* (random 1) != (random 1.0) */ - ((car(car_x) == sc->random_symbol) || - (car(car_x) == sc->sin_symbol) || (car(car_x) == sc->cos_symbol))) - return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); - opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c; - return_true(sc, car_x); - } - p = opt_float_symbol(sc, cadr(car_x)); - if ((p) && - (!has_methods(slot_value(p)))) - { - opc->v[1].p = p; - opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_f_abs : ((func == sin_d_d) ? opt_d_d_f_sin : - ((func == cos_d_d) ? opt_d_d_f_cos : opt_d_d_f))) : - ((func7 == divide_d_7d) ? opt_d_7d_f_divide : opt_d_7d_f); - opc->v[5].fd = opc->v[4].o1->v[0].fd; - if ((func == abs_d_d) && (opc->v[5].fd == opt_d_7pi_ss_fvref_direct)) - opc->v[0].fd = opt_abs_d_ss_fvref; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - -/* -------- d_v -------- */ -static s7_double opt_d_v(opt_info *o) {return(o->v[3].d_v_f(o->v[5].obj));} - -static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_d_v_t flt_func = s7_d_v_function(s_func); - if (!flt_func) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_symbol(cadr(sig))) && - (is_symbol(cadr(car_x)))) /* look for (oscil g) */ - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - opc->v[3].d_v_f = flt_func; - opc->v[0].fd = opt_d_v; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - -/* -------- d_p -------- */ -static s7_double opt_d_p_s(opt_info *o) {return(o->v[3].d_p_f(slot_value(o->v[1].p)));} -static s7_double opt_d_p_f(opt_info *o) {return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));} - -static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_d_p_t dpf = s7_d_p_function(s_func); /* mostly clm gens */ - if (!dpf) - return_false(sc, car_x); - opc->v[3].d_p_f = dpf; - if (is_symbol(cadr(car_x))) - { - s7_pointer slot = opt_simple_symbol(sc, cadr(car_x)); - if (!slot) - return_false(sc, car_x); - opc->v[1].p = slot; - opc->v[0].fd = opt_d_p_s; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fd = opt_d_p_f; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_7pi -------- */ - -static s7_double opt_d_7pi_sc(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_double opt_d_7pi_ss(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_double opt_d_7pi_sf(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));} -static s7_double opt_d_7pi_ss_fvref(opt_info *o) {return(float_vector_ref_d_7pi(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o) {return(float_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} - -static s7_double opt_d_7pi_ff(opt_info *o) -{ - s7_pointer seq = o->v[5].fp(o->v[4].o1); - return(o->v[3].d_7pi_f(o->sc, seq, o->v[9].fi(o->v[8].o1))); -} - -static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - /* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */ - int32_t start = sc->pc; - s7_d_7pi_t ifunc = s7_d_7pi_function(s_func); /* ifunc: float_vector_ref_d_7pi, s_func: global_value(sc->float_vector_ref_symbol) */ - if (!ifunc) - return_false(sc, car_x); - opc->v[3].d_7pi_f = ifunc; - if (is_symbol(cadr(car_x))) /* (float-vector-ref v i) */ - { - s7_pointer arg2, p, obj; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - - obj = slot_value(opc->v[1].p); - if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && - ((!is_float_vector(obj)) || /* if it's float-vector-ref, make sure obj is a float-vector */ - (vector_rank(obj) > 1))) - return_false(sc, car_x); /* but if it's e.g. (block-ref...), go on */ - - arg2 = caddr(car_x); - if (!is_pair(arg2)) - { - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[0].fd = opt_d_7pi_sc; - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, arg2); - if (!p) - return_false(sc, car_x); - opc->v[2].p = p; - opc->v[0].fd = opt_d_7pi_ss; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) - opc->v[0].fd = (step_end_fits(opc->v[2].p, vector_length(obj))) ? opt_d_7pi_ss_fvref_direct : opt_d_7pi_ss_fvref; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pi_sf; - opc->v[10].o1 = sc->opts[start]; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && - ((!is_float_vector(cadr(car_x))) || - (vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ - return_false(sc, car_x); - - if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pi_ff; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fi = o2->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_ip -------- */ -static s7_double opt_d_ip_ss(opt_info *o) {return(o->v[3].d_ip_f(integer(slot_value(o->v[1].p)), slot_value(o->v[2].p)));} - -static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_ip_t pfunc = s7_d_ip_function(s_func); - if ((pfunc) && - (is_symbol(caddr(car_x)))) - { - s7_pointer p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[3].d_ip_f = pfunc; - opc->v[1].p = p; - opc->v[2].p = lookup_slot_from(caddr(car_x), sc->curlet); - if (is_slot(opc->v[2].p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ - { - opc->v[0].fd = opt_d_ip_ss; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- d_pd -------- */ -static s7_double opt_d_pd_sf(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));} -static s7_double opt_d_pd_ss(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), real(slot_value(o->v[2].p))));} - -static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - if (is_symbol(cadr(car_x))) - { - s7_d_pd_t func = s7_d_pd_function(s_func); - if (func) - { - s7_pointer p, arg2 = caddr(car_x); - int32_t start = sc->pc; - opc->v[3].d_pd_f = func; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - p = opt_float_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - opc->v[0].fd = opt_d_pd_ss; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_pd_sf; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- d_vd -------- */ -static s7_double opt_d_vd_c(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].x));} -static s7_double opt_d_vd_s(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p))));} -static s7_double opt_d_vd_f(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));} -static s7_double opt_d_vd_o(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));} -static s7_double opt_d_vd_o1_mul(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o->v[11].fd(o->v[10].o1)));} -static s7_double opt_d_vd_o1(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))));} -static s7_double opt_d_vd_o2(opt_info *o) {return(o->v[4].d_vd_f(o->v[6].obj, o->v[5].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p)))));} -static s7_double opt_d_vd_o3(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(o->v[6].x, real(slot_value(o->v[2].p)))));} -static s7_double opt_d_vd_ff(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o->v[11].fd(o->v[10].o1))));} - -static s7_double opt_d_dd_cs(opt_info *o); -static s7_double opt_d_dd_sf_mul(opt_info *o); -static s7_double opt_d_dd_sf_add(opt_info *o); -static s7_double opt_d_dd_sf(opt_info *o); - -static bool d_vd_f_combinable(s7_scheme *sc, int32_t start) -{ - opt_info *opc = sc->opts[start - 1], *o1 = sc->opts[start]; - if (o1->v[0].fd == opt_d_v) - { - opc->v[2].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_vd_o; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[6].obj = opc->v[5].obj; - opc->v[4].d_vd_f = opc->v[3].d_vd_f; /* room for symbols */ - opc->v[2].obj = o1->v[5].obj; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[3].p = o1->v[2].p; - opc->v[7].p = o1->v[1].p; - opc->v[0].fd = opt_d_vd_o2; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_dd_cs) - { - opc->v[4].d_dd_f = o1->v[3].d_dd_f; - opc->v[6].x = o1->v[2].x; - opc->v[2].p = o1->v[1].p; - opc->v[0].fd = opt_d_vd_o3; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fd == opt_d_dd_sf_mul) || (o1->v[0].fd == opt_d_dd_sf) || (o1->v[0].fd == opt_d_dd_sf_add)) - { - opc->v[2].p = o1->v[1].p; - opc->v[4].d_dd_f = o1->v[3].d_dd_f; - opc->v[0].fd = (o1->v[0].fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; - opc->v[11].fd = o1->v[5].fd; - opc->v[10].o1 = o1->v[4].o1; - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_vd_f) - { - opc->v[2].d_vd_f = o1->v[3].d_vd_f; - opc->v[4].obj = o1->v[5].obj; - opc->v[6].p = o1->v[1].p; - opc->v[0].fd = opt_d_vd_ff; - opc->v[11].fd = o1->v[9].fd; - opc->v[10].o1 = o1->v[8].o1; - return_true(sc, NULL); - } - return_false(sc, NULL); -} - -static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_d_vd_t vfunc; - if (!is_symbol(cadr(car_x))) - return_false(sc, car_x); - vfunc = s7_d_vd_function(s_func); - if (!vfunc) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_symbol(cadr(sig)))) - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - s7_pointer arg2 = caddr(car_x); - int32_t start = sc->pc; - opc->v[3].d_vd_f = vfunc; - if (!is_pair(arg2)) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fd = opt_d_vd_c; - return_true(sc, car_x); - } - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - if (is_slot(opc->v[2].p)) - { - if (is_t_real(slot_value(opc->v[2].p))) - { - opc->v[0].fd = opt_d_vd_s; - return_true(sc, car_x); - } - if (!float_optimize(sc, cddr(car_x))) - return_false(sc, car_x); - if (d_vd_f_combinable(sc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_vd_f; - opc->v[8].o1 = sc->opts[start]; - opc->v[9].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - }} - else /* is pair arg2 */ - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - if (d_vd_f_combinable(sc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_vd_f; - opc->v[8].o1 = sc->opts[start]; - opc->v[9].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }}} - return_false(sc, car_x); -} - -/* -------- d_id -------- */ -static s7_double opt_d_id_sf(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_id_sc(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));} -static s7_double opt_d_id_sfo1(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_v_f(o->v[2].obj)));} -static s7_double opt_d_id_sfo(opt_info *o) {return(o->v[4].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[3].p)))));} -static s7_double opt_d_id_cf(opt_info *o) {return(o->v[3].d_id_f(o->v[1].i, o->v[5].fd(o->v[4].o1)));} - -static s7_double opt_d_id_ff(opt_info *o) -{ - s7_int x1 = o->v[9].fi(o->v[8].o1); - return(o->v[3].d_id_f(x1, o->v[11].fd(o->v[10].o1))); -} - -static bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[4].d_id_f = opc->v[3].d_id_f; - opc->v[2].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[3].p = o1->v[2].p; - opc->v[0].fd = opt_d_id_sfo; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_v) - { - opc->v[6].p = o1->v[1].p; - opc->v[2].obj = o1->v[5].obj; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_id_sfo1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool d_id_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer p; - int32_t start = sc->pc; - s7_d_id_t flt_func = s7_d_id_function(s_func); - if (!flt_func) - return_false(sc, car_x); - opc->v[3].d_id_f = flt_func; - p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - if (is_t_real(caddr(car_x))) - { - opc->v[0].fd = opt_d_id_sc; - opc->v[2].x = real(caddr(car_x)); - return_true(sc, car_x); - } - if (float_optimize(sc, cddr(car_x))) - { - if (d_id_sf_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_id_sf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (is_t_integer(cadr(car_x))) - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_id_cf; - opc->v[1].i = integer(cadr(car_x)); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fd = opt_d_id_ff; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - -/* -------- d_dd -------- */ - -static s7_double opt_d_dd_cc(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[2].x));} -static s7_double opt_d_dd_cs(opt_info *o) {return(o->v[3].d_dd_f(o->v[2].x, real(slot_value(o->v[1].p))));} -static s7_double opt_d_dd_sc(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));} -static s7_double opt_d_dd_sc_sub(opt_info *o) {return(real(slot_value(o->v[1].p)) - o->v[2].x);} -static s7_double opt_d_dd_ss(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p)));} -static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p)));} - -static s7_double opt_d_dd_cf(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_dd_1f_subtract(opt_info *o) {return(1.0 - o->v[5].fd(o->v[4].o1));} -static s7_double opt_d_dd_fc(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));} - -#if WITH_GMP -static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc) - o->v[2].x);} -#else -static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc->default_random_state) - o->v[2].x);} -#endif - -static s7_double opt_d_dd_fc_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + o->v[2].x);} -static s7_double opt_d_dd_fc_fvref_add(opt_info *o) {return(o->v[2].x + float_vector(slot_value(o->v[4].o1->v[1].p), integer(slot_value(o->v[4].o1->v[2].p))));} -static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - o->v[2].x);} -static s7_double opt_d_dd_sf(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));} -static s7_double opt_d_dd_sf_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + o->v[5].fd(o->v[4].o1));} -static s7_double opt_d_dd_sf_sub(opt_info *o) {return(real(slot_value(o->v[1].p)) - o->v[5].fd(o->v[4].o1));} - -static s7_double opt_d_7dd_cc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[2].x));} -static s7_double opt_d_7dd_cs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, real(slot_value(o->v[1].p))));} -static s7_double opt_d_7dd_sc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[2].x));} -static s7_double opt_d_7dd_ss(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static s7_double opt_d_7dd_cf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7dd_fc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));} -static s7_double opt_d_7dd_sf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} - -static s7_double opt_d_7pii_scs(opt_info *o); -static s7_double opt_d_dd_sf_mul_fvref(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - return(real(slot_value(o->v[1].p)) * float_vector_ref_d_7pii(o1->sc, slot_value(o1->v[1].p), o1->v[2].i, integer(slot_value(o1->v[3].p)))); -} - -static s7_double opt_d_dd_sfo(opt_info *o) -{ - return(o->v[4].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))))); -} - -static s7_double opt_d_7dd_sfo(opt_info *o) -{ - return(o->v[4].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))))); -} - -static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - if (func) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_dd_sfo; - } - else - { - opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_7dd_sfo; - } - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_double opt_d_dd_fs(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} -static s7_double opt_d_dd_fs_mul(opt_info *o) {return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));} -static s7_double opt_d_dd_fs_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + real(slot_value(o->v[1].p)));} -static s7_double opt_d_dd_fs_sub(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - real(slot_value(o->v[1].p)));} -static s7_double opt_d_7dd_fs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} - -static s7_double opt_d_dd_fs_add_fvref(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - return(real(slot_value(o->v[1].p)) + float_vector_ref_d_7pii(o1->sc, slot_value(o1->v[1].p), o1->v[2].i, integer(slot_value(o1->v[3].p)))); -} - -static s7_double opt_d_dd_fso(opt_info *o) -{ - return(o->v[4].d_dd_f(o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))); -} - -static s7_double opt_d_7dd_fso(opt_info *o) -{ - return(o->v[4].d_7dd_f(o->sc, o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))); -} - -static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - if (func) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_dd_fso; - } - else - { - opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; - opc->v[0].fd = opt_d_7dd_fso; - } - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_double opt_d_dd_ff(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_mul(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(x1 * o->v[11].fd(o->v[10].o1)); -} - -static s7_double opt_d_dd_ff_square(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(x1 * x1); -} - -static s7_double opt_d_dd_ff_add(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - return(x1 + o->v[11].fd(o->v[10].o1)); -} - -static s7_double opt_d_dd_ff_add_mul(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(x1 + (x2 * o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(o->v[6].p), o->v[9].fi(o->v[8].o1))); -} - -static s7_double opt_d_dd_ff_sub(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - return(x1 - o->v[11].fd(o->v[10].o1)); -} - -static s7_double opt_d_7dd_ff(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(o->v[3].d_7dd_f(o->sc, x1, o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_o1(opt_info *o) -{ - s7_double x1 = o->v[2].d_v_f(o->v[1].obj); - return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_mul1(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1));} - -static s7_double opt_d_dd_ff_o2(opt_info *o) -{ - s7_double x1 = o->v[4].d_v_f(o->v[1].obj); - return(o->v[3].d_dd_f(x1, o->v[5].d_v_f(o->v[2].obj))); -} - -static s7_double opt_d_dd_ff_mul2(opt_info *o) {return(o->v[4].d_v_f(o->v[1].obj) * o->v[5].d_v_f(o->v[2].obj));} - -static s7_double opt_d_dd_ff_o3(opt_info *o) -{ - s7_double x1 = o->v[5].d_v_f(o->v[1].obj); - return(o->v[4].d_dd_f(x1, o->v[6].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p))))); -} - -static s7_double opt_d_dd_fff(opt_info *o) -{ - s7_double x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))), real(slot_value(o->v[3+1].p))); /* dd_fso */ - s7_double x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))), real(slot_value(o->v[8+1].p))); /* dd_fso */ - return(o->v[3].d_dd_f(x1, x2)); -} - -static s7_double opt_d_mm_fff(opt_info *o) -{ - s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p)); - s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p)); - return(o->v[3].d_dd_f(x1, x2)); -} - -static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */ -{ - s7_double x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p)))); - s7_double x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p)))); - return(o->v[3].d_dd_f(x1, x2)); -} - -static s7_double opt_d_dd_ff_o4(opt_info *o) -{ - s7_double x1 = o->v[2].d_v_f(o->v[1].obj); - return(o->v[3].d_dd_f(x1, o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)))); -} - -static s7_double opt_d_dd_ff_mul4(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));} - -static s7_double opt_d_7pii_sss(opt_info *o); -static s7_double opt_d_dd_ff_mul_sss(opt_info *o) -{ - opt_info *o1 = o->v[8].o1; - s7_pointer v = slot_value(o1->v[1].p); - s7_int i1 = integer(slot_value(o1->v[2].p)); - s7_int i2 = integer(slot_value(o1->v[3].p)); - s7_double x1 = float_vector_ref_d_7pii(o1->sc, v, i1, i2); - o1 = o->v[10].o1; - v = slot_value(o1->v[1].p); - i1 = integer(slot_value(o1->v[2].p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */ - i2 = integer(slot_value(o1->v[3].p)); - return(x1 * float_vector_ref_d_7pii(o1->sc, v, i1, i2)); -} - -static bool finish_dd_fso(opt_info *opc, opt_info *o1, opt_info *o2) -{ - opc->v[3+1].p = o1->v[1].p; - opc->v[3+2].p = o1->v[2].p; - opc->v[3+3].p = o1->v[3].p; - opc->v[3+4].d_dd_f = o1->v[4].d_dd_f; - opc->v[3+5].d_7pi_f = o1->v[5].d_7pi_f; - opc->v[8+1].p = o2->v[1].p; - opc->v[8+2].p = o2->v[2].p; - opc->v[8+3].p = o2->v[3].p; - opc->v[8+4].d_dd_f = o2->v[4].d_dd_f; - opc->v[8+5].d_7pi_f = o2->v[5].d_7pi_f; - return(true); -} - -static s7_double opt_d_7dd_ff_div_add(opt_info *o) -{ - opt_info *o2 = o->v[10].o1; - s7_double x1 = o->v[9].fd(o->v[8].o1); - s7_double x2 = o2->v[5].fd(o2->v[4].o1); - x2 += float_vector_ref_d_7pi(o2->sc, slot_value(o2->v[6].p), o2->v[9].fi(o2->v[8].o1)); - return(divide_d_7dd(o->sc, x1, x2)); -} - -static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) -{ - opt_info *o1 = opc->v[8].o1, *o2 = opc->v[10].o1; - if (o1->v[0].fd == opt_d_v) - { - /* opc->v[3] is in use */ - if ((o2->v[0].fd == opt_d_v) && - (sc->pc == start + 2)) - { - opc->v[1].obj = o1->v[5].obj; - opc->v[6].p = o1->v[1].p; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o2->v[5].obj; - opc->v[7].p = o2->v[1].p; - opc->v[5].d_v_f = o2->v[3].d_v_f; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; - sc->pc -= 2; - return_true(sc, NULL); - } - if ((o2->v[0].fd == opt_d_vd_s) && - (sc->pc == start + 2)) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* make room for symbols */ - opc->v[1].obj = o1->v[5].obj; - opc->v[7].p = o1->v[1].p; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o2->v[5].obj; - opc->v[8].p = o2->v[1].p; - opc->v[6].d_vd_f = o2->v[3].d_vd_f; - opc->v[3].p = o2->v[2].p; - opc->v[0].fd = opt_d_dd_ff_o3; - sc->pc -= 2; - return_true(sc, NULL); - } - if ((o2->v[0].fd == opt_d_vd_o) && - (sc->pc == start + 2)) - { - opc->v[1].obj = o1->v[5].obj; - opc->v[8].p = o1->v[1].p; - opc->v[2].d_v_f = o1->v[3].d_v_f; - opc->v[7].d_vd_f = o2->v[3].d_vd_f; - opc->v[4].d_v_f = o2->v[4].d_v_f; - opc->v[5].obj = o2->v[5].obj; - opc->v[9].p = o2->v[1].p; - opc->v[6].obj = o2->v[6].obj; - opc->v[10].p = o2->v[2].p; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; - sc->pc -= 2; - return_true(sc, NULL); - } - opc->v[1].obj = o1->v[5].obj; - opc->v[4].p = o1->v[1].p; - opc->v[2].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1; - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_dd_fso) - { - if (o2->v[0].fd == opt_d_dd_fso) - { - if ((o1->v[4].d_dd_f == multiply_d_dd) && - (o2->v[4].d_dd_f == multiply_d_dd) && - (o1->v[5].d_7pi_f == float_vector_ref_d_7pi) && - (o2->v[5].d_7pi_f == float_vector_ref_d_7pi)) - opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */ - else opc->v[0].fd = opt_d_dd_fff; - return(finish_dd_fso(opc, o1, o2)); - }} - if (o1->v[0].fd == opt_d_dd_sfo) - { - if (o2->v[0].fd == opt_d_dd_sfo) - { - if ((o1->v[4].d_dd_f == multiply_d_dd) && - (o2->v[4].d_dd_f == multiply_d_dd) && - (o1->v[5].d_7pi_f == float_vector_ref_d_7pi) && - (o2->v[5].d_7pi_f == float_vector_ref_d_7pi)) - opc->v[0].fd = opt_d_mm_fff; /* multiply is commutative */ - else opc->v[0].fd = opt_d_dd_fff_rev; - return(finish_dd_fso(opc, o1, o2)); - }} - return_false(sc, NULL); -} - -static s7_double opt_d_dd_cfo(opt_info *o) {return(o->v[3].d_dd_f(o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));} -static s7_double opt_d_7dd_cfo(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));} -static s7_double opt_d_dd_cfo1(opt_info *o) {return(o->v[3].d_dd_f(o->v[4].x, o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[2].p)))));} -static s7_double opt_d_7dd_cfo1(opt_info *o){return(o->v[3].d_7dd_f(o->sc, o->v[4].x, o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[2].p)))));} - -static bool d_dd_call_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fd == opt_d_v) - { - opc->v[2].x = opc->v[1].x; - opc->v[6].p = o1->v[1].p; - opc->v[1].obj = o1->v[5].obj; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[4].x = opc->v[1].x; - opc->v[1].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[2].p = o1->v[2].p; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - int32_t start = sc->pc; - opt_info *o1; - s7_d_7dd_t func7 = NULL; - s7_d_dd_t func = s7_d_dd_function(s_func); - if (!func) - { - func7 = s7_d_7dd_function(s_func); - if (!func7) return_false(sc, car_x); - } - if (func) - opc->v[3].d_dd_f = func; - else opc->v[3].d_7dd_f = func7; - - /* arg1 = real constant */ - if (is_small_real(arg1)) - { - if (is_small_real(arg2)) - { - if ((!is_t_real(arg1)) && (!is_t_real(arg2))) - return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, arg1); - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; - return_true(sc, car_x); - } - slot = opt_float_symbol(sc, arg2); - if (slot) - { - opc->v[1].p = slot; - opc->v[2].x = s7_number_to_real(sc, arg1); /* move arg1? */ - opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; - return_true(sc, car_x); - } - if (float_optimize(sc, cddr(car_x))) - { - opc->v[1].x = s7_number_to_real(sc, arg1); - if (d_dd_call_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - opc->v[0].fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; - if ((opc->v[1].x == 1.0) && (func == subtract_d_dd)) opc->v[0].fd = opt_d_dd_1f_subtract; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 = float symbol */ - slot = opt_float_symbol(sc, arg1); - if (slot) - { - opc->v[1].p = slot; - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - if (func) - opc->v[0].fd = (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; - else opc->v[0].fd = opt_d_7dd_sc; - return_true(sc, car_x); - } - slot = opt_float_symbol(sc, arg2); - if (slot) - { - opc->v[2].p = slot; - if (func) - { - if (func == multiply_d_dd) - opc->v[0].fd = opt_d_dd_ss_mul; - else opc->v[0].fd = (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; - } - else opc->v[0].fd = opt_d_7dd_ss; - return_true(sc, car_x); - } - if (float_optimize(sc, cddr(car_x))) - { - if (d_dd_sf_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul : - ((func == add_d_dd) ? opt_d_dd_sf_add : - ((func == subtract_d_dd) ? opt_d_dd_sf_sub : opt_d_dd_sf)); - if ((func == multiply_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) - opc->v[0].fd = opt_d_dd_sf_mul_fvref; - } - else opc->v[0].fd = opt_d_7dd_sf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 = float expr or non-float */ - o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - int32_t start2 = sc->pc; - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - if (func == add_d_dd) - { - opc->v[0].fd = (opc->v[5].fd == opt_d_7pi_ss_fvref_direct) ? opt_d_dd_fc_fvref_add : opt_d_dd_fc_add; - return_true(sc, car_x); - } - if (func == subtract_d_dd) - { - opc->v[0].fd = opt_d_dd_fc_subtract; - /* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */ - if ((opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fd == opt_d_7d_c) && - (sc->opts[start]->v[3].d_7d_f == random_d_7d)) - { - opc->v[0].fd = opt_subtract_random_f_f; - opc->v[1].x = sc->opts[start]->v[1].x; /* random arg */ - backup_pc(sc); - }} - else opc->v[0].fd = opt_d_dd_fc; - } - else opc->v[0].fd = opt_d_7dd_fc; - return_true(sc, car_x); - } - slot = opt_float_symbol(sc, arg2); - if (slot) - { - opc->v[1].p = slot; - if (d_dd_fs_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_fs_mul : - ((func == add_d_dd) ? opt_d_dd_fs_add : - ((func == subtract_d_dd) ? opt_d_dd_fs_sub : opt_d_dd_fs)); - if ((func == add_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) - opc->v[0].fd = opt_d_dd_fs_add_fvref; - } - else opc->v[0].fd = opt_d_7dd_fs; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opt_info *o2; - opc->v[8].o1 = o1; - opc->v[9].fd = o1->v[0].fd; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - if (func) - { - if (d_dd_ff_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_dd_ff; - if (func == multiply_d_dd) - { - if (arg1 == arg2) - opc->v[0].fd = opt_d_dd_ff_square; - else - if ((opc->v[9].fd == opt_d_7pii_sss) && (opc->v[11].fd == opt_d_7pii_sss) && - (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) /* currently redundant */ - opc->v[0].fd = opt_d_dd_ff_mul_sss; - else opc->v[0].fd = opt_d_dd_ff_mul; - return_true(sc, car_x); - } - o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ - if (func == add_d_dd) - { - if (o2->v[0].fd == opt_d_dd_ff_mul) - { - opc->v[0].fd = opt_d_dd_ff_add_mul; - opc->v[4].o1 = o1; /* add first arg */ - opc->v[5].fd = o1->v[0].fd; - opc->v[8].o1 = o2->v[8].o1; /* mul first arg */ - opc->v[9].fd = o2->v[9].fd; - opc->v[10].o1 = o2->v[10].o1; /* mul second arg */ - opc->v[11].fd = o2->v[11].fd; - return_true(sc, car_x); - } - if ((o2->v[0].fd == opt_d_7pi_sf) && - (o2->v[3].d_7pi_f == float_vector_ref_d_7pi)) - { - opc->v[0].fd = opt_d_dd_ff_add_fv_ref; - opc->v[6].p = o2->v[1].p; - opc->v[8].o1 = o2->v[10].o1; /* sc->opts[start2 + 1]; */ - opc->v[9].fi = o2->v[11].fi; /* sc->opts[start2 + 1]->v[0].fi; */ - } - else - { - opc->v[0].fd = opt_d_dd_ff_add; - opc->v[10].o1 = o2; - opc->v[11].fd = o2->v[0].fd; - } - opc->v[4].o1 = o1; /* sc->opts[start]; */ - opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ - return_true(sc, car_x); - } - if (func == subtract_d_dd) - { - opc->v[0].fd = opt_d_dd_ff_sub; - opc->v[4].o1 = o1; /* sc->opts[start]; */ - opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ - opc->v[10].o1 = o2; - opc->v[11].fd = o2->v[0].fd; - return_true(sc, car_x); - }} - else - { - opc->v[0].fd = opt_d_7dd_ff; - if ((opc->v[11].fd == opt_d_dd_ff_add_fv_ref) && - (opc->v[3].d_7dd_f == divide_d_7dd)) - opc->v[0].fd = opt_d_7dd_ff_div_add; - } - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_ddd -------- */ -static s7_double opt_d_ddd_sss(opt_info *o) {return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), real(slot_value(o->v[3].p))));} -static s7_double opt_d_ddd_ssf(opt_info *o) {return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));} - -static s7_double opt_d_ddd_sff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2)); -} - -static s7_double opt_d_ddd_fff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - s7_double x3 = o->v[6].fd(o->v[5].o1); - return(o->v[4].d_ddd_f(x1, x2, x3)); -} - -static s7_double opt_d_ddd_fff1(opt_info *o) -{ - s7_double x1 = o->v[1].d_v_f(o->v[2].obj); - s7_double x2 = o->v[3].d_v_f(o->v[4].obj); - s7_double x3 = o->v[5].d_v_f(o->v[6].obj); - return(o->v[7].d_ddd_f(x1, x2, x3)); -} - -static s7_double opt_d_ddd_fff2(opt_info *o) -{ - s7_double x1 = o->v[1].d_v_f(o->v[2].obj); - s7_double x2 = o->v[9].fd(o->v[12].o1); - s7_double x3 = o->v[6].fd(o->v[5].o1); - return(o->v[7].d_ddd_f(x1, x2, x3)); -} - -static s7_double opt_d_ddd_fff_mul(opt_info *o) -{ - s7_double x1 = opt_D_s(o->v[10].o1); - s7_double x2 = opt_D_s(o->v[8].o1); - s7_double x3 = opt_d_s(o->v[5].o1); - return(multiply_d_ddd(x1, x2, x3)); -} - -static bool d_ddd_fff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) -{ - opt_info *o1; - if (sc->opts[start]->v[0].fd != opt_d_v) - return_false(sc, NULL); - opc->v[12].o1 = opc->v[8].o1; - opc->v[7].d_ddd_f = opc->v[4].d_ddd_f; - o1 = sc->opts[start]; - opc->v[1].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o1->v[5].obj; - opc->v[8].p = o1->v[1].p; - if ((sc->opts[start + 1]->v[0].fd == opt_d_v) && - (sc->opts[start + 2]->v[0].fd == opt_d_v)) - { - opc->v[0].fd = opt_d_ddd_fff1; - o1 = sc->opts[start + 1]; - opc->v[3].d_v_f = o1->v[3].d_v_f; - opc->v[4].obj = o1->v[5].obj; - opc->v[9].p = o1->v[1].p; - o1 = sc->opts[start + 2]; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[6].obj = o1->v[5].obj; - opc->v[10].p = o1->v[1].p; - sc->pc -= 3; - return_true(sc, NULL); - } - opc->v[0].fd = opt_d_ddd_fff2; - opc->v[9].fd = opc->v[12].o1->v[0].fd; - opc->v[6].fd = opc->v[5].o1->v[0].fd; - return_true(sc, NULL); -} - -static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_d_ddd_t f = s7_d_ddd_function(s_func); - if (!f) - return_false(sc, car_x); - opc->v[4].d_ddd_f = f; - slot = opt_float_symbol(sc, arg1); - opc->v[10].o1 = sc->opts[start]; - if (slot) - { - opc->v[1].p = slot; - slot = opt_float_symbol(sc, arg2); - if (slot) - { - s7_pointer arg3 = cadddr(car_x); - opc->v[2].p = slot; - slot = opt_float_symbol(sc, arg3); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_ddd_sss; - return_true(sc, car_x); - } - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fd = opt_d_ddd_ssf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (float_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_ddd_sff; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - } - if (float_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[5].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - if (d_ddd_fff_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_ddd_fff; /* tfft: (* xout xin iw) (+ (* xout xin iw) (* yout yin ih) (* zout zin id)) */ - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[6].fd = opc->v[5].o1->v[0].fd; - if ((f = multiply_d_ddd) && (opc->v[11].fd == opt_D_s) && (opc->v[9].fd == opt_D_s) && (opc->v[6].fd == opt_d_s)) - opc->v[0].fd = opt_d_ddd_fff_mul; - return_true(sc, car_x); - }}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_7pid -------- */ -static s7_double opt_d_7pid_ssf(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))); -} - -static s7_pointer opt_d_7pid_ssf_nr(opt_info *o) -{ - o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)); - return(NULL); -} - -static s7_double opt_d_7pid_sss(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), real(slot_value(o->v[3].p)))); -} - -static s7_double opt_d_7pid_ssc(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[3].x)); -} - -static s7_double opt_d_7pid_sff(opt_info *o) -{ - s7_int pos = o->v[11].fi(o->v[10].o1); - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1))); -} - -static s7_double opt_d_7pid_sff_fvset(opt_info *o) -{ - s7_int pos = o->v[11].fi(o->v[10].o1); - return(float_vector_set_d_7pid(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1))); -} - -static s7_double opt_d_7pid_sso(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].d_v_f(o->v[3].obj))); -} - -static s7_double opt_d_7pid_ss_ss(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), - integer(slot_value(o->v[2].p)), - o->v[3].d_7pi_f(o->sc, slot_value(o->v[5].p), integer(slot_value(o->v[6].p))))); -} - -static s7_double opt_d_7pid_ssfo(opt_info *o) -{ - s7_pointer fv = slot_value(o->v[1].p); - return(o->v[4].d_7pid_f(o->sc, fv, integer(slot_value(o->v[2].p)), - o->v[6].d_dd_f(o->v[5].d_7pi_f(o->sc, fv, integer(slot_value(o->v[3].p))), real(slot_value(o->v[8].p))))); -} - -static s7_double opt_d_7pid_ssfo_fv(opt_info *o) -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - s7_double val = o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], real(slot_value(o->v[8].p))); - els[integer(slot_value(o->v[2].p))] = val; - return(val); -} - -static s7_pointer opt_d_7pid_ssfo_fv_nr(opt_info *o) /* these next are variations on (float-vector-set! s (float-vector-ref s...)) */ -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - els[integer(slot_value(o->v[2].p))] = o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], real(slot_value(o->v[8].p))); - return(NULL); -} - -static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info *o) -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - els[integer(slot_value(o->v[2].p))] = els[integer(slot_value(o->v[3].p))] + real(slot_value(o->v[8].p)); - return(NULL); -} - -static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info *o) -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - els[integer(slot_value(o->v[2].p))] = els[integer(slot_value(o->v[3].p))] - real(slot_value(o->v[8].p)); - return(NULL); -} - -static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fd == opt_d_v) - { - opc->v[6].p = o1->v[1].p; - opc->v[3].obj = o1->v[5].obj; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_7pid_sso; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - opc->v[3].d_7pi_f = o1->v[3].d_7pi_f; - opc->v[5].p = o1->v[1].p; - opc->v[6].p = o1->v[2].p; - opc->v[0].fd = opt_d_7pid_ss_ss; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fd == opt_d_dd_fso) && - (opc->v[1].p == o1->v[2].p)) - { - /* opc: pid_ssf: o->v[4].d_7pid_f(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)) - * o1: d_dd_fso: o->v[4].d_dd_f(o->v[5].d_7pi_f(slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))) - */ - opc->v[6].d_dd_f = o1->v[4].d_dd_f; - opc->v[5].d_7pi_f = o1->v[5].d_7pi_f; - opc->v[3].p = o1->v[3].p; - opc->v[8].p = o1->v[1].p; - opc->v[0].fd = opt_d_7pid_ssfo; - if ((opc->v[5].d_7pi_f == float_vector_ref_d_7pi) && - ((opc->v[4].d_7pid_f == float_vector_set_d_7pid_direct) || (opc->v[4].d_7pid_f == float_vector_set_d_7pid))) - opc->v[0].fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */ - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp); -static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7pid_t f = s7_d_7pid_function(s_func); - if ((f) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot, head = car(car_x); - int32_t start = sc->pc; - opc->v[4].d_7pid_f = f; - - if (is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, NULL, cdddr(car_x))); - - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - opc->v[10].o1 = sc->opts[start]; - if (is_slot(opc->v[1].p)) - { - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_float_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pid_sss; - return_true(sc, car_x); - } - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = sc->opts[start]->v[0].fd; - if (d_7pid_ssf_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_7pid_ssf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- d_7pii -------- */ -/* currently this can only be float_vector_ref_d_7pii (d_7pii is not exported at this time) */ - -static s7_double opt_d_7pii_sss(opt_info *o) -{ /* o->v[4].d_7pii_f */ - return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)))); -} - -static s7_double opt_d_7pii_sss_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - return(float_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); -} - -static s7_double opt_d_7pii_scs(opt_info *o) -{ - return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)))); -} - -static s7_double opt_d_7pii_sff(opt_info *o) -{ - return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1))); -} - -static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7pii_t ifunc = s7_d_7pii_function(s_func); - if ((ifunc == float_vector_ref_d_7pii) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot; - int32_t start = sc->pc; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if ((!is_slot(opc->v[1].p)) || - (!is_float_vector(slot_value(opc->v[1].p))) || - (vector_rank(slot_value(opc->v[1].p)) != 2)) - return_false(sc, car_x); - - opc->v[4].d_7pii_f = ifunc; /* currently pointless */ - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = slot; - opc->v[0].fd = opt_d_7pii_sss; - if ((step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fd = opt_d_7pii_sss_unchecked; - return_true(sc, car_x); - } - if (is_t_integer(caddr(car_x))) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[0].fd = opt_d_7pii_scs; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[start]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - -/* -------- d_7piid -------- */ -/* currently only float_vector_set */ - -static s7_double opt_d_7piid_sssf(opt_info *o) -{ /* o->v[5].d_7piid_f and below */ - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1))); -} - -static s7_double opt_d_7piid_sssc(opt_info *o) -{ - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].x)); -} - -static s7_double opt_d_7piid_scsf(opt_info *o) -{ - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_7piid_sfff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), i1, i2, o->v[4].fd(o->v[3].o1))); -} - -static s7_double opt_d_7piid_sssf_unchecked(opt_info *o) /* this could be subsumed by the call above if we were using o->v[5] or o->v[0].fd */ -{ - s7_int i1 = integer(slot_value(o->v[2].p)), i2 = integer(slot_value(o->v[3].p)); - s7_pointer vect = slot_value(o->v[1].p); - s7_double val = o->v[9].fd(o->v[8].o1); - float_vector(vect, (i1 * (vector_offset(vect, 0)) + i2)) = val; - return(val); -} - -static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7piid_t f = s7_d_7piid_function(s_func); - if ((f) && - (is_symbol(cadr(car_x)))) - { - opc->v[4].d_7piid_f = f; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), NULL, cddddr(car_x))); - } - return_false(sc, car_x); -} - -/* -------- d_7piii -------- */ -static s7_double opt_d_7piii_ssss(opt_info *o) -{ - return(float_vector_ref_d_7piii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)))); -} - -static s7_double opt_d_7piii_ssss_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - s7_int i1 = integer(slot_value(o->v[2].p)) * vector_offset(v, 0); - s7_int i2 = integer(slot_value(o->v[3].p)) * vector_offset(v, 1); /* offsets accumulate */ - return(float_vector(v, (i1 + i2 + integer(slot_value(o->v[5].p))))); -} - -static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7piii_t ifunc = s7_d_7piii_function(s_func); - if ((ifunc == float_vector_ref_d_7piii) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if ((!is_slot(opc->v[1].p)) || - (!is_float_vector(slot_value(opc->v[1].p))) || - (vector_rank(slot_value(opc->v[1].p)) != 3)) - return_false(sc, car_x); - - opc->v[4].d_7piii_f = ifunc; /* currently ignored */ - slot = opt_integer_symbol(sc, car(cddddr(car_x))); - if (slot) - { - opc->v[5].p = slot; - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - s7_pointer vect = slot_value(opc->v[1].p); - opc->v[2].p = slot; - opc->v[0].fd = opt_d_7piii_ssss; - if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && - (step_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) - opc->v[0].fd = opt_d_7piii_ssss_unchecked; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- d_7piiid -------- */ -static s7_double opt_d_7piiid_ssssf(opt_info *o) -{ - return(float_vector_set_d_7piiid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)), o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_7piiid_ssssf_unchecked(opt_info *o) -{ - s7_pointer vect = slot_value(o->v[1].p); - s7_int i1 = integer(slot_value(o->v[2].p)) * vector_offset(vect, 0); - s7_int i2 = integer(slot_value(o->v[3].p)) * vector_offset(vect, 1); - s7_int i3 = integer(slot_value(o->v[5].p)); - s7_double val = o->v[11].fd(o->v[10].o1); - float_vector(vect, (i1 + i2 + i3)) = val; - return(val); -} - -static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7piiid_t f = s7_d_7piiid_function(s_func); - if ((f == float_vector_set_d_7piiid) && - (is_symbol(cadr(car_x)))) - { - opc->v[4].d_7piiid_f = f; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x), cdr(cddddr(car_x)))); - } - return(false); -} - -static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp) -{ - s7_pointer settee = lookup_slot_from(v, sc->curlet); - if ((is_slot(settee)) && - (!is_immutable(slot_value(settee)))) - { - s7_pointer slot, vect = slot_value(settee); - int32_t start = sc->pc; - opc->v[1].p = settee; - if (!is_float_vector(vect)) - return_false(sc, NULL); - opc->v[10].o1 = sc->opts[start]; - if ((!indexp2) && - (vector_rank(vect) == 1)) - { - opc->v[4].d_7pid_f = float_vector_set_d_7pid; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(vect))) - opc->v[4].d_7pid_f = float_vector_set_d_7pid_direct; - slot = opt_float_symbol(sc, car(valp)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pid_sss; - return_true(sc, NULL); - } - if (is_small_real(car(valp))) - { - opc->v[3].x = s7_real(car(valp)); - opc->v[0].fd = opt_d_7pid_ssc; - return_true(sc, NULL); - } - if (float_optimize(sc, valp)) - { - opc->v[11].fd = sc->opts[start]->v[0].fd; - if (d_7pid_ssf_combinable(sc, opc)) - return_true(sc, NULL); - opc->v[0].fd = opt_d_7pid_ssf; - return_true(sc, NULL); - } - pc_fallback(sc, start); - } - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = (opc->v[4].d_7pid_f == float_vector_set_d_7pid) ? opt_d_7pid_sff_fvset : opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - if ((indexp2) && (!indexp3) && - (vector_rank(vect) == 2)) - { - opc->v[5].d_7piid_f = float_vector_set_d_7piid; - /* could check for step_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid - * perhaps set a different fd? so opc->v[0].fd = fvset_unchecked_d_7piid or whatever - */ - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - if (is_t_integer(car(indexp1))) - { - if (!float_optimize(sc, valp)) - return_false(sc, NULL); - opc->v[0].fd = opt_d_7piid_scsf; - opc->v[2].i = integer(car(indexp1)); - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, NULL); - } - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (is_small_real(car(valp))) - { - opc->v[0].fd = opt_d_7piid_sssc; - opc->v[4].x = s7_real(car(valp)); - return_true(sc, NULL); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piid_sssf; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - - if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(vect, 1)))) - opc->v[0].fd = opt_d_7piid_sssf_unchecked; - return_true(sc, NULL); - } - pc_fallback(sc, start); - }} - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[3].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piid_sfff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[4].fd = opc->v[3].o1->v[0].fd; - return_true(sc, NULL); - }}} - return_false(sc, NULL); - } - if ((indexp3) && - (vector_rank(vect) == 3)) - { - opc->v[4].d_7piiid_f = float_vector_set_d_7piiid; - slot = opt_integer_symbol(sc, car(indexp3)); - if (slot) - { - opc->v[5].p = slot; - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piiid_ssssf; - opc->v[11].fd = sc->opts[start]->v[0].fd; - if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && - (step_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) - opc->v[0].fd = opt_d_7piiid_ssssf_unchecked; - return_true(sc, NULL); - }}}}}} - return_false(sc, NULL); -} - - -/* -------- d_vid -------- */ -static s7_double opt_d_vid_ssf(opt_info *o) {return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));} - -static inline s7_double opt_fmv(opt_info *o) -{ - /* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */ - opt_info *o1 = o->v[12].o1; - opt_info *o2 = o->v[13].o1; - opt_info *o3 = o->v[14].o1; - s7_double amp_env = o1->v[2].d_v_f(o1->v[1].obj); - s7_double vib = real(slot_value(o2->v[2].p)); - s7_double index_env = o3->v[5].d_v_f(o3->v[1].obj); - return(o->v[4].d_vid_f(o->v[5].obj, - integer(slot_value(o->v[2].p)), - amp_env * o2->v[3].d_vd_f(o2->v[5].obj, - vib + (index_env * o3->v[6].d_vd_f(o3->v[2].obj, vib))))); -} - -static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - if ((is_symbol(cadr(car_x))) && - (is_symbol(caddr(car_x)))) - { - s7_pointer sig; - s7_d_vid_t flt = s7_d_vid_function(s_func); - if (!flt) - return_false(sc, car_x); - opc->v[4].d_vid_f = flt; - sig = c_function_signature(s_func); - if (is_pair(sig)) - { - int32_t start = sc->pc; - s7_pointer vslot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (vslot) - { - s7_pointer slot; - opc->v[0].fd = opt_d_vid_ssf; - opc->v[1].p = vslot; - opc->v[10].o1 = sc->opts[start]; - slot = opt_integer_symbol(sc, caddr(car_x)); - if ((slot) && - (float_optimize(sc, cdddr(car_x)))) - { - opt_info *o2; - opc->v[2].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(vslot)); - opc->v[11].fd = opc->v[10].o1->v[0].fd; - o2 = sc->opts[start]; - if (o2->v[0].fd == opt_d_dd_ff_mul1) - { - opt_info *o3 = sc->opts[start + 2]; - if (o3->v[0].fd == opt_d_vd_o1) - { - opt_info *o1 = sc->opts[start + 4]; - if ((o1->v[0].fd == opt_d_dd_ff_o3) && - (o1->v[4].d_dd_f == multiply_d_dd) && - (o3->v[4].d_dd_f == add_d_dd)) - { - opc->v[0].fd = opt_fmv; /* a placeholder -- see below */ - opc->v[12].o1 = o2; - opc->v[13].o1 = o3; - opc->v[14].o1 = o1; - }}} - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- d_vdd -------- */ -static s7_double opt_d_vdd_ff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(o->v[4].d_vdd_f(o->v[5].obj, x1, x2)); -} - -static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_vdd_t flt = s7_d_vdd_function(s_func); - if (flt) - { - s7_pointer sig = c_function_signature(s_func); - opc->v[4].d_vdd_f = flt; - if (is_pair(sig)) - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - int32_t start = sc->pc; - opc->v[10].o1 = sc->opts[start]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - opc->v[0].fd = opt_d_vdd_ff; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }}} - return_false(sc, car_x); -} - - -/* -------- d_dddd -------- */ -static s7_double opt_d_dddd_ffff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - s7_double x3 = o->v[5].fd(o->v[4].o1); - s7_double x4 = o->v[3].fd(o->v[2].o1); - return(o->v[1].d_dddd_f(x1, x2, x3, x4)); -} - -static bool d_dddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_dddd_t f = s7_d_dddd_function(s_func); - if (!f) - return_false(sc, car_x); - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[2].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddddr(car_x))) - { - opc->v[1].d_dddd_f = f; - opc->v[0].fd = opt_d_dddd_ffff; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[5].fd = opc->v[4].o1->v[0].fd; - opc->v[3].fd = opc->v[2].o1->v[0].fd; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- d_add|multiply|subtract_any ------- */ -static s7_double opt_d_add_any_f(opt_info *o) -{ - s7_double sum = 0.0; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum += o1->v[0].fd(o1); - } - return(sum); -} - -static s7_double opt_d_multiply_any_f(opt_info *o) -{ - s7_double sum = 1.0; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum *= o1->v[0].fd(o1); - } - return(sum); -} - -static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) -{ - s7_pointer head = car(car_x); - int32_t start = sc->pc; - if ((head == sc->add_symbol) || - (head == sc->multiply_symbol)) - { - s7_pointer p; - int32_t cur_len; - for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) - { - opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - break; - } - if (is_null(p)) - { - opc->v[1].i = cur_len; - opc->v[0].fd = (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - - -/* -------- d_syntax -------- */ -static s7_double opt_set_d_d_f(opt_info *o) -{ - s7_double x = o->v[3].fd(o->v[2].o1); - slot_set_value(o->v[1].p, make_real(o->sc, x)); - return(x); -} - -static s7_double opt_set_d_d_fm(opt_info *o) -{ - s7_double x = o->v[3].fd(o->v[2].o1); - real(slot_value(o->v[1].p)) = x; - return(x); -} - -static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - if ((len == 3) && - (car(car_x) == sc->set_symbol)) - { - opt_info *opc = alloc_opt_info(sc); - if (is_symbol(cadr(car_x))) - { - s7_pointer settee; - if (is_immutable(cadr(car_x))) - return_false(sc, car_x); - settee = lookup_slot_from(cadr(car_x), sc->curlet); - if ((is_slot(settee)) && - (is_t_real(slot_value(settee))) && - (!is_immutable(settee)) && - ((!slot_has_setter(settee)) || - ((is_c_function(slot_setter(settee))) && - ((slot_setter(settee) == initial_value(sc->is_float_symbol)) || - (c_function_call(slot_setter(settee)) == b_is_float_setter))))) - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[1].p = settee; - if ((!is_t_integer(caddr(car_x))) && - (float_optimize(sc, cddr(car_x)))) - { - opc->v[0].fd = (is_mutable_number(slot_value(opc->v[1].p))) ? opt_set_d_d_fm : opt_set_d_d_f; - opc->v[2].o1 = o1; - opc->v[3].fd = o1->v[0].fd; - return_true(sc, car_x); - }}} - else /* if is_pair(settee) get setter */ - if ((is_pair(cadr(car_x))) && - (is_symbol(caadr(car_x))) && - (is_pair(cdadr(car_x)))) - { - if (is_null(cddadr(car_x))) - return(opt_float_vector_set(sc, opc, caadr(car_x), cdadr(car_x), NULL, NULL, cddr(car_x))); - if (is_null(cdddr(cadr(car_x)))) - return(opt_float_vector_set(sc, opc, caadr(car_x), cdadr(car_x), cddadr(car_x), NULL, cddr(car_x))); - }} - return_false(sc, car_x); -} - -static bool d_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) -{ - s7_pointer slot, obj = slot_value(s_slot); - if (is_float_vector(obj)) - { - /* implicit float-vector-ref */ - if ((len == 2) && - (vector_rank(obj) == 1)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[3].d_7pi_f = float_vector_ref_d_7pi; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(obj))) - opc->v[0].fd = opt_d_7pi_ss_fvref_direct; - else opc->v[0].fd = opt_d_7pi_ss_fvref; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fd = opt_d_7pi_sf; - return_true(sc, car_x); - } - if ((len == 3) && - (vector_rank(obj) == 2)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].d_7pii_f = float_vector_ref_d_7pii; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pii_sss; - if ((step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fd = opt_d_7pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}} - if ((len == 4) && - (vector_rank(obj) == 3)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].d_7piii_f = float_vector_ref_d_7piii; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[5].p = slot; - opc->v[0].fd = opt_d_7piii_ssss; - if ((step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1))) && - (step_end_fits(opc->v[5].p, vector_dimension(obj, 2)))) - opc->v[0].fd = opt_d_7piii_ssss_unchecked; - return_true(sc, car_x); - }}}}} - if ((is_c_object(obj)) && - (len == 2)) - { - s7_pointer getf = c_object_getf(sc, obj); - if (is_c_function(getf)) /* default is #f */ - { - s7_d_7pi_t func = s7_d_7pi_function(getf); - if (func) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].obj = (void *)c_object_value(obj); - opc->v[3].d_7pi_f = func; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[0].fd = opt_d_7pi_ss; - opc->v[2].p = slot; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fd = opt_d_7pi_sf; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - - -/* -------------------------------- bool opts -------------------------------- */ -static bool opt_b_s(opt_info *o) {return(slot_value(o->v[1].p) != o->sc->F);} - -static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - s7_pointer p; - if (!is_symbol(car_x)) - return_false(sc, car_x); /* i.e. use cell_optimize */ - p = opt_simple_symbol(sc, car_x); - if ((p) && - (is_boolean(slot_value(p)))) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fb = opt_b_s; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- b_idp -------- */ -static bool opt_b_i_s(opt_info *o) {return(o->v[2].b_i_f(integer(slot_value(o->v[1].p))));} -static bool opt_b_i_f(opt_info *o) {return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));} -static bool opt_b_d_s(opt_info *o) {return(o->v[2].b_d_f(real(slot_value(o->v[1].p))));} -static bool opt_b_d_f(opt_info *o) {return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));} -static bool opt_b_p_s(opt_info *o) {return(o->v[2].b_p_f(slot_value(o->v[1].p)));} -static bool opt_b_p_f(opt_info *o) {return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));} -static bool opt_b_7p_s(opt_info *o) {return(o->v[2].b_7p_f(o->sc, slot_value(o->v[1].p)));} -static bool opt_b_7p_s_not(opt_info *o) {return(slot_value(o->v[1].p) == o->sc->F);} -static bool opt_b_7p_f(opt_info *o) {return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} -static bool opt_b_d_s_is_positive(opt_info *o) {return(real(slot_value(o->v[1].p)) > 0.0);} -static bool opt_b_p_s_is_integer(opt_info *o) {return(s7_is_integer(slot_value(o->v[1].p)));} -static bool opt_b_p_s_is_pair(opt_info *o) {return(is_pair(slot_value(o->v[1].p)));} -static bool opt_b_p_f_is_string(opt_info *o) {return(s7_is_string(o->v[4].fp(o->v[3].o1)));} -static bool opt_b_7p_s_iter_at_end(opt_info *o) {return(iterator_is_at_end(slot_value(o->v[1].p)));} -static bool opt_b_7p_f_not(opt_info *o) {return((o->v[4].fp(o->v[3].o1)) == o->sc->F);} - -static bool opt_zero_mod(opt_info *o) -{ - s7_int x = integer(slot_value(o->v[1].p)); - return((x % o->v[2].i) == 0); -} - -static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg_type) -{ - s7_b_p_t bpf = NULL; - s7_b_7p_t bpf7 = NULL; - opt_info *opc = alloc_opt_info(sc); - int32_t cur_index = sc->pc; - - if (arg_type == sc->is_integer_symbol) - { - s7_b_i_t bif = s7_b_i_function(s_func); - if (bif) - { - opc->v[2].b_i_f = bif; - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - opc->v[0].fb = opt_b_i_s; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((car(car_x) == sc->is_zero_symbol) && - (o1->v[0].fi == opt_i_ii_sc) && - (o1->v[3].i_ii_f == modulo_i_ii_unchecked)) - { - opc->v[0].fb = opt_zero_mod; - opc->v[1].p = o1->v[1].p; - opc->v[2].i = o1->v[2].i; - backup_pc(sc); - return_true(sc, car_x); - } - opc->v[0].fb = opt_b_i_f; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - }}} - else - if (arg_type == sc->is_float_symbol) - { - s7_b_d_t bdf = s7_b_d_function(s_func); - if (bdf) - { - opc->v[2].b_d_f = bdf; - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - opc->v[0].fb = (bdf == is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fb = opt_b_d_f; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - }}} - pc_fallback(sc, cur_index); - - bpf = s7_b_p_function(s_func); - if (!bpf) bpf7 = s7_b_7p_function(s_func); - if ((bpf) || (bpf7)) - { - if (bpf) - opc->v[2].b_p_f = bpf; - else opc->v[2].b_7p_f = bpf7; - if (is_symbol(cadr(car_x))) - { - s7_pointer p = opt_simple_symbol(sc, cadr(car_x)); - if (!p) return_false(sc, car_x); - opc->v[1].p = p; - opc->v[0].fb = (bpf) ? ((bpf == s7_is_integer) ? opt_b_p_s_is_integer : ((bpf == s7_is_pair) ? opt_b_p_s_is_pair : opt_b_p_s)) : - (((bpf7 == iterator_is_at_end_b_7p) && (is_iterator(slot_value(p)))) ? opt_b_7p_s_iter_at_end : - ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); - return_true(sc, car_x); - } - opc->v[3].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fb = (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : opt_b_p_f) : (bpf7 == not_b_7p) ? opt_b_7p_f_not : opt_b_7p_f; - opc->v[4].fp = opc->v[3].o1->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - - -/* -------- b_pp -------- */ -static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) -{ - s7_pointer slot, arg = car(argp); - if (is_pair(arg)) - { - if (is_symbol(car(arg))) - { - if ((is_global(car(arg))) || - ((is_slot(global_slot(car(arg)))) && - (lookup_slot_from(car(arg), sc->curlet) == global_slot(car(arg))))) - { - s7_pointer a_func = global_value(car(arg)); - if (is_c_function(a_func)) - { - s7_pointer sig = c_function_signature(a_func); - if (is_pair(sig)) - { - if ((car(sig) == sc->is_integer_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_integer_symbol, car(sig))))) - return(sc->is_integer_symbol); - if ((car(sig) == sc->is_float_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_float_symbol, car(sig))))) - return(sc->is_float_symbol); - if ((car(sig) == sc->is_real_symbol) || - (car(sig) == sc->is_number_symbol)) - { - int32_t start = sc->pc; - if (int_optimize(sc, argp)) - { - pc_fallback(sc, start); - return(sc->is_integer_symbol); - } - if (float_optimize(sc, argp)) - { - pc_fallback(sc, start); - return(sc->is_float_symbol); - } - pc_fallback(sc, start); - } - return(car(sig)); /* we want the function's return type in this context */ - } - return(sc->T); - } - if ((car(arg) == sc->quote_symbol) && - (is_pair(cdr(arg)))) - return(s7_type_of(sc, cadr(arg))); - } - slot = lookup_slot_from(car(arg), sc->curlet); - if ((is_slot(slot)) && - (is_sequence(slot_value(slot)))) - { - s7_pointer sig = s7_signature(sc, slot_value(slot)); - if (is_pair(sig)) - return(car(sig)); - }} - return(sc->T); - } - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (!slot) return(sc->T); -#if WITH_GMP - if (is_big_number(slot_value(slot))) - return(sc->T); - if ((is_t_integer(slot_value(slot))) && - (integer(slot_value(slot)) > QUOTIENT_INT_LIMIT)) - return(sc->T); - if ((is_t_real(slot_value(slot))) && - (real(slot_value(slot)) > QUOTIENT_FLOAT_LIMIT)) - return(sc->T); -#endif - return(s7_type_of(sc, slot_value(slot))); - } - return(s7_type_of(sc, arg)); -} - -static bool opt_b_pp_ff(opt_info *o) -{ - s7_pointer p1 = o->v[9].fp(o->v[8].o1); - return(o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1))); -} - -static bool opt_b_7pp_ff(opt_info *o) -{ - s7_pointer p1 = o->v[9].fp(o->v[8].o1); - return(o->v[3].b_7pp_f(o->sc, p1, o->v[11].fp(o->v[10].o1))); -} - -static bool opt_b_pp_sf(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} -static bool opt_b_pp_fs(opt_info *o) {return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} -static bool opt_b_pp_ss(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_pp_sc(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p));} -static bool opt_b_pp_sfo(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_b_7pp_sf(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} -static bool opt_b_7pp_fs(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} -static bool opt_b_7pp_ss(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_ss_lt(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_ss_gt(opt_info *o) {return(gt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_ss_char_lt(opt_info *o) {return(char_lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_sc(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} -static bool opt_b_7pp_sfo(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_is_equivalent_sfo(opt_info *o) {return(is_equivalent_1(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p)), NULL));} -static bool opt_b_pp_sf_char_eq(opt_info *o) {return(slot_value(o->v[1].p) == o->v[11].fp(o->v[10].o1));} /* lt above checks for char args */ -static bool opt_b_pp_ff_char_eq(opt_info *o) {return(o->v[9].fp(o->v[8].o1) == o->v[11].fp(o->v[10].o1));} - -static bool opt_car_equal_sf(opt_info *o) -{ - s7_pointer p = slot_value(o->v[2].p); - return(s7_is_equal(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)))); -} - -static bool opt_car_equivalent_sf(opt_info *o) -{ - s7_pointer p = slot_value(o->v[2].p); - return(is_equivalent_1(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)), NULL)); -} - -static bool opt_b_7pp_car_sf(opt_info *o) -{ - s7_pointer p = slot_value(o->v[2].p); - return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)))); -} - -static s7_pointer opt_p_substring_uncopied_ssf(opt_info *o) /* "inline" here rather than copying below is much slower? */ -{ - return(substring_uncopied_p_pii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[6].fi(o->v[5].o1))); -} - -static bool opt_substring_equal_sf(opt_info *o) {return(scheme_strings_are_equal(slot_value(o->v[1].p), opt_p_substring_uncopied_ssf(o->v[10].o1)));} - -static s7_pointer opt_p_p_s(opt_info *o); - -static bool b_pp_sf_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fp == opt_p_p_s) - { - opc->v[2].p = o1->v[1].p; - opc->v[4].p_p_f = o1->v[2].p_p_f; - if (bpf_case) - opc->v[0].fb = opt_b_pp_sfo; - else - if (opc->v[4].p_p_f == car_p_p) - opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_car_equal_sf : - ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_car_equivalent_sf : opt_b_7pp_car_sf)); - else opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : - ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_is_equivalent_sfo : opt_b_7pp_sfo)); - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool opt_b_pp_ffo(opt_info *o) -{ - s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)); - return(o->v[3].b_pp_f(b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p)))); -} - -static bool opt_b_pp_ffo_is_eq(opt_info *o) -{ - s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)); - s7_pointer b2 = o->v[5].p_p_f(o->sc, slot_value(o->v[2].p)); - return((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2)))); -} - -static bool opt_b_7pp_ffo(opt_info *o) -{ - s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)); - return(o->v[3].b_7pp_f(o->sc, b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p)))); -} - -static bool opt_b_cadr_cadr(opt_info *o) -{ - s7_pointer p1 = slot_value(o->v[1].p); - s7_pointer p2 = slot_value(o->v[2].p); - p1 = ((is_pair(p1)) && (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(o->sc, set_plist_1(o->sc, p1)); - p2 = ((is_pair(p2)) && (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(o->sc, set_plist_1(o->sc, p2)); - return(o->v[3].b_7pp_f(o->sc, p1, p2)); -} - -static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) -{ - if ((sc->pc > 2) && - (opc == sc->opts[sc->pc - 3])) - { - opt_info *o1 = sc->opts[sc->pc - 2], *o2 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fp == opt_p_p_s) && (o2->v[0].fp == opt_p_p_s)) - { - opc->v[1].p = o1->v[1].p; - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[2].p = o2->v[1].p; - opc->v[5].p_p_f = o2->v[2].p_p_f; - opc->v[0].fb = (bpf_case) ? ((opc->v[3].b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq : opt_b_pp_ffo) : - (((opc->v[4].p_p_f == cadr_p_p) && (opc->v[5].p_p_f == cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo); - sc->pc -= 2; - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static void check_b_types(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, bool (*fb)(opt_info *o)) -{ - if (s7_b_pp_unchecked_function(s_func)) - { - s7_pointer call_sig = c_function_signature(s_func); - s7_pointer arg1_type = opt_arg_type(sc, cdr(car_x)); - s7_pointer arg2_type = opt_arg_type(sc, cddr(car_x)); - if ((cadr(call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? (string) (read-line)) */ - (caddr(call_sig) == arg2_type)) - { - opc->v[0].fb = fb; - opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func); - }} -#if 0 - if ((arg2_type == sc->is_integer_symbol) && s7_b_pi_function(s_func)) - { - /* opc->v[0].fb = opt_b_pi */ - fprintf(stderr, " pi: %s\n", display(car_x)); - } -#endif -} - -static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2, bool bpf_case) -{ - int32_t cur_index = sc->pc; - opt_info *o1; - /* v[3] is set when we get here */ - if ((is_symbol(arg1)) && - (is_symbol(arg2))) - { - opc->v[1].p = opt_simple_symbol(sc, arg1); - opc->v[2].p = opt_simple_symbol(sc, arg2); - if ((opc->v[1].p) && - (opc->v[2].p)) - { - s7_b_7pp_t b7f = (bpf_case) ? NULL : opc->v[3].b_7pp_f; - opc->v[0].fb = (bpf_case) ? opt_b_pp_ss : - ((b7f == lt_b_7pp) ? opt_b_7pp_ss_lt : ((b7f == gt_b_7pp) ? opt_b_7pp_ss_gt : - ((b7f == char_lt_b_7pp) ? opt_b_7pp_ss_char_lt : opt_b_7pp_ss))); - return_true(sc, car_x); - }} - if (is_symbol(arg1)) - { - opc->v[1].p = opt_simple_symbol(sc, arg1); - if (!opc->v[1].p) - return_false(sc, car_x); - if ((!is_symbol(arg2)) && - (!is_pair(arg2))) - { - opc->v[2].p = arg2; - opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_sc); - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - if (!b_pp_sf_combinable(sc, opc, bpf_case)) - { - opc->v[10].o1 = sc->opts[cur_index]; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_sf); /* this finds b_pp_unchecked cases */ - if ((opc->v[11].fp == opt_p_substring_uncopied_ssf) && (opc->v[3].b_pp_f == string_eq_b_unchecked)) - opc->v[0].fb = opt_substring_equal_sf; - else if (opc->v[3].b_pp_f == char_eq_b_unchecked) opc->v[0].fb = opt_b_pp_sf_char_eq; - } - return_true(sc, car_x); - } - pc_fallback(sc, cur_index); - } - else - if ((is_symbol(arg2)) && - (is_pair(arg1))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); - if ((!is_slot(opc->v[1].p)) || - (has_methods(slot_value(opc->v[1].p)))) - return_false(sc, car_x); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_fs); - return_true(sc, car_x); - } - pc_fallback(sc, cur_index); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - if (b_pp_ff_combinable(sc, opc, bpf_case)) - return_true(sc, car_x); - opc->v[0].fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; - opc->v[8].o1 = o1; - opc->v[9].fp = o1->v[0].fp; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); - if (opc->v[3].b_pp_f == char_eq_b_unchecked) opc->v[0].fb = opt_b_pp_ff_char_eq; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - -/* -------- b_pi -------- */ -static bool opt_b_pi_fs(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} -static bool opt_b_pi_fs_num_eq(opt_info *o) {return(num_eq_b_pi(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} -static bool opt_b_pi_fi(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), o->v[1].i));} -static bool opt_b_pi_ff(opt_info *o) {s7_pointer p1 = o->v[11].fp(o->v[10].o1); return(o->v[2].b_pi_f(o->sc, p1, o->v[9].fi(o->v[8].o1)));} - -static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2) -{ - s7_b_pi_t bpif = s7_b_pi_function(s_func); /* perhaps add vector-ref/equal? */ - if (bpif) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[2].b_pi_f = bpif; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(arg2)) - { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ - opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; - return_true(sc, car_x); - } - if (is_t_integer(arg2)) - { - opc->v[1].i = integer(arg2); - opc->v[0].fb = opt_b_pi_fi; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fb = opt_b_pi_ff; - opc->v[8].o1 = o1; - opc->v[9].fp = o1->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - - -/* -------- b_dd -------- */ -static bool opt_b_dd_ss(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static bool opt_b_dd_ss_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < real(slot_value(o->v[2].p)));} -static bool opt_b_dd_ss_gt(opt_info *o) {return(real(slot_value(o->v[1].p)) > real(slot_value(o->v[2].p)));} - -static bool opt_b_dd_sc(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));} -static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < o->v[2].x);} -static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(o->v[1].p)) >= o->v[2].x);} -static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(o->v[1].p)) == o->v[2].x);} - -static bool opt_b_dd_sf(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));} -static bool opt_b_dd_fs(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));} -static bool opt_b_dd_fs_gt(opt_info *o) {return(o->v[11].fd(o->v[10].o1) > real(slot_value(o->v[1].p)));} -static bool opt_b_dd_fc(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));} -static bool opt_b_dd_fc_gt(opt_info *o) {return(o->v[11].fd(o->v[10].o1) > o->v[1].x);} - -static bool opt_b_dd_ff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(o->v[3].b_dd_f(x1, x2)); -} - -static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) -{ - s7_b_dd_t bif = s7_b_dd_function(s_func); - int32_t cur_index = sc->pc; - if (!bif) - return_false(sc, car_x); - opc->v[3].b_dd_f = bif; - if (is_symbol(arg1)) - { - opc->v[1].p = lookup_slot_from(arg1, sc->curlet); - if (is_symbol(arg2)) - { - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_ss_lt : ((bif == gt_b_dd) ? opt_b_dd_ss_gt : opt_b_dd_ss); - return_true(sc, car_x); - } - if (is_t_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_sc_lt : ((bif == geq_b_dd) ? opt_b_dd_sc_geq : ((bif == num_eq_b_dd) ? opt_b_dd_sc_eq : opt_b_dd_sc)); - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fb = opt_b_dd_sf; - return_true(sc, car_x); - }} - pc_fallback(sc, cur_index); - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - if (is_symbol(arg2)) - { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); - opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; - return_true(sc, car_x); - } - if (is_small_real(arg2)) - { - opc->v[1].x = s7_number_to_real(sc, arg2); - opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[0].fb = opt_b_dd_ff; - return_true(sc, car_x); - }} - pc_fallback(sc, cur_index); - return_false(sc, car_x); -} - - -/* -------- b_ii -------- */ -static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} -static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);} -static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= o->v[2].i);} -static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > o->v[2].i);} -static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= o->v[2].i);} -static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);} -static bool opt_b_ii_sc_lt_2(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 2);} -static bool opt_b_ii_sc_lt_1(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 1);} -static bool opt_b_ii_sc_lt_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 0);} -static bool opt_b_ii_sc_leq_0(opt_info *o){return(integer(slot_value(o->v[1].p)) <= 0);} -static bool opt_b_ii_sc_gt_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) > 0);} -static bool opt_b_ii_sc_geq_0(opt_info *o){return(integer(slot_value(o->v[1].p)) >= 0);} -static bool opt_b_ii_sc_eq_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) == 0);} -static bool opt_b_ii_sc_eq_1(opt_info *o) {return(integer(slot_value(o->v[1].p)) == 1);} - -static bool opt_b_7ii_ss(opt_info *o) {return(o->v[3].b_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static bool opt_b_7ii_sc(opt_info *o) {return(o->v[3].b_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} -static bool opt_b_7ii_sc_bit(opt_info *o) {return((integer(slot_value(o->v[1].p)) & ((int64_t)(1LL << o->v[2].i))) != 0);} - -static bool opt_b_ii_ff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[3].b_ii_f(i1, i2)); -} - -static bool opt_b_ii_fs(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} -static bool opt_b_ii_sf(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));} -static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1));} -static bool opt_b_ii_fc(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} -static bool opt_b_ii_fc_eq(opt_info *o) {return(o->v[11].fi(o->v[10].o1) == o->v[2].i);} - -static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) -{ - s7_b_ii_t bif = s7_b_ii_function(s_func); - s7_b_7ii_t b7if = NULL; - if (!bif) - { - b7if = s7_b_7ii_function(s_func); - if (!b7if) - return_false(sc, car_x); - } - if (bif) opc->v[3].b_ii_f = bif; else opc->v[3].b_7ii_f = b7if; - if (is_symbol(arg1)) - { - opc->v[1].p = lookup_slot_from(arg1, sc->curlet); - if (is_symbol(arg2)) - { - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - - opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : - ((bif == leq_b_ii) ? opt_b_ii_ss_leq : - ((bif == gt_b_ii) ? opt_b_ii_ss_gt : - ((bif == geq_b_ii) ? opt_b_ii_ss_geq : - ((bif == num_eq_b_ii) ? opt_b_ii_ss_eq : - ((bif) ? opt_b_ii_ss : opt_b_7ii_ss))))); - return_true(sc, car_x); - } - if (is_t_integer(arg2)) - { - s7_int i2 = integer(arg2); - opc->v[2].i = i2; - opc->v[0].fb = (bif == num_eq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_eq_0 : ((i2 == 1) ? opt_b_ii_sc_eq_1 : opt_b_ii_sc_eq)) : - ((bif == lt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_lt_0 : ((i2 == 1) ? opt_b_ii_sc_lt_1 : ((i2 == 2) ? opt_b_ii_sc_lt_2 : opt_b_ii_sc_lt))) : - ((bif == gt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_gt_0 : opt_b_ii_sc_gt) : - ((bif == leq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_leq_0 : opt_b_ii_sc_leq) : - ((bif == geq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_geq_0 : opt_b_ii_sc_geq) : - (((b7if == logbit_b_7ii) && (i2 >= 0) && (i2 < S7_INT_BITS)) ? opt_b_7ii_sc_bit : - ((bif) ? opt_b_ii_sc : opt_b_7ii_sc)))))); - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if ((bif) && (int_optimize(sc, cddr(car_x)))) - { - opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - if (!bif) return_false(sc, car_x); - - if (is_symbol(arg2)) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - opc->v[0].fb = opt_b_ii_fs; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[0].fb = opt_b_ii_ff; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - -/* -------- b_or|and -------- */ -static bool opt_and_bb(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) && (o->v[11].fb(o->v[10].o1)));} - -static bool opt_and_any_b(opt_info *o) -{ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - if (!o1->v[0].fb(o1)) - return(false); - } - return(true); -} - -static bool opt_or_bb(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) || o->v[11].fb(o->v[10].o1));} - -static bool opt_or_any_b(opt_info *o) -{ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - if (o1->v[0].fb(o1)) - return(true); - } - return(false); -} - -static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t is_and) -{ - opt_info *opc = alloc_opt_info(sc); - s7_pointer p = cdr(car_x); - if (len == 3) - { - opt_info *o1 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, cddr(car_x))) - { - opc->v[10].o1 = o2; - opc->v[11].fb = o2->v[0].fb; - opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb; - opc->v[2].o1 = o1; - opc->v[3].fb = o1->v[0].fb; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - opc->v[1].i = (len - 1); - for (int32_t i = 0; (is_pair(p)) && (i < 12); i++, p = cdr(p)) - { - opc->v[i + 3].o1 = sc->opts[sc->pc]; - if (!bool_optimize_nw(sc, p)) - break; - } - if (!is_null(p)) - return_false(sc, car_x); - opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b; - return_true(sc, car_x); -} - -static bool opt_b_and(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_b_or_and(sc, car_x, len, true));} -static bool opt_b_or(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_b_or_and(sc, car_x, len, false));} - - -/* ---------------------------------------- cell opts ---------------------------------------- */ -static s7_pointer opt_p_c(opt_info *o) {return(o->v[1].p);} -static s7_pointer opt_p_s(opt_info *o) {return(slot_value(o->v[1].p));} - -static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - s7_pointer p; - opt_info *opc; - if (!is_symbol(car_x)) - { - opc = alloc_opt_info(sc); - opc->v[1].p = car_x; - opc->v[0].fp = opt_p_c; - return_true(sc, car_x); - } - p = opt_simple_symbol(sc, car_x); - if (!p) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fp = opt_p_s; - return_true(sc, car_x); -} - -/* -------- p -------- */ -#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P)))) - -#define cf_call(Sc, Car_x, S_func, Num) \ - (((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x, false))) - -static s7_pointer opt_p_f(opt_info *o) {return(o->v[1].p_f(o->sc));} -static s7_pointer opt_p_call(opt_info *o) {return(o->v[1].call(o->sc, o->sc->nil));} - -static bool p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_t func = s7_p_function(s_func); - if (func) - { - opc->v[1].p_f = func; - opc->v[0].fp = opt_p_f; - return_true(sc, car_x); - } - if ((is_safe_procedure(s_func)) && - (c_function_min_args(s_func) == 0)) - { - opc->v[1].call = cf_call(sc, car_x, s_func, 0); - opc->v[0].fp = opt_p_call; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- p_p -------- */ -static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o); -static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o); - -static s7_pointer opt_p_p_c(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[1].p));} -static s7_pointer opt_p_i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_i_f(o->v[1].i)));} -static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_7i_f(o->sc, o->v[1].i)));} -static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));} -static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));} -static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_s_abs(opt_info *o) {return(abs_p_p(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_s_cdr(opt_info *o) {s7_pointer p = slot_value(o->v[1].p); return((is_pair(p)) ? cdr(p) : cdr_p_p(o->sc, p));} -static s7_pointer opt_p_p_f(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_p_f1(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));} -static s7_pointer opt_p_p_f_exp(opt_info *o) {return(exp_p_p(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_7d_c_random(opt_info *o) {return(make_real(o->sc, random_d_7d(o->sc, o->v[1].x)));} -static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_f_iterate(opt_info *o) {return(iterate_p_p(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_p_f_string_to_number(opt_info *o) {return(string_to_number_p_p(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_p_s_iterate_unchecked(opt_info *o) {s7_pointer iter = slot_value(o->v[1].p); return(iterator_next(iter)(o->sc, iter));} -static s7_pointer opt_p_p_fvref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_fvref_direct(o->v[3].o1)));} /* unwrap to fvref is not faster */ -static s7_pointer opt_p_p_vref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_vref_direct(o->v[3].o1)));} - -static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fp == opt_p_p_s) - { - opc->v[3].p_p_f = o1->v[2].p_p_f; - opc->v[1].p = o1->v[1].p; - opc->v[0].fp = opt_p_p_f1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_pointer opt_p_call_f(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));} -static s7_pointer opt_p_call_s(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));} -static s7_pointer opt_p_call_c(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[1].p)));} - -static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_p_t ppf; - int32_t start = sc->pc; - if (is_t_integer(cadr(car_x))) - { - s7_i_i_t iif = s7_i_i_function(s_func); - s7_i_7i_t i7if; - opc->v[1].i = integer(cadr(car_x)); - if (iif) - { - opc->v[2].i_i_f = iif; - opc->v[0].fp = opt_p_i_c; - return_true(sc, car_x); - } - i7if = s7_i_7i_function(s_func); - if (i7if) - { - opc->v[2].i_7i_f = i7if; - opc->v[0].fp = opt_p_7i_c; - return_true(sc, car_x); - }} - if (is_t_real(cadr(car_x))) - { - s7_d_d_t ddf = s7_d_d_function(s_func); - s7_d_7d_t d7df; - opc->v[1].x = real(cadr(car_x)); - if (ddf) - { - opc->v[2].d_d_f = ddf; - opc->v[0].fp = opt_p_d_c; - return_true(sc, car_x); - } - d7df = s7_d_7d_function(s_func); - if (d7df) - { - opc->v[2].d_7d_f = d7df; - opc->v[0].fp = (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; - return_true(sc, car_x); - }} - ppf = s7_p_p_function(s_func); - if (ppf) - { - opt_info *o1; - opc->v[2].p_p_f = ppf; - if ((ppf == symbol_to_string_p_p) && - (is_optimized(car_x)) && - (fn_proc(car_x) == g_symbol_to_string_uncopied)) - opc->v[2].p_p_f = symbol_to_string_uncopied_p; - - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = opt_simple_symbol(sc, cadr(car_x)); - if (!opc->v[1].p) - return_false(sc, car_x); - opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : - ((ppf == iterate_p_p) ? ((is_iterator(slot_value(opc->v[1].p))) ? opt_p_p_s_iterate_unchecked : opt_p_p_s_iterate) : opt_p_p_s)); - return_true(sc, car_x); - } - if (!is_pair(cadr(car_x))) - { - if (opc->v[2].p_p_f == s7_length) - { - opc->v[1].p = s7_length(sc, cadr(car_x)); - opc->v[0].fp = opt_p_c; - } - else - { - opc->v[1].p = cadr(car_x); - opc->v[0].fp = opt_p_p_c; - } - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - if (!p_p_f_combinable(sc, opc)) - { - s7_pointer (*fp)(opt_info *o); - opc->v[0].fp = (ppf == exp_p_p) ? opt_p_p_f_exp : ((ppf == iterate_p_p) ? opt_p_p_f_iterate : - ((ppf == string_to_number_p_p) ? opt_p_p_f_string_to_number : opt_p_p_f)); - if (caadr(car_x) == sc->string_ref_symbol) - { - if (opc->v[2].p_p_f == char_upcase_p_p) - opc->v[2].p_p_f = char_upcase_p_p_unchecked; - else - if (opc->v[2].p_p_f == is_char_whitespace_p_p) - opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked; - } - opc->v[3].o1 = o1; - fp = o1->v[0].fp; - opc->v[4].fp = fp; - if (fp == opt_p_pi_ss_fvref_direct) opc->v[0].fp = opt_p_p_fvref; - else if (fp == opt_p_pi_ss_vref_direct) opc->v[0].fp = opt_p_p_vref; - } - return_true(sc, car_x); - }} - - pc_fallback(sc, start); - if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 1))) - { - opc->v[2].call = cf_call(sc, car_x, s_func, 1); - if (is_symbol(cadr(car_x))) - { - s7_pointer slot = opt_simple_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[1].p = slot; - opc->v[0].fp = opt_p_call_s; - return_true(sc, car_x); - }} - else - { - opt_info *o1; - if (!is_pair(cadr(car_x))) - { - opc->v[1].p = cadr(car_x); - opc->v[0].fp = opt_p_call_c; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fp = opt_p_call_f; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- p_i -------- */ -static s7_pointer opt_p_i_s(opt_info *o) {return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));} /* number_to_string_p_i expanded here doesn't gain much */ -static s7_pointer opt_p_i_f(opt_info *o) {return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));} -static s7_pointer opt_p_i_f_intc(opt_info *o) {return(integer_to_char_p_i(o->sc, o->v[4].fi(o->v[3].o1)));} - -static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer p; - s7_p_i_t ifunc = s7_p_i_function(s_func); - if (!ifunc) - return_false(sc, car_x); - p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[2].p_i_f = ifunc; - opc->v[0].fp = opt_p_i_s; - return_true(sc, car_x); - } - if (int_optimize(sc, cdr(car_x))) - { - opc->v[2].p_i_f = ifunc; - opc->v[0].fp = (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; - opc->v[3].o1 = sc->opts[pstart]; - opc->v[4].fi = sc->opts[pstart]->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_ii -------- */ -static s7_pointer opt_p_ii_ss(opt_info *o) {return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_ii_fs(opt_info *o) {return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_ii_ff_divide(opt_info *o) {return(make_ratio_with_div_check(o->sc, o->sc->divide_symbol, o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));} - -static s7_pointer opt_p_ii_ff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - return(o->v[3].p_ii_f(o->sc, i1, o->v[9].fi(o->v[8].o1))); -} - -static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer p2; - s7_p_ii_t ifunc = s7_p_ii_function(s_func); - if (!ifunc) - return_false(sc, car_x); - p2 = opt_integer_symbol(sc, caddr(car_x)); - if (p2) - { - s7_pointer p1 = opt_integer_symbol(sc, cadr(car_x)); - if (p1) - { - opc->v[1].p = p1; - opc->v[2].p = p2; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = opt_p_ii_ss; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = p2; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = opt_p_ii_fs; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; - return_true(sc, car_x); - }} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_d -------- */ -static s7_pointer opt_p_d_s(opt_info *o) {return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), __func__)));} -static s7_pointer opt_p_d_f(opt_info *o) {return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));} -/* static s7_pointer opt_p_d_fvref(opt_info *o) {return(o->v[2].p_d_f(o->sc, float_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)))));} */ - -static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer p; - opt_info *o1; - s7_p_d_t ifunc = s7_p_d_function(s_func); - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(car_x)); */ - - if (!ifunc) - return_false(sc, car_x); - p = opt_float_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[2].p_d_f = ifunc; - opc->v[0].fp = opt_p_d_s; - return_true(sc, car_x); - } - if ((is_number(cadr(car_x))) && (!is_t_real(cadr(car_x)))) - return_false(sc, car_x); - o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[2].p_d_f = ifunc; - opc->v[0].fp = opt_p_d_f; - opc->v[3].o1 = o1; - opc->v[4].fd = o1->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_dd -------- */ -static s7_pointer opt_p_dd_sc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), __func__), o->v[2].x));} -static s7_pointer opt_p_dd_cs(opt_info *o) {return(o->v[3].p_dd_f(o->sc, o->v[2].x, real_to_double(o->sc, slot_value(o->v[1].p), __func__)));} -static s7_pointer opt_p_dd_cc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, o->v[1].x, o->v[2].x));} - -static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_p_dd_t ifunc = s7_p_dd_function(s_func); - if (!ifunc) - return_false(sc, car_x); - if (is_t_real(arg2)) - { - if (is_t_real(arg1)) - { - opc->v[1].x = real(arg1); - opc->v[2].x = real(arg2); - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_cc; - return_true(sc, car_x); - } - slot = opt_real_symbol(sc, arg1); - if (slot) - { - opc->v[2].x = real(arg2); - opc->v[1].p = slot; - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_sc; - return_true(sc, car_x); - }} - if (is_t_real(arg1)) - { - slot = opt_real_symbol(sc, arg2); - if (slot) - { - opc->v[2].x = real(arg1); - opc->v[1].p = slot; - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_cs; - return_true(sc, car_x); - }} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_pi -------- */ -static s7_pointer opt_p_pi_ss(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_vref(opt_info *o) {return(normal_vector_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o) {return(normal_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o) {return(float_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o) {return(int_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_lref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_sc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_pointer opt_p_pi_sc_lref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_pointer opt_p_pi_sf(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_sf_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_sf_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_fc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));} - -/* use a unique name for this use of denominator (need to remember that any such integer should be new (i.e. mutable, not a small int) */ -#define do_loop_end(A) denominator(T_Int(A)) -#define set_do_loop_end(A, B) denominator(T_Int(A)) = B - -static void check_unchecked(s7_scheme *sc, s7_pointer obj, s7_pointer slot, opt_info *opc, s7_pointer expr) -{ - switch (type(obj)) /* can't use funcs here (opc->v[3].p_pi_f et al) because there are so many, and copy depends on this choice */ - { - case T_STRING: - if (((!expr) || (car(expr) == sc->string_ref_symbol)) && (do_loop_end(slot_value(slot)) <= string_length(obj))) - opc->v[3].p_pi_f = string_ref_p_pi_direct; - break; - case T_BYTE_VECTOR: - if (((!expr) || (car(expr) == sc->byte_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (do_loop_end(slot_value(slot)) <= byte_vector_length(obj))) - opc->v[3].p_pi_f = byte_vector_ref_p_pi_direct; - break; - case T_VECTOR: - if (((!expr) || (car(expr) == sc->vector_ref_symbol)) && (do_loop_end(slot_value(slot)) <= vector_length(obj))) - opc->v[3].p_pi_f = normal_vector_ref_p_pi_direct; - break; - case T_FLOAT_VECTOR: - if (((!expr) || (car(expr) == sc->float_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (do_loop_end(slot_value(slot)) <= vector_length(obj))) - opc->v[3].p_pi_f = float_vector_ref_p_pi_direct; - break; - case T_INT_VECTOR: - if (((!expr) || (car(expr) == sc->int_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (do_loop_end(slot_value(slot)) <= vector_length(obj))) - opc->v[3].p_pi_f = int_vector_ref_p_pi_direct; - break; - } -} - -static void fixup_p_pi_ss(opt_info *opc) -{ - opc->v[0].fp = (opc->v[3].p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref : - ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_ss_sref_direct : - ((opc->v[3].p_pi_f == normal_vector_ref_p_pi_unchecked) ? opt_p_pi_ss_vref : - ((opc->v[3].p_pi_f == float_vector_ref_p_pi_direct) ? opt_p_pi_ss_fvref_direct : - ((opc->v[3].p_pi_f == int_vector_ref_p_pi_direct) ? opt_p_pi_ss_ivref_direct : - ((opc->v[3].p_pi_f == normal_vector_ref_p_pi_direct) ? opt_p_pi_ss_vref_direct : - ((opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_ss_lref : opt_p_pi_ss)))))); -} - -static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x) -{ - s7_pointer obj = NULL, slot1, checker = NULL; - opt_info *o1; - s7_p_pi_t func = s7_p_pi_function(s_func); - if (!func) - return_false(sc, car_x); - /* here we know cadr is a symbol */ - slot1 = opt_simple_symbol(sc, cadr(car_x)); - if (!slot1) - return_false(sc, car_x); - if ((is_any_vector(slot_value(slot1))) && - (vector_rank(slot_value(slot1)) > 1)) - return_false(sc, car_x); - - opc->v[3].p_pi_f = func; - opc->v[1].p = slot1; - - if (is_symbol(cadr(sig))) - checker = cadr(sig); - - if ((s7_p_pi_unchecked_function(s_func)) && - (checker)) - { - obj = slot_value(opc->v[1].p); - if ((is_string(obj)) || - (is_pair(obj)) || - (is_any_vector(obj))) - { - if (((is_string(obj)) && (checker == sc->is_string_symbol)) || - ((is_any_vector(obj)) && (checker == sc->is_vector_symbol)) || - ((is_pair(obj)) && (checker == sc->is_pair_symbol)) || - ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol))) - opc->v[3].p_pi_f = (is_normal_vector(obj)) ? normal_vector_ref_p_pi_unchecked : s7_p_pi_unchecked_function(s_func); - }} - slot1 = opt_integer_symbol(sc, caddr(car_x)); - if (slot1) - { - opc->v[2].p = slot1; - if ((obj) && - (is_step_end(slot1))) - check_unchecked(sc, obj, slot1, opc, car_x); - fixup_p_pi_ss(opc); - return_true(sc, car_x); - } - if (is_t_integer(caddr(car_x))) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[0].fp = (opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_sc_lref : opt_p_pi_sc; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = (opc->v[3].p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : - ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_sf_sref_direct : opt_p_pi_sf); - opc->v[4].o1 = o1; - opc->v[5].fi = o1->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -static s7_pointer opt_p_pi_fco(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)), o->v[2].i));} - -static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fp == opt_p_p_s) - { - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[1].p = o1->v[1].p; - opc->v[0].fp = opt_p_pi_fco; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -/* -------- p_pp -------- */ -static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static s7_pointer opt_p_pp_sc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} -static s7_pointer opt_p_pp_cs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_sf(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));} -static s7_pointer opt_p_pp_cc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[1].p, o->v[2].p));} -static s7_pointer opt_p_pp_cc_make_list(opt_info *o) {return(make_list(o->sc, o->v[1].i, o->v[2].p));} -static s7_pointer opt_set_car_pp_ss(opt_info *o) {return(inline_set_car(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static s7_pointer opt_p_pp_ss_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static s7_pointer opt_p_pp_sf_add(opt_info *o) {return(add_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_sub(opt_info *o) {return(subtract_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_mul(opt_info *o) {return(multiply_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_set_car(opt_info *o) {return(inline_set_car(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_set_cdr(opt_info *o) {return(inline_set_cdr(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_fs_vref(opt_info *o) {return(vector_ref_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fs_add(opt_info *o) {return(add_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fs_sub(opt_info *o) {return(subtract_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} - -static s7_pointer opt_p_pp_ff(opt_info *o) -{ - s7_scheme *sc = o->sc; - s7_pointer result; - gc_protect_2_via_stack(sc, o->v[11].fp(o->v[10].o1), o->v[9].fp(o->v[8].o1)); /* we do need to protect both */ - result = o->v[3].p_pp_f(sc, stack_protected1(sc), stack_protected2(sc)); - unstack(sc); - return(result); -} - -static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|- (* s1 f2) (* s3 f4)) */ -{ - opt_info *o1 = o->v[10].o1, *o2 = o->v[8].o1; - s7_pointer f4; - s7_scheme *sc = o->sc; - s7_pointer s1 = slot_value(o1->v[1].p); - s7_pointer s3 = slot_value(o2->v[1].p); - s7_pointer f2 = o1->v[5].fp(o1->v[4].o1); - if ((is_t_real(f2)) && (is_t_real(s1)) && (is_t_real(s3))) - { - s7_double r2 = real(f2); - f4 = o2->v[5].fp(o2->v[4].o1); - if (is_t_real(f4)) - return(make_real(sc, (add_case) ? ((real(s1) * r2) + (real(s3) * real(f4))) : ((real(s1) * r2) - (real(s3) * real(f4))))); - gc_protect_via_stack(sc, f2); - } - else - { - gc_protect_via_stack(sc, f2); - f4 = o2->v[5].fp(o2->v[4].o1); - } - set_stack_protected2(sc, f4); - set_stack_protected2(sc, multiply_p_pp(sc, s3, f4)); - set_stack_protected1(sc, multiply_p_pp(sc, s1, f2)); - s3 = (add_case) ? add_p_pp(sc, stack_protected1(sc), stack_protected2(sc)) : subtract_p_pp(sc, stack_protected1(sc), stack_protected2(sc)); - unstack(sc); - return(s3); -} - -static s7_pointer opt_p_pp_ff_add_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, true));} -static s7_pointer opt_p_pp_ff_sub_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, false));} - -static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer slot; - s7_p_pp_t func = s7_p_pp_function(s_func); - if (!func) - return_false(sc, car_x); - - opc->v[3].p_pp_f = func; - if (is_symbol(cadr(car_x))) - { - slot = opt_simple_symbol(sc, cadr(car_x)); - if (!slot) - { - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if ((is_any_vector(slot_value(slot))) && - (vector_rank(slot_value(slot)) > 1)) - { - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - opc->v[1].p = slot; - - if ((func == hash_table_ref_p_pp) && (is_hash_table(slot_value(slot)))) - opc->v[3].p_pp_f = s7_hash_table_ref; - - if (is_symbol(caddr(car_x))) - { - opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[2].p) - { - opc->v[0].fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : ((opc->v[3].p_pp_f == s7_hash_table_ref) ? opt_p_pp_ss_href : opt_p_pp_ss); - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) - { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); - opc->v[0].fp = opt_p_pp_sc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == multiply_p_pp) ? opt_p_pp_sf_mul : - ((func == set_car_p_pp) ? opt_p_pp_sf_set_car : ((func == set_cdr_p_pp) ? opt_p_pp_sf_set_cdr : - ((opc->v[3].p_pp_f == s7_hash_table_ref) ? opt_p_pp_sf_href : opt_p_pp_sf))))); - opc->v[4].o1 = sc->opts[pstart]; - opc->v[5].fp = sc->opts[pstart]->v[0].fp; - return_true(sc, car_x); - }} - else - { - opt_info *o1 = sc->opts[sc->pc]; - if ((!is_pair(cadr(car_x))) || - (is_proper_quote(sc, cadr(car_x)))) - { - opc->v[1].p = (!is_pair(cadr(car_x))) ? cadr(car_x) : cadadr(car_x); - if ((!is_symbol(caddr(car_x))) && - ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x))))) - { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); - if ((opc->v[3].p_pp_f == make_list_p_pp) && - (is_t_integer(opc->v[1].p)) && (integer(opc->v[1].p) >= 0) && (integer(opc->v[1].p) < sc->max_list_length)) - { - opc->v[0].fp = opt_p_pp_cc_make_list; - opc->v[1].i = integer(opc->v[1].p); - } - else opc->v[0].fp = opt_p_pp_cc; - return_true(sc, car_x); - } - if (is_symbol(caddr(car_x))) - { - opc->v[2].p = opc->v[1].p; - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[1].p) - { - opc->v[0].fp = opt_p_pp_cs; - if (is_pair(slot_value(opc->v[1].p))) - { - if (func == assq_p_pp) opc->v[3].p_pp_f = s7_assq; - else - if (func == memq_p_pp) opc->v[3].p_pp_f = s7_memq; - else - if ((func == member_p_pp) && (is_simple(opc->v[2].p))) opc->v[3].p_pp_f = s7_memq; - else - if (func == assoc_p_pp) - { - if (is_simple(opc->v[2].p)) opc->v[3].p_pp_f = s7_assq; - else if (is_pair(car(slot_value(opc->v[1].p)))) opc->v[3].p_pp_f = assoc_1; - }} - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - }} - if (cell_optimize(sc, cdr(car_x))) - { - if (is_symbol(caddr(car_x))) - { - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[1].p) - { - opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : - ((func == vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == cons_p_pp) ? opt_p_pp_fs_cons : opt_p_pp_fs))); - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) - { - if (is_t_integer(caddr(car_x))) - { - s7_p_pi_t ifunc = s7_p_pi_function(s_func); - if (ifunc) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[3].p_pi_f = ifunc; - if (!p_pi_fc_combinable(sc, opc)) - { - opc->v[0].fp = opt_p_pi_fc; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - } - return_true(sc, car_x); - }} - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); - opc->v[0].fp = opt_p_pp_fc; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[0].fp = opt_p_pp_ff; - - if ((opc->v[9].fp == opt_p_pp_sf_mul) && (opc->v[11].fp == opt_p_pp_sf_mul)) - { - if (func == add_p_pp) opc->v[0].fp = opt_p_pp_ff_add_mul_mul; - else if (func == subtract_p_pp) opc->v[0].fp = opt_p_pp_ff_sub_mul_mul; - } - - return_true(sc, car_x); - }}} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_call_pp -------- */ -static s7_pointer opt_p_call_ff(opt_info *o) -{ - s7_pointer po2; - s7_scheme *sc = o->sc; - gc_protect_via_stack(sc, o->v[11].fp(o->v[10].o1)); - po2 = o->v[9].fp(o->v[8].o1); - po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2)); - unstack(sc); - return(po2); -} - -static s7_pointer opt_p_call_fs(opt_info *o) -{ - s7_pointer po1 = o->v[11].fp(o->v[10].o1); - return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p)))); -} - -static s7_pointer opt_p_call_sf(opt_info *o) -{ - s7_pointer po1 = o->v[11].fp(o->v[10].o1); - return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1))); -} - -static s7_pointer opt_p_call_sc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), o->v[2].p)));} -static s7_pointer opt_p_call_ss(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p))));} - -static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 2))) - { - /* if optimized, we want to use the current fn_proc (to take advantage of fixups like substring_temp), - * but those same fixups are incorrect for this context if op_safe_c_c related. - */ - opc->v[3].call = cf_call(sc, car_x, s_func, 2); - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if ((is_slot(opc->v[1].p)) && - (!has_methods(slot_value(opc->v[1].p)))) - { - if (is_symbol(caddr(car_x))) - { - opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[2].p) - { - opc->v[0].fp = opt_p_call_ss; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if (!is_pair(caddr(car_x))) - { - opc->v[2].p = caddr(car_x); - opc->v[0].fp = opt_p_call_sc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = sc->opts[pstart]; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fp = opt_p_call_sf; - return_true(sc, car_x); - }} - else - { - pc_fallback(sc, pstart); - return_false(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(caddr(car_x))) - { - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[1].p) - { - opc->v[0].fp = opt_p_call_fs; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[0].fp = opt_p_call_ff; - return_true(sc, car_x); - }}} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - - -/* -------- p_pip --------*/ - -static s7_pointer opt_p_pip_ssf(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pip_ssf_sset(opt_info *o) {return(string_set_p_pip_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pip_ssf_vset(opt_info *o) {return(vector_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pip_sss(opt_info *o) {return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));} -static s7_pointer opt_p_pip_sss_vset(opt_info *o) {return(vector_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));} -static s7_pointer opt_p_pip_ssc(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p));} -static s7_pointer opt_p_pip_c(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));} - -static s7_pointer opt_p_pip_sff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1))); -} - -static s7_pointer opt_p_pip_sff_lset(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - return(list_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1))); -} - -static s7_pointer opt_p_pip_sso(opt_info *o) -{ - return(o->v[5].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - o->v[6].p_pi_f(o->sc, slot_value(o->v[3].p), integer(slot_value(o->v[4].p))))); -} - -static s7_pointer opt_p_pip_ssf1(opt_info *o) -{ - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o->v[6].fp(o->v[5].o1)))); -} - -static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start) -{ - opt_info *o1; - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fp == opt_p_pi_ss) || (o1->v[0].fp == opt_p_pi_ss_sref) || (o1->v[0].fp == opt_p_pi_ss_vref) || - (o1->v[0].fp == opt_p_pi_ss_sref_direct) || (o1->v[0].fp == opt_p_pi_ss_vref_direct) || - (o1->v[0].fp == opt_p_pi_ss_fvref_direct) || (o1->v[0].fp == opt_p_pi_ss_ivref_direct) || - (o1->v[0].fp == opt_p_pi_ss_lref)) - { - opc->v[5].p_pip_f = opc->v[3].p_pip_f; - opc->v[6].p_pi_f = o1->v[3].p_pi_f; - opc->v[3].p = o1->v[1].p; - opc->v[4].p = o1->v[2].p; - opc->v[0].fp = opt_p_pip_sso; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fp == opt_p_p_c) - { - opc->v[5].p_p_f = o1->v[2].p_p_f; - opc->v[4].p = o1->v[1].p; - backup_pc(sc); - opc->v[0].fp = opt_p_pip_c; - return_true(sc, NULL); - }} - o1 = sc->opts[start]; - if (o1->v[0].fp != opt_p_p_f) - return_false(sc, NULL); - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[5].o1 = sc->opts[start + 1]; - opc->v[6].fp = sc->opts[start + 1]->v[0].fp; - opc->v[0].fp = opt_p_pip_ssf1; - return_true(sc, NULL); -} - -static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer obj, slot1, sig, checker = NULL; - s7_p_pip_t func = s7_p_pip_function(s_func); - if (!func) - return_false(sc, car_x); - - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_pair(cdr(sig))) && - (is_symbol(cadr(sig)))) - checker = cadr(sig); - - /* here we know cadr is a symbol */ - slot1 = lookup_slot_from(cadr(car_x), sc->curlet); - if ((!is_slot(slot1)) || - (has_methods(slot_value(slot1))) || - (is_immutable(slot_value(slot1)))) - return_false(sc, car_x); - if ((is_any_vector(slot_value(slot1))) && - (vector_rank(slot_value(slot1)) > 1)) - return_false(sc, car_x); - - opc->v[1].p = slot1; - obj = slot_value(opc->v[1].p); - opc->v[3].p_pip_f = func; - if ((s7_p_pip_unchecked_function(s_func)) && - (checker)) - { - if ((is_normal_vector(obj)) && (checker == sc->is_vector_symbol)) - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; - else - if ((is_pair(obj)) && (checker == sc->is_pair_symbol)) /* avoid dumb mismatch in val_type and sig below, #t integer:any? and integer? integer:any? */ - opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); - else - { - s7_pointer val_type = opt_arg_type(sc, cdddr(car_x)); - if ((val_type == cadddr(sig)) && - (((is_string(obj)) && (checker == sc->is_string_symbol)) || - ((is_float_vector(obj)) && (checker == sc->is_float_vector_symbol)) || - ((is_int_vector(obj)) && (checker == sc->is_int_vector_symbol)) || - ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol)))) - opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); - }} - if (is_symbol(caddr(car_x))) - { - int32_t start = sc->pc; - s7_pointer slot2 = opt_integer_symbol(sc, caddr(car_x)); - if (slot2) - { - opc->v[2].p = slot2; - if (is_step_end(slot2)) - switch (type(obj)) - { - case T_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_normal_vector_set_p_pip_direct : normal_vector_set_p_pip_direct; - break; - case T_INT_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = int_vector_set_p_pip_direct; - break; - case T_FLOAT_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = float_vector_set_p_pip_direct; - break; - case T_STRING: - if (do_loop_end(slot_value(slot2)) <= string_length(obj)) - opc->v[3].p_pip_f = string_set_p_pip_direct; - break; - case T_BYTE_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; - break; - } /* T_PAIR here would require list_length check which sort of defeats the purpose */ - - if (is_symbol(cadddr(car_x))) - { - s7_pointer val_slot = opt_simple_symbol(sc, cadddr(car_x)); - if (val_slot) - { - opc->v[4].p_pip_f = opc->v[3].p_pip_f; - opc->v[3].p = val_slot; - opc->v[0].fp = (opc->v[4].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset : opt_p_pip_sss; - return_true(sc, car_x); - }} - else - if ((!is_pair(cadddr(car_x))) || - (is_proper_quote(sc, cadddr(car_x)))) - { - opc->v[4].p = (is_pair(cadddr(car_x))) ? cadr(cadddr(car_x)) : cadddr(car_x); - opc->v[0].fp = opt_p_pip_ssc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdddr(car_x))) - { - if (p_pip_ssf_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fp = (opc->v[3].p_pip_f == string_set_p_pip_direct) ? opt_p_pip_ssf_sset : - ((opc->v[3].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_ssf_vset : opt_p_pip_ssf); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - }}} - else /* not symbol caddr */ - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = (opc->v[3].p_pip_f == list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : opt_p_pip_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- p_piip -------- */ -static s7_pointer opt_p_piip_sssf(opt_info *o) -{ - return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fp(o->v[10].o1))); -} - -static s7_pointer vector_set_piip_sssf_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - s7_pointer val = o->v[11].fp(o->v[10].o1); - vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val; - return(val); -} - -static s7_pointer opt_p_piip_sssc(opt_info *o) -{ - return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].p)); -} - -static s7_pointer opt_p_piip_sfff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */ -} - -static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp, s7_pointer obj) -{ - s7_pointer slot = opt_integer_symbol(sc, car(indexp2)); - if (!slot) - return_false(sc, indexp1); - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if ((is_symbol(car(valp))) || - (is_unquoted_pair(car(valp)))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, valp)) - return_false(sc, indexp1); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fp = opt_p_piip_sssf; - if ((is_normal_vector(obj)) && - (step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fp = vector_set_piip_sssf_unchecked; - return_true(sc, NULL); - } - opc->v[0].fp = opt_p_piip_sssc; - opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp); - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[3].fp = opc->v[4].o1->v[0].fp; - opc->v[0].fp = opt_p_piip_sfff; - return_true(sc, NULL); - }}} - return_false(sc, NULL); -} - -static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_piip_t func = s7_p_piip_function(s_func); - if ((func) && (s_func == global_value(sc->vector_set_symbol)) && (is_symbol(cadr(car_x)))) - { - s7_pointer obj; - s7_pointer slot1 = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(slot1)) - return_false(sc, car_x); - obj = slot_value(slot1); - if ((has_methods(obj)) || (is_immutable(obj))) - return_false(sc, car_x); - if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */ - (vector_rank(obj) == 2)) - { - opc->v[1].p = slot1; - opc->v[5].p_piip_f = vector_set_p_piip; - return(p_piip_to_sx(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x), obj)); - }} - return_false(sc, car_x); -} - -/* -------- p_pii -------- */ -static s7_pointer opt_p_pii_sss(opt_info *o) -{ - return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)))); -} - -static s7_pointer opt_p_pii_sff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); -} - -static s7_pointer vector_ref_pii_sss_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - return(vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); -} - -static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_pii_t func = s7_p_pii_function(s_func); - if ((func) && - (is_symbol(cadr(car_x)))) - { - s7_pointer obj; - s7_pointer slot1 = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(slot1)) - return_false(sc, car_x); - obj = slot_value(slot1); - if ((has_methods(obj)) || (is_immutable(obj))) - return_false(sc, car_x); - if ((is_normal_vector(obj)) && - (vector_rank(obj) == 2)) - { - s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x); - opc->v[1].p = slot1; - opc->v[4].p_pii_f = vector_ref_p_pii; - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - opc->v[0].fp = opt_p_pii_sss; - /* normal vector rank 2 (see above) */ - if ((step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fp = vector_ref_pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[0].fp = opt_p_pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- p_ppi -------- */ -static s7_pointer opt_p_ppi_psf(opt_info *o) {return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_ppi_psf_cpos(opt_info *o) {return(char_position_p_ppi(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} - -static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_p_ppi_t ifunc = s7_p_ppi_function(s_func); - if (!ifunc) - return_false(sc, car_x); - opc->v[3].p_ppi_f = ifunc; - if ((is_character(cadr(car_x))) && - (is_symbol(caddr(car_x))) && - (int_optimize(sc, cdddr(car_x)))) - { - s7_pointer slot = opt_simple_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = cadr(car_x); - opc->v[1].p = slot; - opc->v[0].fp = (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- p_ppp -------- */ -static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_ppp_hash_table_increment(opt_info *o) {return(fx_hash_table_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));} -static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_scs_eset(opt_info *o) {return(let_set_1(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_sss(opt_info *o) {return(o->v[4].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} -static s7_pointer opt_p_ppp_sss_mul(opt_info *o) {return(multiply_p_ppp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} -static s7_pointer opt_p_ppp_sss_hset(opt_info *o) {return(s7_hash_table_set(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} -static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[4].p));} -static s7_pointer opt_list_3c(opt_info *o) {s7_scheme *sc = o->sc; return(list_3(sc, o->v[10].p, o->v[8].p, o->v[4].p));} - -static s7_pointer opt_p_ppp_sff(opt_info *o) -{ - s7_pointer res; - s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); - res = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), stack_protected1(sc), stack_protected2(sc)); - unstack(sc); - return(res); -} - -static s7_pointer opt_p_ppp_fff(opt_info *o) -{ - s7_pointer res; - s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); - res = o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc), o->v[5].fp(o->v[4].o1)); - unstack(sc); - return(res); -} - -static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer arg1 = cadr(car_x); - s7_pointer arg2 = caddr(car_x); - s7_pointer arg3 = cadddr(car_x); - int32_t start = sc->pc; - s7_p_ppp_t func = s7_p_ppp_function(s_func); - if (!func) - return_false(sc, car_x); - opc->v[3].p_ppp_f = func; - if (is_symbol(arg1)) /* dealt with at the top -> p1 */ - { - s7_pointer obj; - opt_info *o1; - s7_pointer slot = lookup_slot_from(arg1, sc->curlet); - if ((!is_slot(slot)) || - (has_methods(slot_value(slot)))) - return_false(sc, car_x); - - obj = slot_value(slot); - if ((is_any_vector(obj)) && - (vector_rank(obj) > 1)) - return_false(sc, car_x); - - if (is_target_or_its_alias(car(car_x), s_func, sc->hash_table_set_symbol)) - { - if ((!is_hash_table(obj)) || (is_immutable(obj))) - return_false(sc, car_x); - } - else - if ((is_target_or_its_alias(car(car_x), s_func, sc->let_set_symbol)) && - ((!is_let(obj)) || (is_immutable(obj)))) - return_false(sc, car_x); - - opc->v[1].p = slot; - - if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) - opc->v[3].p_ppp_f = s7_hash_table_set; - - if (is_symbol(arg2)) - { - slot = opt_simple_symbol(sc, arg2); - if (slot) - { - opc->v[2].p = slot; - if (is_symbol(arg3)) - { - slot = opt_simple_symbol(sc, arg3); - if (slot) - { - s7_p_ppp_t func1 = opc->v[3].p_ppp_f; - opc->v[4].p_ppp_f = func1; - opc->v[3].p = slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); - return_true(sc, car_x); - }} - else - if ((!is_pair(arg3)) || - (is_proper_quote(sc, arg3))) - { - opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; - opc->v[0].fp = opt_p_ppp_ssc; - return_true(sc, car_x); - } - if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) - { - opc->v[0].fp = opt_p_ppp_hash_table_increment; - opc->v[5].p = car_x; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - opc->v[0].fp = opt_p_ppp_ssf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - if ((is_proper_quote(sc, arg2)) && - (is_symbol(arg3))) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[4].p = cadr(arg2); - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_scs; - if (opc->v[3].p_ppp_f == let_set) - { - if (is_symbol(cadr(arg2))) /* checked is_let, has_methods and is_immutable above */ - opc->v[0].fp = opt_p_ppp_scs_eset; - else return_false(sc, car_x); - } - return_true(sc, car_x); - }} - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (is_symbol(arg3)) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */ - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }} - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_sff; - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fp = o2->v[0].fp; - return_true(sc, car_x); - }}} - else - { - opc->v[10].o1 = sc->opts[start]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_fff; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - if ((opc->v[3].p_ppp_f == list_p_ppp) && - (opc->v[5].fp == opt_p_c) && (opc->v[9].fp == opt_p_c) && (opc->v[11].fp == opt_p_c)) - { - opc->v[0].fp = opt_list_3c; - opc->v[4].p = opc->v[4].o1->v[1].p; - opc->v[8].p = opc->v[8].o1->v[1].p; - opc->v[10].p = opc->v[10].o1->v[1].p; - } - return_true(sc, car_x); - }}}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- p_call_ppp -------- */ -static s7_pointer opt_p_call_sss(opt_info *o) -{ - return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)))); -} - -static s7_pointer opt_p_call_css(opt_info *o) -{ - return(o->v[4].call(o->sc, set_plist_3(o->sc, o->v[1].p, slot_value(o->v[2].p), slot_value(o->v[3].p)))); -} - -static s7_pointer opt_p_call_ssf(opt_info *o) -{ - return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[6].fp(o->v[5].o1)))); -} - -static s7_pointer opt_p_call_ppp(opt_info *o) -{ - s7_pointer res; - s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, o->v[4].fp(o->v[3].o1), o->v[6].fp(o->v[5].o1)); - res = o->v[11].fp(o->v[10].o1); /* not combinable into next */ - res = o->v[2].call(sc, set_plist_3(sc, stack_protected1(sc), stack_protected2(sc), res)); - unstack(sc); - return(res); -} - -static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 3)) && - (s_func != global_value(sc->hash_table_ref_symbol)) && (s_func != global_value(sc->list_ref_symbol))) - { - s7_pointer slot, arg = cadr(car_x); - opt_info *o1 = sc->opts[sc->pc]; - - if (!is_pair(arg)) - { - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[1].p = slot; - if ((s_func == global_value(sc->vector_ref_symbol)) && - (is_normal_vector(slot_value(slot))) && (vector_rank(slot_value(slot)) != 2)) - return_false(sc, car_x); - } - else return_false(sc, car_x); /* no need for pc_fallback here, I think */ - } - else - { - opc->v[1].p = arg; - if (s_func == global_value(sc->vector_ref_symbol)) - return_false(sc, car_x); - } - arg = caddr(car_x); - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[2].p = slot; - arg = cadddr(car_x); - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[3].p = slot; - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = (is_slot(opc->v[1].p)) ? opt_p_call_sss : opt_p_call_css; - return_true(sc, car_x); - }} - else - if (is_slot(opc->v[1].p)) - { - int32_t start1 = sc->pc; - if ((cf_call(sc, car_x, s_func, 3) == g_substring_uncopied) && /* opc->v[4].call is unsafe -- might not be set */ - (is_t_integer(slot_value(opc->v[2].p))) && - (is_string(slot_value(opc->v[1].p))) && - (int_optimize(sc, cdddr(car_x)))) - { - opc->v[0].fp = opt_p_substring_uncopied_ssf; - opc->v[5].o1 = o1; - opc->v[6].fi = o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start1); - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ssf; - opc->v[5].o1 = o1; - opc->v[6].fp = o1->v[0].fp; - return_true(sc, car_x); - }}}}} - if (s_func == global_value(sc->vector_ref_symbol)) - return_false(sc, car_x); - if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o3 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[2].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ppp; - opc->v[3].o1 = o1; - opc->v[4].fp = o1->v[0].fp; - opc->v[5].o1 = o2; - opc->v[6].fp = o2->v[0].fp; - opc->v[10].o1 = o3; - opc->v[11].fp = o3->v[0].fp; - return_true(sc, car_x); - }}}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - - -/* -------- p_call_any -------- */ -#define P_CALL_O1 3 - -static s7_pointer opt_p_call_any(opt_info *o) -{ - s7_scheme *sc = o->sc; - s7_pointer val = safe_list_if_possible(sc, o->v[1].i); - s7_pointer arg = val; - if (in_heap(val)) gc_protect_via_stack(sc, val); - for (s7_int i = 0; i < o->v[1].i; i++, arg = cdr(arg)) - { - opt_info *o1 = o->v[i + P_CALL_O1].o1; - set_car(arg, o1->v[0].fp(o1)); - } - arg = o->v[2].call(sc, val); - if (in_heap(val)) unstack(sc); - else clear_list_in_use(val); - return(arg); -} - -static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len) -{ - if ((len < (NUM_VUNIONS - P_CALL_O1)) && - (is_safe_procedure(s_func)) && - (c_function_is_aritable(s_func, len - 1))) - { - s7_pointer p = cdr(car_x); /* (vector-set! v k i 2) gets here */ - opc->v[1].i = (len - 1); - for (int32_t pctr = P_CALL_O1; is_pair(p); pctr++, p = cdr(p)) - { - opc->v[pctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(p)) - { - opc->v[0].fp = opt_p_call_any; - opc->v[2].call = cf_call(sc, car_x, s_func, len - 1); - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - - -/* -------- p_fx_any -------- */ - -static s7_pointer opt_p_fx_any(opt_info *o) {return(o->v[1].call(o->sc, o->v[2].p));} - -static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer x) -{ - s7_function f = (has_fx(x)) ? fx_proc(x) : fx_choose(sc, x, sc->curlet, let_symbol_is_safe); - if (!f) - return_false(sc, x); - opc->v[0].fp = opt_p_fx_any; - opc->v[1].call = f; - opc->v[2].p = car(x); - return_true(sc, x); -} - - -/* -------- p_implicit -------- */ - -static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) -{ - s7_pointer obj = slot_value(s_slot); - opt_info *opc; - int32_t start; - - if ((!is_sequence(obj)) || (len < 2)) - return_false(sc, car_x); - - opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - start = sc->pc; - if (len == 2) - { - switch (type(obj)) - { - case T_PAIR: opc->v[3].p_pi_f = list_ref_p_pi_unchecked; break; - case T_HASH_TABLE: opc->v[3].p_pp_f = s7_hash_table_ref; break; - case T_LET: opc->v[3].p_pp_f = let_ref; break; - case T_STRING: opc->v[3].p_pi_f = string_ref_p_pi_unchecked; break; - case T_C_OBJECT: return_false(sc, car_x); /* no pi_ref because ref assumes pp */ - - case T_VECTOR: - if (vector_rank(obj) != 1) - return_false(sc, car_x); - opc->v[3].p_pi_f = normal_vector_ref_p_pi_unchecked; - break; - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - if (vector_rank(obj) != 1) - return_false(sc, car_x); - opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; - break; - - default: - return_false(sc, car_x); - } - /* now v3.p_pi|pp.f is set */ - if (is_symbol(cadr(car_x))) - { - s7_pointer slot = lookup_slot_from(cadr(car_x), sc->curlet); - if (is_slot(slot)) - { - opc->v[2].p = slot; - if ((!is_hash_table(obj)) && /* these because opt_int below */ - (!is_let(obj))) - { - if (!is_t_integer(slot_value(slot))) - return_false(sc, car_x); /* I think this reflects that a non-int index is an error for list-ref et al */ - opc->v[0].fp = opt_p_pi_ss; - if (is_step_end(opc->v[2].p)) - check_unchecked(sc, obj, opc->v[2].p, opc, NULL); - fixup_p_pi_ss(opc); - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_pp_ss; - return_true(sc, car_x); - }} - else - { - if ((!is_hash_table(obj)) && - (!is_let(obj))) - { - opt_info *o1; - if (is_t_integer(cadr(car_x))) - { - opc->v[2].i = integer(cadr(car_x)); - opc->v[0].fp = opt_p_pi_sc; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[0].fp = opt_p_pi_sf; - opc->v[4].o1 = o1; - opc->v[5].fi = o1->v[0].fi; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fp = opt_p_pp_sf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - }}} /* len==2 */ - else - { /* len > 2 */ - if ((is_normal_vector(obj)) && (len == 3) && (vector_rank(obj) == 2)) - { - s7_pointer slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - opc->v[4].p_pii_f = vector_ref_p_pii; - opc->v[0].fp = opt_p_pii_sss; - if ((step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fp = vector_ref_pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - /* opc->v[1].p set above */ - opc->v[4].p_pii_f = vector_ref_p_pii_direct; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - } - - #define P_IMPLICIT_CALL_O1 4 - if (len < (NUM_VUNIONS - P_IMPLICIT_CALL_O1)) /* mimic p_call_any_ok */ - { - s7_pointer p = car_x; - opc->v[1].i = len; - for (int32_t pctr = (P_IMPLICIT_CALL_O1 - 1); is_pair(p); pctr++, p = cdr(p)) - { - opc->v[pctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(p)) - { - /* here we know the vector rank/type, probably can handle the new value type, and maybe indices/dimensions, - * so at least forgo the vec type/rank + immutable checks, the *_set cases are from p_call_any_ok called in cell_optimize, - * but this is called very rarely mainly because hi-rank implicit refs are rare, and check_type_uncertainty is unhappy - * if there are multiple sets of a var. - * hash-tables, lets, lists, and vectors with extra (implicit) args can't be handled because we have no way to tell - * what the implicit call will do, and in the opt_* context, everything must be "safe" (i.e. no defines or - * hidden multiple-values, etc). - */ - if ((!is_any_vector(obj)) || (vector_rank(obj) != (len - 1))) return_false(sc, car_x); - opc->v[0].fp = opt_p_call_any; - switch (type(obj)) /* string can't happen here (no multidimensional strings), for pair/hash/let see above */ - { - case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break; - case T_BYTE_VECTOR: opc->v[2].call = g_byte_vector_ref; break; - case T_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break; - case T_VECTOR: opc->v[2].call = g_vector_ref; break; - default: return_false(sc, car_x); - } - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- cell_quote -------- */ -static bool opt_cell_quote(s7_scheme *sc, s7_pointer car_x) -{ - opt_info *opc; - if (!is_null(cddr(car_x))) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[1].p = cadr(car_x); - opc->v[0].fp = opt_p_c; - return_true(sc, car_x); -} - -/* -------- cell_set -------- */ -static s7_pointer opt_set_p_p_f(opt_info *o) -{ - s7_pointer x = o->v[4].fp(o->v[3].o1); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_p_f_with_setter(opt_info *o) -{ - s7_pointer x = o->v[4].fp(o->v[3].o1); - call_c_function_setter(o->sc, slot_setter(o->v[1].p), slot_symbol(o->v[1].p), x); - slot_set_value(o->v[1].p, x); /* symbol_increment?? */ - return(x); -} - -static s7_pointer opt_set_p_i_s(opt_info *o) -{ - s7_pointer val = slot_value(o->v[2].p); - if (is_mutable_integer(val)) - val = make_integer(o->sc, integer(val)); - slot_set_value(o->v[1].p, val); - return(val); -} - -static s7_pointer opt_set_p_i_f(opt_info *o) -{ - s7_pointer x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_d_s(opt_info *o) -{ - s7_pointer val = slot_value(o->v[2].p); - if (is_mutable_number(val)) - val = make_real(o->sc, real(val)); - slot_set_value(o->v[1].p, val); - return(val); -} - -static s7_pointer opt_set_p_d_f(opt_info *o) -{ - s7_pointer x = make_real(o->sc, o->v[5].fd(o->v[4].o1)); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_d_f_sf_add(opt_info *o) -{ - s7_pointer x = make_real(o->sc, opt_d_dd_sf_add(o->v[4].o1)); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_d_f_mm_add(opt_info *o) -{ - s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p)); - s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[10].p), integer(slot_value(o->v[11].p))) * real(slot_value(o->v[9].p)); - slot_set_value(o->v[1].p, make_real(o->sc, x1 + x2)); - return(slot_value(o->v[1].p)); -} - -static s7_pointer opt_set_p_d_f_mm_subtract(opt_info *o) -{ - s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p)); - s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[10].p), integer(slot_value(o->v[11].p))) * real(slot_value(o->v[9].p)); - slot_set_value(o->v[1].p, make_real(o->sc, x1 - x2)); - return(slot_value(o->v[1].p)); -} - -static s7_pointer opt_set_p_c(opt_info *o) -{ - slot_set_value(o->v[1].p, o->v[2].p); - return(o->v[2].p); -} - -static s7_pointer opt_set_p_i_fo(opt_info *o) -{ - s7_int i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))); - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_i_fo_add(opt_info *o) -{ - s7_int i = integer(slot_value(o->v[2].p)) + integer(slot_value(o->v[3].p)); - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_i_fo1(opt_info *o) -{ - s7_int i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), o->v[3].i); - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_i_fo1_add(opt_info *o) -{ - s7_int i = integer(slot_value(o->v[2].p)) + o->v[3].i; - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fi == opt_i_ii_ss) || - (o1->v[0].fi == opt_i_ii_ss_add)) - { - opc->v[4].i_ii_f = o1->v[3].i_ii_f; - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[0].fp = (o1->v[0].fi == opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fi == opt_i_ii_sc) || (o1->v[0].fi == opt_i_ii_sc_add) || (o1->v[0].fi == opt_i_ii_sc_sub)) - { - opc->v[4].i_ii_f = o1->v[3].i_ii_f; - opc->v[2].p = o1->v[1].p; - opc->v[3].i = o1->v[2].i; - opc->v[0].fp = (o1->v[0].fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool set_p_d_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 3) && - (opc == sc->opts[sc->pc - 4])) - { - opt_info *o1 = sc->opts[sc->pc - 3]; - if ((o1->v[0].fd == opt_d_mm_fff) && - ((o1->v[3].d_dd_f == add_d_dd) || (o1->v[3].d_dd_f == subtract_d_dd))) - { - opc->v[0].fp = (o1->v[3].d_dd_f == add_d_dd) ? opt_set_p_d_f_mm_add : opt_set_p_d_f_mm_subtract; - o1 = sc->opts[sc->pc - 2]; - opc->v[3].p = o1->v[1].p; - opc->v[4].p = o1->v[2].p; - opc->v[5].p = o1->v[3].p; - o1 = sc->opts[sc->pc - 1]; - opc->v[9].p = o1->v[1].p; - opc->v[10].p = o1->v[2].p; - opc->v[11].p = o1->v[3].p; - sc->pc -= 3; - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool is_some_number(s7_scheme *sc, const s7_pointer tp) -{ - return((tp == sc->is_integer_symbol) || - (tp == sc->is_float_symbol) || - (tp == sc->is_real_symbol) || - (tp == sc->is_complex_symbol) || - (tp == sc->is_number_symbol) || - (tp == sc->is_byte_symbol) || - (tp == sc->is_rational_symbol)); -} - -static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc) -{ - s7_pointer code = sc->code; - /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) car_x) where car_x is the do body, but it can also be for-each etc */ - - /* maybe the type uncertainty is not a problem */ - if ((is_pair(code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */ - (is_pair(car(code))) && - (is_pair(cdr(code))) && /* weird that code sometimes has nothing to do with car_x -- tree_memq below for reality check */ - (is_pair(cadr(code)))) - { - s7_int counts; - if ((!has_low_count(code)) && /* only set below */ - (s7_tree_memq(sc, car_x, code))) - { - if (is_pair(caar(code))) - { - counts = tree_count(sc, target, car(code), 0) + - tree_count(sc, target, caadr(code), 0) + - tree_count(sc, target, cddr(code), 0); - for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_proper_list_2(sc, var)) && - (car(var) == target)) - counts--; - }} - else counts = tree_count(sc, target, code, 0); - } - else counts = 2; - /* can be from lambda: (lambda (n)...): ((n) (set! sum (+ sum n))) etc */ - if (counts <= 2) - { - set_has_low_count(code); - pc_fallback(sc, start_pc); - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_set_p_p_f; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_syntax) */ -{ - opt_info *opc = alloc_opt_info(sc); - s7_pointer target = cadr(car_x); - if (is_symbol(target)) - { - s7_pointer settee; - if ((is_constant_symbol(sc, target)) || - ((is_slot(global_slot(target))) && (slot_has_setter(global_slot(target))))) - return_false(sc, car_x); - - settee = lookup_slot_from(target, sc->curlet); - if ((is_slot(settee)) && - (!is_immutable(settee)) && - (!is_syntax(slot_value(settee)))) - { - int32_t start_pc = sc->pc; - s7_pointer stype = s7_type_of(sc, slot_value(settee)); - s7_pointer atype; - opc->v[1].p = settee; - if (slot_has_setter(settee)) - { - if ((is_c_function(slot_setter(settee))) && - (is_bool_function(slot_setter(settee))) && - (stype == opt_arg_type(sc, cddr(car_x))) && - (cell_optimize(sc, cddr(car_x)))) - { - opc->v[1].p = settee; - opc->v[0].fp = opt_set_p_p_f_with_setter; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - - if (stype == sc->is_integer_symbol) - { - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_integer_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_set_p_i_s; - return_true(sc, car_x); - }} - else - { - opc->v[5].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cddr(car_x))) - return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); - if (!set_p_i_f_combinable(sc, opc)) - { - opc->v[0].fp = opt_set_p_i_f; - opc->v[6].fi = opc->v[5].o1->v[0].fi; - } - return_true(sc, car_x); - }} - if (stype == sc->is_float_symbol) - { - if (is_t_real(caddr(car_x))) - { - opc->v[2].p = caddr(car_x); - opc->v[0].fp = opt_set_p_c; - return_true(sc, car_x); - } - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_float_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_set_p_d_s; - return_true(sc, car_x); - }} - else - { - if ((is_pair(caddr(car_x))) && - (float_optimize(sc, cddr(car_x)))) - { - if (!set_p_d_f_combinable(sc, opc)) - { - opc->v[4].o1 = sc->opts[start_pc]; - opc->v[5].fd = sc->opts[start_pc]->v[0].fd; - opc->v[0].fp = (opc->v[5].fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; - } - return_true(sc, car_x); - } - return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); - }} - - atype = opt_arg_type(sc, cddr(car_x)); - if ((is_some_number(sc, atype)) && - (!is_some_number(sc, stype))) - return_false(sc, car_x); - if (cell_optimize(sc, cddr(car_x))) - { - if ((stype != atype) && - (is_symbol(stype)) && - (((t_sequence_p[symbol_type(stype)]) && - (stype != sc->is_null_symbol) && - (stype != sc->is_pair_symbol)) || /* compatible with is_proper_list! */ - (stype == sc->is_iterator_symbol))) - return_false(sc, car_x); - opc->v[0].fp = opt_set_p_p_f; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if ((is_pair(target)) && - (is_symbol(car(target))) && - (is_pair(cdr(target))) && - ((is_null(cddr(target))) || (is_null(cdddr(target))) || (is_null(cddddr(target))))) - { - s7_pointer obj, index, s_slot = lookup_slot_from(car(target), sc->curlet); - if (!is_slot(s_slot)) - return_false(sc, car_x); - - obj = slot_value(s_slot); - opc->v[1].p = s_slot; - if (!is_mutable_sequence(obj)) - return_false(sc, car_x); - - index = cadr(target); - switch (type(obj)) - { - case T_STRING: - { - s7_pointer val_type; - if (is_pair(cddr(target))) return_false(sc, car_x); - val_type = opt_arg_type(sc, cddr(car_x)); - if (val_type != sc->is_char_symbol) - return_false(sc, car_x); - opc->v[3].p_pip_f = string_set_p_pip_unchecked; - } - break; - - case T_VECTOR: - /* is_t_integer below to handle the index */ - if (is_null(cddr(target))) - { - if (vector_rank(obj) != 1) return_false(sc, car_x); - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; - } - else - { - if (vector_rank(obj) != 2) - return_false(sc, car_x); - opc->v[5].p_piip_f = (is_typed_vector(obj)) ? typed_vector_set_p_piip_direct : vector_set_p_piip_direct; - return(p_piip_to_sx(sc, opc, cdr(target), cddr(target), cddr(car_x), obj)); - } - break; - - case T_FLOAT_VECTOR: - if (opt_float_vector_set(sc, opc, car(target), cdr(target), - (is_null(cddr(target))) ? NULL : cddr(target), - ((!is_pair(cddr(target))) || (is_null(cdddr(target)))) ? NULL : cdddr(target), - cddr(car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - } - return_false(sc, car_x); - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - if (opt_int_vector_set(sc, -1, opc, car(target), cdr(target), (is_null(cddr(target))) ? NULL : cddr(target), cddr(car_x))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return_true(sc, car_x); - } - return_false(sc, car_x); - - case T_C_OBJECT: - if ((is_null(cddr(target))) && - (is_c_function(c_object_setf(sc, obj)))) - { - /* d_7pid_ok assumes cadr is the target, not car etc */ - s7_d_7pid_t func = s7_d_7pid_function(c_object_setf(sc, obj)); - if (func) - { - s7_pointer slot = opt_integer_symbol(sc, cadr(target)); - opc->v[4].d_7pid_f = func; - opc->v[10].o1 = sc->opts[sc->pc]; - if (slot) - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[O_WRAP].fd = opt_d_7pid_ssf; - opc->v[0].fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ - opc->v[2].p = slot; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - }} - else - if (int_optimize(sc, cdr(target))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[O_WRAP].fd = opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); - - case T_PAIR: - if (is_pair(cddr(target))) return_false(sc, car_x); - opc->v[3].p_pip_f = list_set_p_pip_unchecked; - - /* an experiment -- is this ever hit in normal code? */ - { - s7_pointer val = caddr(car_x); - if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_t_integer(caddr(val))) && (is_null(cdddr(val))) && (is_symbol(cadr(target))) && - (car(target) == (caadr(val))) && (is_pair(cdadr(val))) && (is_null(cddadr(val))) && (cadr(target) == cadadr(val))) - { - s7_pointer slot = opt_simple_symbol(sc, index); - if ((slot) && (is_t_integer(slot_value(slot)))) - { - opc->v[2].p = slot; - opc->v[3].p = caddr(val); - opc->v[0].fp = list_increment_p_pip_unchecked; - return_true(sc, car_x); - }}} - break; - - case T_HASH_TABLE: - if (is_pair(cddr(target))) return_false(sc, car_x); - opc->v[3].p_ppp_f = s7_hash_table_set; - break; - - case T_LET: - /* here we know the let is a covered mutable let -- ?? not true if s7-optimize called explicitly */ - if ((is_pair(cddr(target))) || (is_openlet(obj))) - return_false(sc, car_x); - if ((is_symbol_and_keyword(cadr(target))) || - ((is_quoted_symbol(cadr(target))))) - opc->v[3].p_ppp_f = let_set_1; - else opc->v[3].p_ppp_f = let_set_p_ppp_2; - break; - - default: - return_false(sc, car_x); - } - if (is_symbol(index)) - { - int32_t start = sc->pc; - s7_pointer slot = opt_simple_symbol(sc, index); - if (slot) - { - opc->v[2].p = slot; - if ((is_t_integer(slot_value(slot))) && - (is_step_end(opc->v[2].p))) - { - if (is_string(obj)) - { - if (do_loop_end(slot_value(opc->v[2].p)) <= string_length(obj)) - opc->v[3].p_pip_f = string_set_p_pip_direct; - } - else - if (is_byte_vector(obj)) - { - if (do_loop_end(slot_value(opc->v[2].p)) <= byte_vector_length(obj)) - opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; - } - else - if (is_any_vector(obj)) /* true for all 3 vectors */ - { - if ((is_any_vector(obj)) && - (do_loop_end(slot_value(opc->v[2].p)) <= vector_length(obj))) - { - if ((is_normal_vector(obj)) && (is_typed_vector(obj))) - opc->v[3].p_pip_f = typed_normal_vector_set_p_pip_direct; - else opc->v[3].p_pip_f = normal_vector_set_p_pip_direct; - }}} - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) - { - s7_p_ppp_t func1; - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - opc->v[4].p_pip_f = opc->v[3].p_pip_f; - opc->v[3].p = val_slot; - opc->v[0].fp = opt_p_pip_sss; - return_true(sc, car_x); - } - func1 = opc->v[3].p_ppp_f; - opc->v[4].p_ppp_f = func1; - opc->v[3].p = val_slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); - return_true(sc, car_x); - }} - else - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) - { - if (!is_pair(caddr(car_x))) - opc->v[4].p = caddr(car_x); - else opc->v[4].p = cadaddr(car_x); - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - opc->v[0].fp = opt_p_pip_ssc; - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_ppp_ssc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - if (p_pip_ssf_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fp = opt_p_pip_ssf; - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_ppp_ssf; - return_true(sc, car_x); - }}} - else /* index not a symbol */ - { - opt_info *o1; - if ((is_string(obj)) || - (is_pair(obj)) || - (is_any_vector(obj))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(target))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_pip_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if ((is_proper_quote(sc, cadr(target))) && - (is_symbol(caddr(car_x)))) - { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[4].p = cadadr(target); - opc->v[2].p = val_slot; - opc->v[0].fp = (opc->v[3].p_ppp_f == let_set_1) ? opt_p_ppp_scs_eset : opt_p_ppp_scs; - return_true(sc, car_x); - }} - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(target))) - { - opt_info *o2; - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }} - o2 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_sff; - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fp = o2->v[0].fp; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - - -/* -------- cell_begin -------- */ -static s7_pointer opt_begin_p(opt_info *o) -{ - opt_info *o1; - s7_int i, len = o->v[1].i; /* len = 1 if 2 exprs, etc */ - for (i = 0; i < len; i++) - { - o1 = o->v[i + 2].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + 2].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_begin_p_1(opt_info *o) -{ - o->v[3].fp(o->v[2].o1); - return(o->v[5].fp(o->v[4].o1)); -} - -static void oo_idp_nr_fixup(opt_info *start) -{ - if (start->v[0].fp == d_to_p) - { - start->v[0].fp = d_to_p_nr; - if (start->v[O_WRAP].fd == opt_d_7pid_ssf) - start->v[0].fp = opt_d_7pid_ssf_nr; - else - if (start->v[O_WRAP].fd == opt_d_7pid_ssfo_fv) - { - start->v[0].fp = opt_d_7pid_ssfo_fv_nr; - if (start->v[6].d_dd_f == add_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr; - else - if (start->v[6].d_dd_f == subtract_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; - }} - else - if (start->v[0].fp == i_to_p) - start->v[0].fp = i_to_p_nr; -} - -static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - int32_t i; - opt_info *opc; - s7_pointer p; - if (len > (NUM_VUNIONS - 3)) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - if (is_pair(cdr(p))) - oo_idp_nr_fixup(start); - opc->v[i].o1 = start; - } - opc->v[1].i = len - 2; - if (len == 3) - { - opc->v[0].fp = opt_begin_p_1; - opc->v[4].o1 = opc->v[3].o1; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - opc->v[3].fp = opc->v[2].o1->v[0].fp; - } - else opc->v[0].fp = opt_begin_p; - return_true(sc, car_x); -} - -/* -------- cell_when|unless -------- */ -static s7_pointer opt_when_p_2(opt_info *o) -{ - if (o->v[4].fb(o->v[3].o1)) - { - o->v[6].fp(o->v[5].o1); - return(o->v[8].fp(o->v[7].o1)); - } - return(o->sc->unspecified); -} - -static s7_pointer opt_when_p(opt_info *o) -{ - if (o->v[4].fb(o->v[3].o1)) - { - s7_int i, len = o->v[1].i - 1; - opt_info *o1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + 5].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + 5].o1; - return(o1->v[0].fp(o1)); - } - return(o->sc->unspecified); -} - -static s7_pointer opt_when_p_1(opt_info *o) -{ - opt_info *o1; - if (!o->v[4].fb(o->v[3].o1)) - return(o->sc->unspecified); - o1 = o->v[5].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_unless_p(opt_info *o) -{ - opt_info *o1; - s7_int i, len; - if (o->v[4].fb(o->v[3].o1)) - return(o->sc->unspecified); - len = o->v[1].i - 1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + 5].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + 5].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_unless_p_1(opt_info *o) -{ - opt_info *o1; - if (o->v[4].fb(o->v[3].o1)) - return(o->sc->unspecified); - o1 = o->v[5].o1; - return(o1->v[0].fp(o1)); -} - -static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - s7_pointer p; - int32_t k; - opt_info *opc; - if (len > (NUM_VUNIONS - 6)) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[3].o1 = sc->opts[sc->pc]; - if (!bool_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - if (is_pair(cdr(p))) - oo_idp_nr_fixup(start); - opc->v[k].o1 = start; - } - opc->v[4].fb = opc->v[3].o1->v[0].fb; - opc->v[1].i = len - 2; - if (car(car_x) == sc->when_symbol) - { - if (len == 3) - opc->v[0].fp = opt_when_p_1; - else - if (len == 4) - { - opc->v[0].fp = opt_when_p_2; - opc->v[7].o1 = opc->v[6].o1; - opc->v[8].fp = opc->v[7].o1->v[0].fp; - opc->v[6].fp = opc->v[5].o1->v[0].fp; - } - else opc->v[0].fp = opt_when_p; - } - else opc->v[0].fp = (len == 3) ? opt_unless_p_1 : opt_unless_p; - return_true(sc, car_x); -} - -/* -------- cell_cond -------- */ - -#define COND_O1 3 -#define COND_CLAUSE_O1 5 - -static s7_pointer cond_value(opt_info *o) -{ - opt_info *o1; - s7_int i, len = o->v[1].i - 1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + COND_CLAUSE_O1].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + COND_CLAUSE_O1].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_cond(opt_info *top) -{ - s7_int len = top->v[2].i; - for (s7_int clause = 0; clause < len; clause++) - { - opt_info *o1 = top->v[clause + COND_O1].o1; - opt_info *o2 = o1->v[4].o1; - if (o2->v[0].fb(o2)) - { - s7_pointer res = cond_value(o1); - return(res); - }} - return(top->sc->unspecified); -} - -static s7_pointer opt_cond_1(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? cond_value(o->v[6].o1) : o->sc->unspecified);} /* cond as when */ -static s7_pointer opt_cond_1b(opt_info *o) {return((o->v[4].o1->v[O_WRAP].fp(o->v[4].o1) != o->sc->F) ? cond_value(o->v[6].o1) : o->sc->unspecified);} - -static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */ -{ - opt_info *o1 = (o->v[5].fb(o->v[4].o1)) ? o->v[6].o1 : o->v[7].o1; - s7_pointer res = o1->v[0].fp(o1); - return(res); -} - -static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) -{ - /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ - s7_pointer last_clause = NULL; - int32_t branches = 0, max_blen = 0; - opt_info *top = alloc_opt_info(sc); - int32_t start_pc = sc->pc; - for (s7_pointer p = cdr(car_x); is_pair(p); p = cdr(p), branches++) - { - opt_info *opc; - s7_pointer clause = car(p), cp; - int32_t blen; - if ((branches >= (NUM_VUNIONS - COND_O1)) || - (!is_pair(clause)) || - (!is_pair(cdr(clause))) || /* leave the test->result case for later */ - (cadr(clause) == sc->feed_to_symbol)) - return_false(sc, clause); - - last_clause = clause; - top->v[branches + COND_O1].o1 = sc->opts[sc->pc]; - opc = alloc_opt_info(sc); - opc->v[4].o1 = sc->opts[sc->pc]; - if (!bool_optimize(sc, clause)) - return_false(sc, clause); - - for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) - { - if (blen >= NUM_VUNIONS - COND_CLAUSE_O1) - return_false(sc, cp); - opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cp)) - return_false(sc, cp); - } - if (!is_null(cp)) - return_false(sc, cp); - opc->v[1].i = blen; - if (max_blen < blen) max_blen = blen; - opc->v[0].fp = opt_cond; /* a placeholder */ - } - if (branches == 1) - { - opt_info *o1 = sc->opts[start_pc + 1]; - top->v[0].fp = (o1->v[0].fb == p_to_b) ? opt_cond_1b : opt_cond_1; - top->v[4].o1 = o1; - top->v[5].fb = o1->v[0].fb; - top->v[6].o1 = sc->opts[start_pc]; - return_true(sc, car_x); - } - if (branches == 2) - { - if ((max_blen == 1) && - ((car(last_clause) == sc->else_symbol) || (car(last_clause) == sc->T))) - { - opt_info *o1; - top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1; - top->v[7].o1 = top->v[COND_O1 + 1].o1->v[COND_CLAUSE_O1].o1; - - o1 = sc->opts[start_pc + 1]; - top->v[4].o1 = o1; - top->v[5].fb = o1->v[0].fb; - top->v[0].fp = opt_cond_2; - return_true(sc, car_x); - }} - top->v[2].i = branches; - top->v[0].fp = opt_cond; - return_true(sc, car_x); -} - -/* -------- cell_and|or -------- */ -static s7_pointer opt_and_pp(opt_info *o) {return((o->v[11].fp(o->v[10].o1) == o->sc->F) ? o->sc->F : o->v[9].fp(o->v[8].o1));} - -static s7_pointer opt_and_any_p(opt_info *o) -{ - s7_pointer val = o->sc->T; /* (and) -> #t */ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - val = o1->v[0].fp(o1); - if (val == o->sc->F) - return(o->sc->F); - } - return(val); -} - -static s7_pointer opt_or_pp(opt_info *o) -{ - s7_pointer val = o->v[11].fp(o->v[10].o1); - return((val != o->sc->F) ? val : o->v[9].fp(o->v[8].o1)); -} - -static s7_pointer opt_or_any_p(opt_info *o) -{ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - s7_pointer val = o1->v[0].fp(o1); - if (val != o->sc->F) - return(val); - } - return(o->sc->F); -} - -static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - opt_info *opc = alloc_opt_info(sc); - if (len == 3) - { - opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_pp : opt_and_pp); - opc->v[10].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[8].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cddr(car_x))) - return_false(sc, car_x); - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - } - if ((len > 1) && (len < (NUM_VUNIONS - 4))) - { - s7_pointer p = cdr(car_x); - opc->v[1].i = (len - 1); - opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); - for (int32_t i = 3; is_pair(p); i++, p = cdr(p)) - { - opc->v[i].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - } - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- cell_if -------- */ -static s7_pointer opt_if_bp(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} -static s7_pointer opt_if_b7p(opt_info *o) {return((opt_b_7p_f(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} /* expanded not faster */ -static s7_pointer opt_if_nbp(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));} -static s7_pointer opt_if_bp_and(opt_info *o) {return((opt_and_bb(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} - -static s7_pointer opt_if_bp_pb(opt_info *o) /* p_to_b at outer, p_to_b expanded and moved to o[3] */ -{ - return((o->v[3].fp(o->v[2].o1) != o->sc->F) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified); -} - -static s7_pointer opt_if_bp_ii_fc(opt_info *o) -{ - return((o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified); -} - -static s7_pointer opt_if_nbp_s(opt_info *o) -{ - return((o->v[2].b_p_f(slot_value(o->v[3].p))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */ -{ - return((o->v[3].b_pp_f(slot_value(o->v[2].p), o->v[4].p)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */ -{ - return((o->v[3].b_7pp_f(o->sc, slot_value(o->v[2].p), o->v[4].p)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */ -{ - return((o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[4].p)))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_num_eq_ii_ss(opt_info *o) /* b_ii_ss */ -{ - return((integer(slot_value(o->v[2].p)) == integer(slot_value(o->v[4].p))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_fs(opt_info *o) /* b_pi_fs */ -{ - return((o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p)))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_sf(opt_info *o) /* b_pp_sf */ -{ - return((o->v[2].b_pp_f(slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_7sf(opt_info *o) /* b_7pp_sf */ -{ - return((o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_bpp(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->v[11].fp(o->v[10].o1));} -static s7_pointer opt_if_bpp_bit(opt_info *o) {return((opt_b_7ii_sc_bit(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->v[11].fp(o->v[10].o1));} - -static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - opt_info *opc = alloc_opt_info(sc); - opt_info *bop = sc->opts[sc->pc]; - if (len == 3) - { - if ((is_proper_list_2(sc, cadr(car_x))) && /* (not arg) */ - (caadr(car_x) == sc->not_symbol)) - { - if (bool_optimize(sc, cdadr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = top; - opc->v[11].fp = top->v[0].fp; - if (bop->v[0].fb == opt_b_p_s) - { - opc->v[2].b_p_f = bop->v[2].b_p_f; - opc->v[3].p = bop->v[1].p; - opc->v[0].fp = opt_if_nbp_s; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pi_fs) || (bop->v[0].fb == opt_b_pi_fs_num_eq)) - { - opc->v[2].b_pi_f = bop->v[2].b_pi_f; - opc->v[3].p = bop->v[1].p; - opc->v[4].o1 = bop->v[10].o1; - opc->v[5].fp = bop->v[11].fp; - opc->v[0].fp = opt_if_nbp_fs; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pp_sf) || - (bop->v[0].fb == opt_b_7pp_sf)) - { - opc->v[4].o1 = bop->v[10].o1; - opc->v[5].fp = bop->v[11].fp; - if (bop->v[0].fb == opt_b_pp_sf) - { - opc->v[2].b_pp_f = bop->v[3].b_pp_f; - opc->v[0].fp = opt_if_nbp_sf; - } - else - { - opc->v[2].b_7pp_f = bop->v[3].b_7pp_f; - opc->v[0].fp = opt_if_nbp_7sf; - } - opc->v[3].p = bop->v[1].p; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pp_sc) || - (bop->v[0].fb == opt_b_7pp_sc)) - { - if (bop->v[0].fb == opt_b_pp_sc) - { - opc->v[3].b_pp_f = bop->v[3].b_pp_f; - opc->v[0].fp = opt_if_nbp_sc; - } - else - { - opc->v[3].b_7pp_f = bop->v[3].b_7pp_f; - opc->v[0].fp = opt_if_nbp_7sc; - } - opc->v[2].p = bop->v[1].p; - opc->v[4].p = bop->v[2].p; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_ii_ss) || (bop->v[0].fb == opt_b_ii_ss_eq) || - (bop->v[0].fb == opt_b_ii_ss_lt) || (bop->v[0].fb == opt_b_ii_ss_gt) || - (bop->v[0].fb == opt_b_ii_ss_leq) || (bop->v[0].fb == opt_b_ii_ss_geq)) - { - opc->v[3].b_ii_f = bop->v[3].b_ii_f; - opc->v[2].p = bop->v[1].p; - opc->v[4].p = bop->v[2].p; - opc->v[0].fp = (opc->v[3].b_ii_f == num_eq_b_ii) ? opt_if_num_eq_ii_ss : opt_if_nbp_ss; - return_true(sc, car_x); - } - opc->v[4].o1 = bop; - opc->v[5].fb = bop->v[0].fb; - opc->v[0].fp = opt_if_nbp; - return_true(sc, car_x); - }}} - else - if (bool_optimize(sc, cdr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[2].o1 = bop; - opc->v[4].o1 = top; - opc->v[5].fp = top->v[0].fp; - if (bop->v[0].fb == p_to_b) - { - opc->v[0].fp = opt_if_bp_pb; - opc->v[3].fp = bop->v[O_WRAP].fp; - return_true(sc, car_x); - } - if (bop->v[0].fb == opt_b_ii_fc) - { - opc->v[2].i = bop->v[2].i; - opc->v[3].b_ii_f = bop->v[3].b_ii_f; - opc->v[11].fi = bop->v[11].fi; - opc->v[10].o1 = bop->v[10].o1; - opc->v[0].fp = opt_if_bp_ii_fc; - return_true(sc, car_x); - } - opc->v[0].fp = (bop->v[0].fb == opt_b_7p_f) ? opt_if_b7p : ((bop->v[0].fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); - opc->v[3].fb = bop->v[0].fb; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if (len == 4) - { - if (bool_optimize(sc, cdr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o3 = sc->opts[sc->pc]; - opc->v[0].fp = (bop->v[0].fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].o1 = bop; - opc->v[5].fb = bop->v[0].fb; - opc->v[8].o1 = top; - opc->v[9].fp = top->v[0].fp; - opc->v[10].o1 = o3; - opc->v[11].fp = o3->v[0].fp; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- cell_case -------- */ -#define CASE_O1 3 -#define CASE_SEL 2 -#define CASE_CLAUSE_O1 4 -#define CASE_CLAUSE_KEYS 2 - -static s7_pointer case_value(opt_info *o) -{ - opt_info *o1; - int32_t i, len = o->v[1].i - 1; /* int32_t here and below seems to be faster than s7_int (tleft.scm) */ - for (i = 0; i < len; i++) - { - o1 = o->v[i + CASE_CLAUSE_O1].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + CASE_CLAUSE_O1].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_case(opt_info *o) -{ - opt_info *o1 = o->v[CASE_SEL].o1; - int32_t lim = o->v[1].i; - s7_scheme *sc = o->sc; - s7_pointer selector = o1->v[0].fp(o1); - - if (is_simple(selector)) - { - for (int32_t ctr = CASE_O1; ctr < lim; ctr++) - { - s7_pointer z; - o1 = o->v[ctr].o1; - for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) - if (selector == car(z)) - return(case_value(o1)); - if (z == sc->else_symbol) - return(case_value(o1)); - }} - else - for (int32_t ctr = CASE_O1; ctr < lim; ctr++) - { - s7_pointer z; - o1 = o->v[ctr].o1; - for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) - if (s7_is_eqv(sc, selector, car(z))) - return(case_value(o1)); - if (z == sc->else_symbol) - return(case_value(o1)); - } - return(sc->unspecified); -} - -static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x) -{ - /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ - s7_pointer p; - int32_t ctr; - opt_info *top = alloc_opt_info(sc); - top->v[CASE_SEL].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(car_x))) /* selector */ - return_false(sc, car_x); - for (ctr = CASE_O1, p = cddr(car_x); (is_pair(p)) && (ctr < NUM_VUNIONS); ctr++, p = cdr(p)) - { - opt_info *opc; - s7_pointer clause = car(p), cp; - int32_t blen; - if ((!is_pair(clause)) || - ((!is_pair(car(clause))) && (car(clause) != sc->else_symbol)) || - (!is_pair(cdr(clause))) || - (cadr(clause) == sc->feed_to_symbol)) - return_false(sc, clause); - - opc = alloc_opt_info(sc); - top->v[ctr].o1 = opc; - if (car(clause) == sc->else_symbol) - { - if (!is_null(cdr(p))) - return_false(sc, clause); - opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol; - } - else - { - if (!s7_is_proper_list(sc, car(clause))) - return_false(sc, clause); - opc->v[CASE_CLAUSE_KEYS].p = car(clause); - } - - for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < (NUM_VUNIONS - CASE_CLAUSE_O1)); blen++, cp = cdr(cp)) - { - opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cp)) - return_false(sc, cp); - } - if (!is_null(cp)) - return_false(sc, cp); - opc->v[1].i = blen; - opc->v[0].fp = opt_case; /* just a placeholder I hope */ - } - if (!is_null(p)) - return_false(sc, p); - top->v[1].i = ctr; - top->v[0].fp = opt_case; - return_true(sc, car_x); -} - -/* -------- cell_let_temporarily -------- */ - -#define LET_TEMP_O1 5 - -static s7_pointer opt_let_temporarily(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - s7_int i, len; - s7_pointer result; - s7_scheme *sc = o->sc; - - if (is_immutable_slot(o->v[1].p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, slot_symbol(o->v[1].p))); - - o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */ - gc_protect_via_stack(sc, o->v[3].p); - slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */ - len = o->v[2].i - 1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + LET_TEMP_O1].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + LET_TEMP_O1].o1; - result = o1->v[0].fp(o1); - slot_set_value(o->v[1].p, o->v[3].p); /* restore old */ - unstack(sc); - return(result); -} - -static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - s7_pointer vars; - if (len <= 2) - return_false(sc, car_x); - - vars = cadr(car_x); - if ((len < (NUM_VUNIONS - LET_TEMP_O1)) && - (is_proper_list_1(sc, vars)) && /* just one var for now */ - (is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */ - (is_symbol(caar(vars))) && - (!is_immutable(caar(vars))) && - (!is_syntactic_symbol(caar(vars)))) - { - int32_t i; - s7_pointer p; - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = lookup_slot_from(caaadr(car_x), sc->curlet); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - - opc->v[4].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdaadr(car_x))) - return_false(sc, car_x); - - for (i = LET_TEMP_O1, p = cddr(car_x); is_pair(p); i++, p = cdr(p)) - { - opc->v[i].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - } - opc->v[2].i = len - 2; - opc->v[0].fp = opt_let_temporarily; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- cell_do -------- */ - -#define do_curlet(o) o->v[2].p -#define do_body_length(o) o->v[3].i -#define do_result_length(o) o->v[4].i -#define do_any_inits(o) o->v[7].o1 -#define do_any_body(o) o->v[10].o1 -#define do_any_results(o) o->v[11].o1 -#define do_any_test(o) o->v[12].o1 -#define do_any_steps(o) o->v[13].o1 - -static void let_set_has_pending_value(s7_pointer lt) -{ - for (s7_pointer vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) - slot_set_pending_value(vp, eof_object); /* gc needs a legit value here */ -} - -static void let_clear_has_pending_value(s7_pointer lt) -{ - for (s7_pointer vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) - slot_clear_has_pending_value(vp); -} - -typedef s7_pointer (*opt_info_fp)(opt_info *o); - -static s7_pointer opt_do_any(opt_info *o) -{ - opt_info *o1; - opt_info *ostart = do_any_test(o); - opt_info *body = do_any_body(o); - opt_info *inits = do_any_inits(o); - opt_info *steps = do_any_steps(o); - opt_info *results = do_any_results(o); - int32_t i, k, len = do_body_length(o); /* len=6 tlist, 6|7 tbig, 0 tvect */ - s7_pointer vp, result; - s7_scheme *sc = o->sc; - opt_info *os[NUM_VUNIONS]; - opt_info_fp fp[NUM_VUNIONS]; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - sc->curlet = T_Let(do_curlet(o)); - /* init */ - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - { - o1 = inits->v[k].o1; - slot_set_value(vp, o1->v[0].fp(o1)); - } - let_set_has_pending_value(sc->curlet); - for (i = 0; i < len; i++) - { - os[i] = body->v[i].o1; - fp[i] = os[i]->v[0].fp; - } - while (true) - { - /* end */ - if (ostart->v[0].fb(ostart)) - break; - /* body */ - if (len == 6) /* here and in opt_do_n we need a better way to unroll these loops */ - {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]);} - else - if (len == 7) - {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]);} - else for (i = 0; i < len; i++) fp[i](os[i]); - /* step (let not let*) */ - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - if (has_stepper(vp)) - { - o1 = steps->v[k].o1; - slot_simply_set_pending_value(vp, o1->v[0].fp(o1)); - } - for (vp = let_slots(sc->curlet); tis_slot(vp); vp = next_slot(vp)) - if (has_stepper(vp)) - slot_set_value(vp, slot_pending_value(vp)); - } - /* result */ - result = sc->T; - for (i = 0; i < do_result_length(o); i++) - { - o1 = results->v[i].o1; - result = o1->v[0].fp(o1); - } - let_clear_has_pending_value(sc->curlet); - unstack(sc); - set_curlet(sc, old_e); - return(result); -} - -static s7_pointer opt_do_step_1(opt_info *o) -{ - /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ - opt_info *o1; - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *inits = do_any_inits(o); - opt_info *body = do_any_body(o); - int32_t k; - s7_pointer vp, result, stepper = NULL; - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - sc->curlet = T_Let(do_curlet(o)); - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - { - o1 = inits->v[k].o1; - slot_set_value(vp, o1->v[0].fp(o1)); - if (has_stepper(vp)) stepper = vp; - } - while (!(ostart->v[0].fb(ostart))) - { - body->v[0].fp(body); - slot_set_value(stepper, ostep->v[0].fp(ostep)); - } - o1 = do_any_results(o); - result = o1->v[0].fp(o1); - unstack(sc); - set_curlet(sc, old_e); - return(result); -} - -static s7_pointer opt_do_step_i(opt_info *o) -{ - /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ - opt_info *o1; - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *inits = do_any_inits(o); - opt_info *body = do_any_body(o); - int32_t k; - s7_pointer vp, result, stepper = NULL, si; - s7_scheme *sc = o->sc; - s7_int end, incr; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - sc->curlet = T_Let(do_curlet(o)); - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - { - o1 = inits->v[k].o1; - slot_set_value(vp, o1->v[0].fp(o1)); - if (has_stepper(vp)) stepper = vp; - } - end = integer(slot_value(ostart->v[2].p)); - incr = ostep->v[2].i; - si = make_mutable_integer(sc, integer(slot_value(ostart->v[1].p))); - if (stepper) slot_set_value(stepper, si); - while (integer(si) != end) - { - body->v[0].fp(body); - integer(si) += incr; - } - clear_mutable_integer(si); - o1 = do_any_results(o); - result = o1->v[0].fp(o1); - unstack(sc); - set_curlet(sc, old_e); - return(result); -} - -#define do_no_vars_test(o) o->v[6].o1 -#define do_no_vars_body(o) o->v[7].o1 - -static s7_pointer opt_do_no_vars(opt_info *o) -{ - /* no vars, no return, o->v[2].p=let, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6]=end test */ - opt_info *ostart = do_no_vars_test(o); - int32_t len = do_body_length(o); - s7_scheme *sc = o->sc; - bool (*fb)(opt_info *o) = ostart->v[0].fb; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - if (len == 0) /* titer */ - while (!(fb(ostart))); - else - { - opt_info *body = do_no_vars_body(o); - while (!(fb(ostart))) /* tshoot, tfft */ - for (int32_t i = 0; i < len; i++) - { - opt_info *o1 = body->v[i].o1; - o1->v[0].fp(o1); - }} - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -#define do_stepper_init(o) o->v[11].o1 - -static s7_pointer opt_do_1(opt_info *o) -{ - /* 1 var, 1 expr, no return */ - opt_info *o1 = do_stepper_init(o); - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *body = do_any_body(o); - s7_pointer vp = let_slots(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - slot_set_value(vp, o1->v[0].fp(o1)); - if ((o->v[8].i == 1) && - (is_t_integer(slot_value(vp)))) - { - if ((ostep->v[0].fp == opt_p_ii_ss_add) || /* tmap */ - (ostep->v[0].fp == i_to_p)) - { - s7_pointer step_val = make_mutable_integer(sc, integer(slot_value(vp))); - slot_set_value(vp, step_val); - if (ostep->v[0].fp == opt_p_ii_ss_add) - while (!ostart->v[0].fb(ostart)) - { - body->v[0].fp(body); - integer(step_val) = opt_i_ii_ss_add(ostep); - } - else - while (!ostart->v[0].fb(ostart)) - { - body->v[0].fp(body); - integer(step_val) = ostep->v[O_WRAP].fi(ostep); - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); - } - o->v[8].i = 2; - } - while (!(ostart->v[0].fb(ostart))) /* s7test tref */ - { - body->v[0].fp(body); - slot_set_value(vp, ostep->v[0].fp(ostep)); - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -#define do_n_body(o) o->v[7].o1 - -static s7_pointer opt_do_n(opt_info *o) -{ - /* 1 var, no return */ - opt_info *o1 = do_stepper_init(o); - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *body = do_n_body(o); - int32_t len = do_body_length(o); - s7_pointer vp = let_slots(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - slot_set_value(vp, o1->v[0].fp(o1)); - if (len == 2) /* tmac tshoot */ - { - opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; - while (!(ostart->v[0].fb(ostart))) - { - e1->v[0].fp(e1); - e2->v[0].fp(e2); - slot_set_value(vp, ostep->v[0].fp(ostep)); - }} - else - { - opt_info *os[NUM_VUNIONS]; - opt_info_fp fp[NUM_VUNIONS]; - for (int32_t i = 0; i < len; i++) - { - os[i] = body->v[i].o1; - fp[i] = os[i]->v[0].fp; - } - if (len == 7) - while (!ostart->v[0].fb(ostart)) /* tfft teq */ - { - fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]); - slot_set_value(vp, ostep->v[0].fp(ostep)); - } - else - while (!ostart->v[0].fb(ostart)) /* tfft teq */ - { - for (int32_t i = 0; i < len; i++) fp[i](os[i]); - slot_set_value(vp, ostep->v[0].fp(ostep)); - }} - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_times(opt_info *o) -{ - /* 1 var, no return */ - opt_info *o1 = do_stepper_init(o); - opt_info *body = do_n_body(o); - int32_t len = do_body_length(o); - s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[6].i; - s7_pointer vp = let_dox1_value(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); - if (len == 2) /* tmac tmisc */ - { - opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; - while (integer(vp) < end) - { - e1->v[0].fp(e1); - e2->v[0].fp(e2); - integer(vp)++; - }} - else - while (integer(vp) < end) /* tbig sg */ - { - for (int32_t i = 0; i < len; i++) - { - o1 = body->v[i].o1; - o1->v[0].fp(o1); - } - integer(vp)++; - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_list_simple(opt_info *o) -{ - opt_info *o1 = do_stepper_init(o); - s7_pointer vp = let_slots(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer (*fp)(opt_info *o); - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - slot_set_value(vp, o1->v[0].fp(o1)); - o1 = do_any_body(o); - fp = o1->v[0].fp; - if (fp == opt_if_bp) - while (is_pair(slot_value(vp))) - { - if (o1->v[3].fb(o1->v[2].o1)) - o1->v[5].fp(o1->v[4].o1); - slot_set_value(vp, cdr(slot_value(vp))); - } - else - while (!is_null(slot_value(vp))) - { - fp(o1); - slot_set_value(vp, cdr(slot_value(vp))); - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_very_simple(opt_info *o) -{ - /* like simple but step can be direct, v[2].p is a let, v[3].i=end? */ - opt_info *o1 = do_stepper_init(o); - s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[3].i; - s7_pointer vp = let_dox1_value(do_curlet(o)); - s7_pointer (*f)(opt_info *o); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); - o1 = do_any_body(o); - f = o1->v[0].fp; - if (f == opt_p_pip_ssf) /* tref.scm */ - { - opt_info *o2 = o1; - o1 = o2->v[4].o1; - if (o2->v[3].p_pip_f == normal_vector_set_p_pip_direct) - { - s7_pointer v = slot_value(o2->v[1].p); - while (integer(vp) < end) - { - normal_vector_set_p_pip_direct(o2->sc, v, integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); - integer(vp)++; - }} - else - while (integer(vp) < end) - { - o2->v[3].p_pip_f(o2->sc, slot_value(o2->v[1].p), integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); - integer(vp)++; - }} - else - { - if (f == opt_p_pip_sso) - { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */ - if (((let_dox_slot1(do_curlet(o)) == o1->v[2].p) && (o1->v[2].p == o1->v[4].p)) && - (((o1->v[5].p_pip_f == float_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == float_vector_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == int_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == int_vector_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == string_set_p_pip_direct) && (o1->v[6].p_pi_f == string_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == byte_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == byte_vector_ref_p_pi_direct)))) - { - copy_to_same_type(sc, slot_value(o1->v[1].p), slot_value(o1->v[3].p), integer(vp), end, integer(vp)); - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); - } - while (integer(vp) < end) - { - o1->v[5].p_pip_f(o1->sc, slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p)), - o1->v[6].p_pi_f(o1->sc, slot_value(o1->v[3].p), integer(slot_value(o1->v[4].p)))); - integer(vp)++; - }} - else - if ((f == opt_set_p_i_f) && /* tvect.scm */ - (is_t_integer(slot_value(o1->v[1].p))) && - (o1->v[1].p != let_dox_slot1(do_curlet(o)))) - { - opt_info *o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); */ - s7_int (*fi)(opt_info *o) = o2->v[0].fi; - s7_pointer ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); - slot_set_value(o1->v[1].p, ival); - while (integer(vp) < end) - { - integer(ival) = fi(o2); - integer(vp)++; - } - slot_set_value(o1->v[1].p, make_integer(sc, integer(slot_value(o1->v[1].p)))); - } - else - if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ - (o1->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) - { - s7_pointer ind = o1->v[2].p; - opt_info *o2 = do_any_body(o1); - s7_double (*fd)(opt_info *o) = o2->v[0].fd; - s7_pointer fv = slot_value(o1->v[1].p); - while (integer(vp) < end) - { - float_vector_set_d_7pid_direct(sc, fv, integer(slot_value(ind)), fd(o2)); - /* weird! els[integer(slot_value(ind))] = fd(o2) is much slower according to callgrind? */ - integer(vp)++; - }} - else - while (integer(vp) < end) {f(o1); integer(vp)++;}} - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -#define do_prepack_end(o) o->v[1].i -#define do_prepack_stepper(o) o->v[6].p - -static s7_pointer opt_do_prepackaged(opt_info *o) -{ - opt_info *o1 = do_stepper_init(o); - s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[3].i; - s7_pointer vp = let_dox1_value(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); - - do_prepack_stepper(o) = vp; - do_prepack_end(o) = end; - o->v[7].fp(o); /* call opt_do_i|dpnr below */ - - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_dpnr(opt_info *o) -{ - opt_info *o1 = do_any_body(o); - s7_pointer vp = do_prepack_stepper(o); - s7_int end = do_prepack_end(o); - s7_double (*f)(opt_info *o) = o1->v[O_WRAP].fd; - while (integer(vp) < end) {f(o1); integer(vp)++;} - return(NULL); -} - -static s7_pointer opt_do_ipnr(opt_info *o) -{ - opt_info *o1 = do_any_body(o); - s7_pointer vp = do_prepack_stepper(o); - s7_int end = do_prepack_end(o); - s7_int (*f)(opt_info *o) = o1->v[O_WRAP].fi; - while (integer(vp) < end) {f(o1); integer(vp)++;} - return(NULL); -} - -static bool stop_is_safe(s7_scheme *sc, s7_pointer stop, s7_pointer body) -{ - /* this could be folded into the cell_optimize traveral */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (caar(p) == sc->set_symbol) && - (is_pair(cdar(p))) && - (cadar(p) == stop)) - return(!s7_tree_memq(sc, stop, cdr(p))); - return(true); -} - -static bool tree_has_setters(s7_scheme *sc, s7_pointer tree) -{ - clear_symbol_list(sc); - add_symbol_to_list(sc, sc->set_symbol); - add_symbol_to_list(sc, sc->vector_set_symbol); - add_symbol_to_list(sc, sc->list_set_symbol); - add_symbol_to_list(sc, sc->let_set_symbol); - add_symbol_to_list(sc, sc->hash_table_set_symbol); - add_symbol_to_list(sc, sc->set_car_symbol); - add_symbol_to_list(sc, sc->set_cdr_symbol); - return(tree_set_memq(sc, tree)); -} - -static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, bool *has_set); - -static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, bool *has_set) -{ - if (!is_pair(body)) return(true); - if (!is_safety_checked(body)) - { - set_safety_checked(body); - if (!(do_is_safe(sc, body, stepper, sc->nil, has_set))) - set_unsafe_do(body); - } - return(!is_unsafe_do(body)); -} - -#define SIZE_O NUM_VUNIONS - -static bool all_integers(s7_scheme *sc, s7_pointer expr) -{ - if ((is_symbol(car(expr))) && (is_all_integer(car(expr)))) - { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!((is_t_integer(car(p))) || - ((is_symbol(car(p))) && (is_t_integer(slot_value(lookup_slot_from(car(p), sc->curlet))))) || - ((is_pair(car(p))) && (all_integers(sc, car(p)))))) - break; - return(is_null(p)); - } - return(false); -} - -static bool all_floats(s7_scheme *sc, s7_pointer expr) -{ - if ((is_symbol(car(expr))) && (is_all_float(car(expr)))) - { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!((is_t_real(car(p))) || - ((is_symbol(car(p))) && (is_t_real(slot_value(lookup_slot_from(car(p), sc->curlet))))) || - ((is_pair(car(p))) && (all_floats(sc, car(p)))))) - break; - return(is_null(p)); - } - return(false); -} - -static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - opt_info *opc; - s7_pointer p, end, let = NULL, old_e = sc->curlet, stop, ind, ind_step; - int32_t i, k, var_len, body_len = len - 3, body_index, step_len, rtn_len, step_pc, init_pc, end_test_pc; - bool has_set = false; - opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O], *return_o[SIZE_O]; - - if (len < 3) - return_false(sc, car_x); - - if (!s7_is_proper_list(sc, cadr(car_x))) - return_false(sc, car_x); - var_len = proper_list_length(cadr(car_x)); - step_len = var_len; - if (body_len > SIZE_O) - return_false(sc, car_x); - end = caddr(car_x); - if (!is_pair(end)) - return_false(sc, car_x); - - opc = alloc_opt_info(sc); - let = inline_make_let(sc, sc->curlet); - push_stack(sc, OP_GC_PROTECT, old_e, let); - - /* the vars have to be added to the let before evaluating the inits - * else symbol_id can be > let_id (see "(test (do ((i (do ((i (do ((i 0 (+ i 1)))...") - */ - clear_symbol_list(sc); - for (p = cadr(car_x); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_pair(var)) && - (is_symbol(car(var))) && - (is_pair(cdr(var)))) - { - s7_pointer sym = car(var); - if (is_constant_symbol(sc, sym)) - return_false(sc, car_x); - if (symbol_is_in_list(sc, sym)) - syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, var); - add_symbol_to_list(sc, sym); - add_slot(sc, let, sym, sc->undefined); - } - else return_false(sc, car_x); - } - if (tis_slot(let_slots(let))) - let_set_slots(let, reverse_slots(sc, let_slots(let))); - - /* inits */ - { - s7_pointer slot; - init_pc = sc->pc; - for (k = 0, p = cadr(car_x), slot = let_slots(let); (is_pair(p)) && (k < SIZE_O); k++, p = cdr(p), slot = next_slot(slot)) - { - s7_pointer var = car(p); - init_o[k] = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(var))) /* opt init in outer let */ - return_false(sc, car_x); - if (is_pair(cddr(var))) - { - set_has_stepper(slot); - if (!is_null(cdddr(var))) - return_false(sc, car_x); - } - else - { - step_len--; - if (!is_null(cddr(var))) - return_false(sc, car_x); - } - /* we can't use slot_set_value(slot, init_o[k]->v[0].fp(init_o[k])) to get the init value here: it might involve side-effects, - * and in some contexts might access variables that aren't set up yet. So, we kludge around... - */ - if (is_symbol(cadr(var))) - slot_set_value(slot, slot_value(lookup_slot_from(cadr(var), sc->curlet))); - else - if (!is_pair(cadr(var))) - slot_set_value(slot, cadr(var)); - else - if (is_proper_quote(sc, cadr(var))) - slot_set_value(slot, cadadr(var)); - else - { - s7_pointer sf = lookup_checked(sc, caadr(var)); - if (is_c_function(sf)) - { - s7_pointer sig = c_function_signature(sf); - if (is_pair(sig)) - { - if ((car(sig) == sc->is_integer_symbol) || - ((is_pair(car(sig))) && - (direct_memq(sc->is_integer_symbol, car(sig)))) || - (all_integers(sc, cadr(var)))) - slot_set_value(slot, int_zero); - else - if ((car(sig) == sc->is_float_symbol) || - ((is_pair(car(sig))) && - (direct_memq(sc->is_float_symbol, car(sig)))) || - (all_floats(sc, cadr(var)))) - slot_set_value(slot, real_zero); - /* need for stepper too -- how does it know (+ x 0.1) is float? try (i 0 (floor (+ i 1))) etc */ - }}}} - set_curlet(sc, let); - for (p = cadr(car_x); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if (is_pair(cddr(var))) - { - s7_pointer init_type = opt_arg_type(sc, cdr(var)); - if (((init_type == sc->is_integer_symbol) || - (init_type == sc->is_float_symbol)) && - (opt_arg_type(sc, cddr(var)) != init_type)) - { - unstack(sc); /* not pop_stack! */ - set_curlet(sc, old_e); - return_false(sc, car_x); - }}}} - - /* end test */ - end_test_pc = sc->pc; - if (!bool_optimize_nw(sc, end)) - { - unstack(sc); /* not pop_stack! */ - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - stop = car(end); - if ((is_proper_list_3(sc, stop)) && - ((car(stop) == sc->num_eq_symbol) || (car(stop) == sc->geq_symbol) || (car(stop) == sc->gt_symbol)) && - (is_symbol(cadr(stop))) && - ((is_t_integer(caddr(stop))) || (is_symbol(caddr(stop))))) - { - s7_pointer stop_slot = (is_symbol(caddr(stop))) ? opt_integer_symbol(sc, caddr(stop)) : sc->nil; - if (stop_slot) - { - s7_int lim = (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(stop)); - bool set_stop = false; - s7_pointer slot; - - if (car(stop) == sc->gt_symbol) lim++; - for (p = cadr(car_x), slot = let_slots(let); is_pair(p); p = cdr(p), slot = next_slot(slot)) - { - /* this could be put off until it is needed (ref/set), but this code is not called much - * another choice: go from init downto 0: init is lim - */ - if (slot_symbol(slot) == cadr(stop)) - set_stop = true; /* don't overrule this decision below */ - if (has_stepper(slot)) - { - s7_pointer var = car(p), step = caddr(var); - if ((is_t_integer(slot_value(slot))) && - (is_pair(step)) && - (is_pair(cdr(step))) && - (car(var) == cadr(stop)) && - (car(var) == cadr(step)) && - ((car(stop) != sc->num_eq_symbol) || /* else > protects at least the top */ - ((caddr(step) == int_one) && (car(step) == sc->add_symbol)))) - { - set_step_end(slot); - slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); - set_do_loop_end(slot_value(slot), lim); - }}} - - if (!set_stop) - { - s7_pointer slot2 = opt_integer_symbol(sc, cadr(stop)); - if ((slot2) && - (stop_is_safe(sc, cadr(stop), cddr(car_x)))) - { - set_step_end(slot2); - set_do_loop_end(slot_value(slot2), lim); - }}}} - - /* body */ - body_index = sc->pc; - for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - body_o[k] = start; - if (i < 5) opc->v[i + 7].o1 = start; - if (!cell_optimize(sc, p)) - break; - oo_idp_nr_fixup(start); - } - if (!is_null(p)) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - /* we faked up sc->curlet above, so s7_optimize_1 (float_optimize) isn't safe here - * this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better - */ - /* steps */ - step_pc = sc->pc; - for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p)) - { - s7_pointer var = car(p); - step_o[k] = sc->opts[sc->pc]; - if ((is_pair(cddr(var))) && - (!cell_optimize(sc, cddr(var)))) - break; - } - if (!is_null(p)) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - /* result */ - if (!is_list(cdr(end))) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O); p = cdr(p), rtn_len++) - { - return_o[rtn_len] = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (!is_null(p)) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - do_curlet(opc) = let; - do_body_length(opc) = len - 3; - do_result_length(opc) = rtn_len; - opc->v[9].o1 = sc->opts[step_pc]; - set_curlet(sc, old_e); - - if ((var_len == 0) && (rtn_len == 0)) - { - opt_info *body; - do_no_vars_test(opc) = sc->opts[end_test_pc]; - opc->v[0].fp = opt_do_no_vars; - if (body_len > 0) - { - body = alloc_opt_info(sc); - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_no_vars_body(opc) = body; - } - return(true); - } - opc->v[8].i = 0; - if (body_len == 1) - { - s7_pointer expr = cadddr(car_x); - if ((is_pair(expr)) && - ((is_c_function(car(expr))) || - (is_safe_setter(car(expr))) || - ((car(expr) == sc->set_symbol) && - (cadr(expr) != caaadr(car_x))) || /* caadr: (stepper init ...) */ - ((car(expr) == sc->vector_set_symbol) && - (is_null(cddddr(expr))) && - (is_code_constant(sc, cadddr(expr)))))) - opc->v[8].i = 1; - } - if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) - { - opt_info *inits; - - opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any; - /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */ - - do_any_test(opc) = sc->opts[end_test_pc]; - - if ((opc->v[0].fp == opt_do_step_1) && - (opc->v[9].o1->v[0].fp == i_to_p) && - (opc->v[9].o1->v[O_WRAP].fi == opt_i_ii_sc_add) && - (do_any_test(opc)->v[0].fb == opt_b_ii_ss_eq)) - opc->v[0].fp = opt_do_step_i; - - inits = alloc_opt_info(sc); - for (k = 0; k < var_len; k++) - inits->v[k].o1 = init_o[k]; - do_any_inits(opc) = inits; - - if (opc->v[0].fp == opt_do_any) - { - opt_info *result, *step; - opt_info *body = alloc_opt_info(sc); - - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_any_body(opc) = body; - - result = alloc_opt_info(sc); - for (k = 0; k < rtn_len; k++) - result->v[k].o1 = return_o[k]; - do_any_results(opc) = result; - - step = alloc_opt_info(sc); - for (k = 0; k < var_len; k++) - step->v[k].o1 = step_o[k]; - do_any_steps(opc) = step; - } - else - { - do_any_body(opc) = sc->opts[body_index]; - do_any_results(opc) = return_o[0]; - } - return(true); - } - - opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n; - p = caadr(car_x); - ind = car(p); - ind_step = caddr(p); - end = caaddr(car_x); - - if (body_len == 1) /* opt_do_1 */ - do_any_body(opc) = sc->opts[body_index]; - else - { - opt_info *body = alloc_opt_info(sc); - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_n_body(opc) = body; - } - do_stepper_init(opc) = sc->opts[init_pc]; - do_any_test(opc) = sc->opts[end_test_pc]; - do_any_steps(opc) = sc->opts[step_pc]; - - if ((is_pair(end)) && /* (= i len|100) */ - (cadr(end) == ind) && - (is_pair(ind_step))) /* (+ i 1) */ - { - /* we can't use step_end_ok here yet (not set except for op_dox?) */ - - if (((car(end) == sc->num_eq_symbol) || (car(end) == sc->geq_symbol)) && - ((is_symbol(caddr(end))) || (is_t_integer(caddr(end)))) && - (is_null(cdddr(end))) && - (car(ind_step) == sc->add_symbol) && - (cadr(ind_step) == ind) && - (caddr(ind_step) == int_one) && - (is_null(cdddr(ind_step))) && - (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) - { - s7_pointer slot = let_slots(let); - let_set_dox_slot1(let, slot); - let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? lookup_slot_from(caddr(end), sc->curlet) : sc->undefined); - slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); - opc->v[4].i = body_index; - if (body_len == 1) /* opt_do_1 */ - { - opt_info *o1 = sc->opts[body_index]; - opc->v[0].fp = opt_do_very_simple; - if (is_t_integer(caddr(end))) - opc->v[3].i = integer(caddr(end)); - if (o1->v[0].fp == d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_dpnr; - } - else - if (o1->v[0].fp == i_to_p_nr) - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_ipnr; - }} - else - { - opc->v[0].fp = opt_do_times; - if (is_t_integer(caddr(end))) - opc->v[6].i = integer(caddr(end)); - }} - else - if ((car(end) == sc->is_null_symbol) && - (is_null(cddr(end))) && - (car(ind_step) == sc->cdr_symbol) && - (cadr(ind_step) == ind) && - (is_null(cddr(ind_step))) && - (body_len == 1) && - (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) - opc->v[0].fp = opt_do_list_simple; - } - return(true); -} - -static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - s7_pointer func = lookup_global(sc, car(car_x)); - opcode_t op; - if (!is_syntax(func)) {clear_syntactic(car_x); return(false);} - /* I think this is the only case where we don't precede syntax_opcode with syntactic_symbol checks */ - op = syntax_opcode(func); - switch (op) - { - case OP_QUOTE: if ((is_pair(cdr(car_x))) && (is_null(cddr(car_x)))) return(opt_cell_quote(sc, car_x)); break; - case OP_SET: if (len == 3) return(opt_cell_set(sc, car_x)); break; - case OP_BEGIN: if (len > 1) return(opt_cell_begin(sc, car_x, len)); break; - case OP_WHEN: - case OP_UNLESS: if (len > 2) return(opt_cell_when(sc, car_x, len)); break; - case OP_COND: if (len > 1) return(opt_cell_cond(sc, car_x)); break; - case OP_CASE: if (len > 2) return(opt_cell_case(sc, car_x)); break; - case OP_AND: - case OP_OR: return(opt_cell_and(sc, car_x, len)); - case OP_IF: return(opt_cell_if(sc, car_x, len)); - case OP_DO: return(opt_cell_do(sc, car_x, len)); - case OP_LET_TEMPORARILY: return(opt_cell_let_temporarily(sc, car_x, len)); - default: - /* for lambda et al we'd return the new closure, but if unsafe? - * let(*) -> make the let -> body (let=99% of cases), could we use do (i.e. do+no steppers+no end!) or let-temp? - * with-let -> establish car(args)=let, then body - * macroexpand -> return the expansion - * define et al -> define + return value - * map and for-each are not syntax, also call-with*(=exit) - * also let-temp for vars>1 - */ - break; - } - return_false(sc, car_x); -} - - -/* -------------------------------------------------------------------------------- */ -static bool float_optimize_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func, s_slot = NULL; - s7_int len; - if (WITH_GMP) return(false); - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_float_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - return(d_syntax_ok(sc, car_x, len)); - - s_slot = lookup_slot_from(head, sc->curlet); - if (!is_slot(s_slot)) return_false(sc, car_x); - s_func = slot_value(s_slot); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (is_c_function(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - switch (len) - { - case 1: - if (d_ok(sc, opc, s_func)) - return(true); - break; - - case 2: /* (f v) or (f d): (env e) or (abs x) */ - if ((d_d_ok(sc, opc, s_func, car_x)) || - (d_v_ok(sc, opc, s_func, car_x)) || - (d_p_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 3: - if ((d_dd_ok(sc, opc, s_func, car_x)) || - (d_id_ok(sc, opc, s_func, car_x)) || - (d_vd_ok(sc, opc, s_func, car_x)) || - (d_pd_ok(sc, opc, s_func, car_x)) || - (d_ip_ok(sc, opc, s_func, car_x)) || - (d_7pi_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 4: - if ((d_ddd_ok(sc, opc, s_func, car_x)) || - (d_7pid_ok(sc, opc, s_func, car_x)) || - (d_vid_ok(sc, opc, s_func, car_x)) || - (d_vdd_ok(sc, opc, s_func, car_x)) || - (d_7pii_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 5: - if ((d_dddd_ok(sc, opc, s_func, car_x)) || - (d_7piid_ok(sc, opc, s_func, car_x)) || - (d_7piii_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 6: - if (d_7piiid_ok(sc, opc, s_func, car_x)) - return(true); - /* break; */ - - default: - if (d_add_any_ok(sc, opc, car_x)) - return(true); - break; - }} - else - { - if ((is_macro(s_func)) && (!no_cell_opt(expr))) - { - s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body))) && - ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol))) - { - s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); - if (result == sc->F) return_false(sc, car_x); - return(float_optimize(sc, set_plist_1(sc, result))); - }} - if (!s_slot) return_false(sc, car_x); - return(d_implicit_ok(sc, s_slot, car_x, len)); - } - return_false(sc, car_x); -} - -static bool float_optimize(s7_scheme *sc, s7_pointer expr) {return((float_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool int_optimize_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func, s_slot = NULL; - s7_int len; - if (WITH_GMP) return(false); - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_int_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - return(i_syntax_ok(sc, car_x, len)); - s_slot = lookup_slot_from(head, sc->curlet); - if (!is_slot(s_slot)) return_false(sc, car_x); - s_func = slot_value(s_slot); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (is_c_function(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - switch (len) - { - case 2: - if (i_idp_ok(sc, opc, s_func, car_x)) - return(true); - break; - - case 3: - if ((i_ii_ok(sc, opc, s_func, car_x)) || - (i_7pi_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 4: - if ((i_iii_ok(sc, opc, s_func, car_x)) || - (i_7pii_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 5: - { - int32_t pstart = sc->pc; - if (i_7piii_ok(sc, opc, s_func, car_x)) - return(true); - pc_fallback(sc, pstart); - } - /* break; */ - - default: - if (((head == sc->add_symbol) || - (head == sc->multiply_symbol)) && - (i_add_any_ok(sc, opc, car_x))) - return(true); - break; - }} - else - { - if ((is_macro(s_func)) && (!no_cell_opt(expr))) - { - s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body))) && - ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol))) - { - s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); - if (result == sc->F) return_false(sc, car_x); - return(int_optimize(sc, set_plist_1(sc, result))); - }} - if (!s_slot) return_false(sc, car_x); - return(i_implicit_ok(sc, s_slot, car_x, len)); - } - return_false(sc, car_x); -} - -static bool int_optimize(s7_scheme *sc, s7_pointer expr) {return((int_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func, s_slot = NULL; - s7_int len; - if (WITH_GMP) return(false); - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_cell_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) /* this can be wrong! */ - return(p_syntax(sc, car_x, len)); - - s_slot = lookup_slot_from(head, sc->curlet); - if (!is_slot(s_slot)) return_false(sc, car_x); - s_func = slot_value(s_slot); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (is_c_function(s_func)) - { - s7_pointer sig = c_function_signature(s_func); - opt_info *opc = alloc_opt_info(sc); - int32_t pstart = sc->pc; - - switch (len) - { - case 1: - if (p_ok(sc, opc, s_func, car_x)) - return(true); - break; - - case 2: - if ((p_i_ok(sc, opc, s_func, car_x, sc->pc)) || - (p_d_ok(sc, opc, s_func, car_x, sc->pc)) || - (p_p_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 3: - if (is_symbol(cadr(car_x))) - { - if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && (caddr(sig) == sc->is_integer_symbol)) - { - if (p_pi_ok(sc, opc, s_func, sig, car_x)) - return(true); - - if ((car(sig) == sc->is_float_symbol) || - (car(sig) == sc->is_real_symbol)) - { - s7_d_7pi_t f = s7_d_7pi_function(s_func); - if (f) - { - sc->pc = pstart - 1; - if (float_optimize(sc, expr)) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - }}} - pc_fallback(sc, pstart); - }} - { - s7_i_ii_t ifunc = s7_i_ii_function(s_func); - sc->pc = pstart - 1; - if ((ifunc) && - (int_optimize(sc, expr))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - if (opc->v[O_WRAP].fi == opt_i_ii_ss_add) - opc->v[0].fp = opt_p_ii_ss_add; - return(true); - }} - pc_fallback(sc, pstart); - - if ((p_ii_ok(sc, opc, s_func, car_x, pstart)) || - (p_dd_ok(sc, opc, s_func, car_x, pstart)) || - (p_pp_ok(sc, opc, s_func, car_x, pstart)) || - (p_call_pp_ok(sc, opc, s_func, car_x, pstart))) - return(true); - break; - - case 4: - if (is_symbol(cadr(car_x))) - { - if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && - (caddr(sig) == sc->is_integer_symbol)) - { - if (p_pii_ok(sc, opc, s_func, car_x)) - return(true); - if (p_pip_ok(sc, opc, s_func, car_x)) - return(true); - - if (((car(sig) == sc->is_float_symbol) || - (car(sig) == sc->is_real_symbol)) && - (s7_d_7pid_function(s_func)) && - (d_7pid_ok(sc, opc, s_func, car_x))) - { - /* if d_7pid is ok, we need d_to_p for cell_optimize */ - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - } - - sc->pc = pstart - 1; - if ((car(sig) == sc->is_integer_symbol) && - (s7_i_7pii_function(s_func)) && - (i_7pii_ok(sc, alloc_opt_info(sc), s_func, car_x))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return(true); - } - pc_fallback(sc, pstart); - }} - if ((p_ppi_ok(sc, opc, s_func, car_x)) || - (p_ppp_ok(sc, opc, s_func, car_x)) || - (p_call_ppp_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 5: - if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && - (d_7piid_ok(sc, opc, s_func, car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; /* as above, if d_7piid is ok, we need d_to_p for cell_optimize */ - return(true); - } - if ((is_target_or_its_alias(head, s_func, sc->float_vector_ref_symbol)) && - (d_7piii_ok(sc, opc, s_func, car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - } - if (i_7piii_ok(sc, opc, s_func, car_x)) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return(true); - } - if (is_target_or_its_alias(head, s_func, sc->int_vector_set_symbol)) - return_false(sc, car_x); - if (p_piip_ok(sc, opc, s_func, car_x)) - return(true); - pc_fallback(sc, pstart); - if (s_func == global_value(sc->vector_ref_symbol)) - { - s7_pointer obj; - if (!is_symbol(cadr(car_x))) return_false(sc, car_x); - obj = lookup_unexamined(sc, cadr(car_x)); /* was lookup_from (to avoid the unbound variable check) */ - if ((!obj) || (!is_any_vector(obj)) || (vector_rank(obj) != 3)) - return_false(sc, car_x); - } - if (p_call_any_ok(sc, opc, s_func, car_x, len)) - return(true); - break; - - case 6: - if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && - (d_7piiid_ok(sc, opc, s_func, car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - } - - default: /* >3D vector-set etc */ - if (p_call_any_ok(sc, opc, s_func, car_x, len)) - return(true); - break; - }} - else - { - if (is_closure(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - if (p_fx_any_ok(sc, opc, expr)) - return(true); - } - if (is_macro(s_func)) - return_false(sc, car_x); /* macroexpand+cell_optimize here restarts the optimize process */ - if (!s_slot) return_false(sc, car_x); -#if OPT_PRINT - { - bool res = p_implicit_ok(sc, s_slot, car_x, len); - if (!res) fprintf(stderr, " %sno p_implicit for %s%s\n", BOLD_TEXT red_text, display(car_x), UNBOLD_TEXT uncolor_text); - return(res); - } -#else - return(p_implicit_ok(sc, s_slot, car_x, len)); -#endif - } - return_false(sc, car_x); -} - -static bool cell_optimize(s7_scheme *sc, s7_pointer expr) {return((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func = NULL; - s7_int len; - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_bool_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - { - if (head == sc->and_symbol) - return(opt_b_and(sc, car_x, len)); - if (head == sc->or_symbol) - return(opt_b_or(sc, car_x, len)); - return_false(sc, car_x); - } - s_func = lookup_unexamined(sc, head); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (!s_func) return_false(sc, car_x); - if (is_c_function(s_func)) - { - if ((is_symbol(head)) && (symbol_id(head) != 0)) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */ - return_false(sc, car_x); - switch (len) - { - case 2: - return(b_idp_ok(sc, s_func, car_x, opt_arg_type(sc, cdr(car_x)))); - - case 3: - { - s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_pointer sig1 = opt_arg_type(sc, cdr(car_x)); - s7_pointer sig2 = opt_arg_type(sc, cddr(car_x)); - opt_info *opc = alloc_opt_info(sc); - int32_t cur_index = sc->pc; - s7_b_7pp_t bpf7 = NULL; - s7_b_pp_t bpf; - - if (sig2 == sc->is_integer_symbol) - { - if ((sig1 == sc->is_integer_symbol) && - (b_ii_ok(sc, opc, s_func, car_x, arg1, arg2))) - return(true); - pc_fallback(sc, cur_index); - if (b_pi_ok(sc, opc, s_func, car_x, arg2)) - return(true); - pc_fallback(sc, cur_index); - } - - if ((sig1 == sc->is_float_symbol) && - (sig2 == sc->is_float_symbol) && - (b_dd_ok(sc, opc, s_func, car_x, arg1, arg2))) - return(true); - pc_fallback(sc, cur_index); - - bpf = s7_b_pp_function(s_func); - if (!bpf) bpf7 = s7_b_7pp_function(s_func); - if ((bpf) || (bpf7)) - { - if (bpf) - opc->v[3].b_pp_f = bpf; - else opc->v[3].b_7pp_f = bpf7; - return(b_pp_ok(sc, opc, s_func, car_x, arg1, arg2, bpf)); - }} - break; - - default: - break; - }} - return_false(sc, car_x); -} - -static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr) {return((bool_optimize_nw_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool bool_optimize(s7_scheme *sc, s7_pointer expr) -{ - int32_t start = sc->pc; - opt_info *wrapper; - if (WITH_GMP) return(false); - if (bool_optimize_nw(sc, expr)) - return(true); - pc_fallback(sc, start); - wrapper = sc->opts[start]; - if (!cell_optimize(sc, expr)) - return_false(sc, NULL); - if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */ - return_false(sc, NULL); - wrapper->v[O_WRAP].fp = wrapper->v[0].fp; - wrapper->v[0].fb = p_to_b; - return(true); -} - -static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - if ((bool_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) - return_success(sc, opt_bool_any, expr); - return_null(sc, expr); -} - -/* snd-sig.c experiment */ -static s7_double opt_float_any(s7_scheme *sc) {return(sc->opts[0]->v[0].fd(sc->opts[0]));} - -s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - if ((float_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) - return(opt_float_any); - return(NULL); -} - -static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv) -{ - if (WITH_GMP) return(NULL); - if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0)) - return(NULL); - sc->pc = 0; - if (!no_int_opt(expr)) - { - if (int_optimize(sc, expr)) - return((nv) ? opt_int_any_nv : opt_wrap_int); - pc_fallback(sc, 0); - set_no_int_opt(expr); - } - if (!no_float_opt(expr)) - { - if (float_optimize(sc, expr)) - return_success(sc, (nv) ? opt_float_any_nv : opt_wrap_float, expr); - pc_fallback(sc, 0); - set_no_float_opt(expr); - } - if (!no_bool_opt(expr)) - { - if (bool_optimize_nw(sc, expr)) - return_success(sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr); - pc_fallback(sc, 0); - set_no_bool_opt(expr); - } - if (cell_optimize(sc, expr)) - return_success(sc, (nv) ? opt_cell_any_nv : opt_wrap_cell, expr); - set_no_cell_opt(expr); /* checked above */ - return_null(sc, expr); -} - -s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, false));} -s7_pfunc s7_optimize_nv(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, true));} - -static s7_pointer g_optimize(s7_scheme *sc, s7_pointer args) -{ - s7_pfunc f; - s7_pointer code = car(args), result = sc->undefined; - gc_protect_via_stack(sc, code); - f = s7_optimize(sc, code); - if (f) result = f(sc); - if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) unstack(sc); /* was unstack(sc) */ - return(result); -} - -static s7_pfunc s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nv) -{ - sc->pc = 0; - if ((cell_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) - return((nv) ? opt_cell_any_nv : opt_wrap_cell); - return_null(sc, expr); -} - - -/* ---------------- bool funcs (an experiment) ---------------- */ -static void fx_curlet_tree(s7_scheme *sc, s7_pointer code) -{ - s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL, outer_e; - bool more_vars; - s7_pointer slot2 = next_slot(slot1); - if (tis_slot(slot2)) slot3 = next_slot(slot2); - - more_vars = (tis_slot(slot3)) && (tis_slot(next_slot(slot3))); - fx_tree(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - more_vars); - - outer_e = let_outlet(sc->curlet); - if ((!more_vars) && - (is_let(outer_e)) && - (!is_funclet(outer_e)) && - (tis_slot(let_slots(outer_e))) && - (slot_symbol(let_slots(outer_e)) != slot_symbol(slot1))) - { - slot1 = let_slots(outer_e); - slot2 = next_slot(slot1); - slot3 = (tis_slot(slot2)) ? next_slot(slot2) : NULL; - fx_tree_outer(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); - } -} - -static void fx_curlet_tree_in(s7_scheme *sc, s7_pointer code) -{ - s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL; - s7_pointer slot2 = next_slot(slot1); - if (tis_slot(slot2)) slot3 = next_slot(slot2); - fx_tree_in(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); -} - -typedef bool (*s7_bfunc)(s7_scheme *sc, s7_pointer expr); - -static bool fb_lt_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - s7_pointer y = lookup(sc, opt2_sym(cdr(expr))); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y)); -} - -static bool fb_lt_ts(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = t_lookup(sc, cadr(expr), expr); - s7_pointer y = lookup(sc, opt2_sym(cdr(expr))); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y)); -} - -static bool fb_num_eq_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - s7_pointer y = lookup(sc, opt2_sym(cdr(expr))); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y)); -} - -static bool fb_num_eq_s0(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - return((is_t_integer(x)) ? (integer(x) == 0) : num_eq_b_7pp(sc, x, int_zero)); -} - -static bool fb_num_eq_s0f(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - return((is_t_real(x)) ? (real(x) == 0.0) : num_eq_b_7pp(sc, x, real_zero)); -} - -static bool fb_gt_tu(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = t_lookup(sc, cadr(expr), expr), y = u_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y)); -} - -static bool fb_gt_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = s_lookup(sc, cadr(expr), expr); - s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y)); -} - -static bool fb_geq_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = s_lookup(sc, cadr(expr), expr); - s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) >= integer(y)) : geq_b_7pp(sc, x, y)); -} - -static bool fb_leq_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = s_lookup(sc, cadr(expr), expr); - s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) <= integer(y)) : leq_b_7pp(sc, x, y)); -} - -static bool fb_leq_ti(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = t_lookup(sc, cadr(expr), expr); - if (is_t_integer(x)) return(integer(x) <= integer(opt2_con(cdr(expr)))); - return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(expr))))); -} - -static bool fb_leq_ui(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = u_lookup(sc, cadr(expr), expr); - if (is_t_integer(x)) return(integer(x) <= integer(opt2_con(cdr(expr)))); - return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(expr))))); -} - -static s7_pointer fx_to_fb(s7_scheme *sc, s7_function fx) /* eventually parallel arrays? */ -{ - if (fx == fx_num_eq_ss) return((s7_pointer)fb_num_eq_ss); - if (fx == fx_lt_ss) return((s7_pointer)fb_lt_ss); - if (fx == fx_lt_ts) return((s7_pointer)fb_lt_ts); - if (fx == fx_gt_ss) return((s7_pointer)fb_gt_ss); - if (fx == fx_leq_ss) return((s7_pointer)fb_leq_ss); - if (fx == fx_leq_ti) return((s7_pointer)fb_leq_ti); - if (fx == fx_leq_ui) return((s7_pointer)fb_leq_ui); - if (fx == fx_geq_ss) return((s7_pointer)fb_geq_ss); - if (fx == fx_gt_tu) return((s7_pointer)fb_gt_tu); - if (fx == fx_num_eq_s0) return((s7_pointer)fb_num_eq_s0); - if (fx == fx_num_eq_s0f) return((s7_pointer)fb_num_eq_s0f); - return(NULL); -} - -static void fb_annotate(s7_scheme *sc, s7_pointer form, s7_pointer fx_expr, opcode_t op) -{ - s7_pointer bfunc; - if ((is_fx_treeable(cdr(form))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(form)); /* and not already treed? just the one expr? */ - bfunc = fx_to_fb(sc, fx_proc(fx_expr)); - if (bfunc) - { - set_opt3_any(cdr(form), bfunc); - pair_set_syntax_op(form, op); - } -#if 0 - /* fb_annotate additions? [these currently require new "B" ops] */ - else - { - fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_80(fx_expr)); - if (caar(fx_expr) == sc->num_eq_symbol) abort(); - /* [fx_leq_ti] fx_lt_t0 fx_gt_ti fx_num_eq_u0 */ - } -#endif -} - -/* when_b cond? do end-test? num_eq_vs|us */ - - -/* ---------------------------------------- for-each ---------------------------------------- */ -static Inline s7_pointer inline_make_counter(s7_scheme *sc, s7_pointer iter) /* all calls are hit about the same: lg/sg */ -{ - s7_pointer x; - new_cell(sc, x, T_COUNTER); - counter_set_result(x, sc->nil); - counter_set_list(x, iter); /* iterator -- here it's always either an iterator or a pair */ - counter_set_capture(x, 0); /* will be capture_let_counter */ - counter_set_let(x, sc->nil); /* will be the saved let */ - counter_set_slots(x, sc->nil); /* local let slots before body is evalled */ - stack_set_has_counters(sc->stack); - return(x); -} - -static s7_pointer make_iterators(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - s7_pointer p = cdr(args); - sc->temp3 = args; - sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */ - for (s7_int i = 2; is_pair(p); p = cdr(p), i++) - { - s7_pointer iter = car(p); - if (!is_iterator(iter)) - { - if (!is_mappable(iter)) - wrong_type_error_nr(sc, caller, i, iter, a_sequence_string); - iter = s7_make_iterator(sc, iter); - } - sc->z = cons(sc, iter, sc->z); - } - sc->temp3 = sc->unused; - return(proper_list_reverse_in_place(sc, sc->z)); -} - -static s7_pointer seq_init(s7_scheme *sc, s7_pointer seq) -{ - if (is_float_vector(seq)) return(real_zero); - if (is_string(seq)) return(chars[65]); - if ((is_int_vector(seq)) || (is_byte_vector(seq))) return(int_zero); - return(sc->F); -} - -#define MUTLIM 32 /* was 1000 */ - -static s7_pointer clear_for_each(s7_scheme *sc) -{ - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - return(sc->unspecified); -} - -static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence arg */ -{ - s7_pointer body = closure_body(f); - if (!no_cell_opt(body)) /* if at top level we often get an unoptimized (not safe) function here that can be cell_optimized below */ - { - s7_pfunc func = NULL; - s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot, res = NULL; - - val = seq_init(sc, seq); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), (is_pair(car(pars))) ? caar(pars) : car(pars), val); - slot = let_slots(sc->curlet); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_optimize_nv(sc, body); - else - if (is_null(cddr(body))) /* 3 sometimes works */ - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ - }} - - if (func) - { - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); - sc->map_call_ctr++; - if (is_pair(seq)) - { - for (s7_pointer x = seq, y = x; is_pair(x); ) - { - slot_set_value(slot, car(x)); - func(sc); - x = cdr(x); - if (is_pair(x)) - { - slot_set_value(slot, car(x)); - func(sc); - x = cdr(x); - y = cdr(y); - if (x == y) break; - }} - res = sc->unspecified; - } - else - if (is_float_vector(seq)) - { - s7_double *vals = float_vector_floats(seq); - s7_int i, len = vector_length(seq); - if ((len > MUTLIM) && - (!tree_has_setters(sc, body))) - { - s7_pointer sv = s7_make_mutable_real(sc, 0.0); - slot_set_value(slot, sv); - if (func == opt_float_any_nv) - { - opt_info *o = sc->opts[0]; - s7_double (*fd)(opt_info *o) = o->v[0].fd; - for (i = 0; i < len; i++) {real(sv) = vals[i]; fd(o);}} - else - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (fp == opt_unless_p_1) - for (i = 0; i < len; i++) {real(sv) = vals[i]; if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1);} - else for (i = 0; i < len; i++) {real(sv) = vals[i]; fp(o);} - } - else for (i = 0; i < len; i++) {real(sv) = vals[i]; func(sc);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} - res = sc->unspecified; - } - else - if (is_int_vector(seq)) - { - s7_int *vals = int_vector_ints(seq); - s7_int i, len = vector_length(seq); - if ((len > MUTLIM) && - (!tree_has_setters(sc, body))) - { - s7_pointer sv = make_mutable_integer(sc, 0); - slot_set_value(slot, sv); - /* since there are no setters, the inner step is also mutable if there is one. - * func=opt_cell_any_nv, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version - */ - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {integer(sv) = vals[i]; fi(o);}} - else for (i = 0; i < len; i++) {integer(sv) = vals[i]; func(sc);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} - res = sc->unspecified; - } - else - if (is_normal_vector(seq)) - { - s7_pointer *vals = vector_elements(seq); - s7_int i, len = vector_length(seq); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); fp(o);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); func(sc);} - res = sc->unspecified; - } - else - if (is_string(seq)) - { - const char *str = string_value(seq); - s7_int len = string_length(seq); - for (s7_int i = 0; i < len; i++) {slot_set_value(slot, chars[(uint8_t)(str[i])]); func(sc);} - res = sc->unspecified; - } - else - if (is_byte_vector(seq)) - { - const uint8_t *vals = (const uint8_t *)byte_vector_bytes(seq); - s7_int i, len = vector_length(seq); - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); fi(o);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); func(sc);} - res = sc->unspecified; - } - if (res) - return(clear_for_each(sc)); - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); - sc->z = s7_make_iterator(sc, seq); - seq = sc->z; - set_stack_protected2_with(sc, seq, OP_MAP_UNWIND); /* GC protect new iterator */ - } - else sc->z = T_Ext(seq); - /* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */ - sc->z = sc->unused; - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - fp(o); - }} - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - fi(o); - }} - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - func(sc); - }} /* we never get here -- the while loops above exit via return # */ - else /* not func -- unneeded "else" but otherwise confusing code */ - { - set_no_cell_opt(body); - set_curlet(sc, old_e); - }} - if ((!is_closure_star(f)) && /* for simplicity in op_for_each_2 (otherwise we need to check for default arg) */ - (is_null(cdr(body))) && - (is_pair(seq))) - { - s7_pointer c = inline_make_counter(sc, seq); - counter_set_result(c, seq); - push_stack(sc, OP_FOR_EACH_2, c, f); - return(sc->unspecified); - } - - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); - sc->z = s7_make_iterator(sc, seq); - } - else sc->z = seq; - push_stack(sc, OP_FOR_EACH_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) -{ - for (s7_pointer fast1 = seq1, slow1 = seq1, fast2 = seq2, slow2 = seq2; (is_pair(fast1)) && (is_pair(fast2)); - fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) - { - slot_set_value(slot1, car(fast1)); - slot_set_value(slot2, car(fast2)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); /* see map_closure_2 below -- stack_protected3 is our temp */ - } - if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) - { - fast1 = cdr(fast1); - if (fast1 == slow1) break; - fast2 = cdr(fast2); - if (fast2 == slow2) break; - slot_set_value(slot1, car(fast1)); - slot_set_value(slot2, car(fast2)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }}} -} - -static void map_or_for_each_closure_vector_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) -{ - s7_int len = vector_length(seq1); - if (len > vector_length(seq2)) len = vector_length(seq2); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot1, vector_getter(seq1)(sc, seq1, i)); - slot_set_value(slot2, vector_getter(seq2)(sc, seq2, i)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }} -} - -static void map_or_for_each_closure_string_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) -{ - s7_int len = string_length(seq1); - const char *s1 = string_value(seq1), *s2 = string_value(seq2); - if (len > string_length(seq2)) len = string_length(seq2); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot1, chars[(uint8_t)(s1[i])]); - slot_set_value(slot2, chars[(uint8_t)(s2[i])]); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }} -} - -static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) -{ - s7_pointer body = closure_body(f); - if (!no_cell_opt(body)) - { - s7_pfunc func = NULL; - s7_pointer olde = sc->curlet, pars = closure_args(f), slot1, slot2; - s7_pointer val1 = seq_init(sc, seq1); - s7_pointer val2 = seq_init(sc, seq2); - sc->curlet = make_let_with_two_slots(sc, closure_let(f), - (is_pair(car(pars))) ? caar(pars) : car(pars), val1, - (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2); - slot1 = let_slots(sc->curlet); - slot2 = next_slot(slot1); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_optimize_nv(sc, body); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); - }} - - if (func) - { - s7_pointer res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); - sc->map_call_ctr++; - if ((is_pair(seq1)) && (is_pair(seq2))) - { - map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, true); - set_curlet(sc, olde); - res = sc->unspecified; - } - else - if ((is_any_vector(seq1)) && (is_any_vector(seq2))) - { - map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, true); - set_curlet(sc, olde); - res = sc->unspecified; - } - else - if ((is_string(seq1)) && (is_string(seq2))) - { - map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, true); - set_curlet(sc, olde); - res = sc->unspecified; - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - set_curlet(sc, olde); - if (res) return(res); - set_no_cell_opt(body); - } - else /* not func */ - { - set_no_cell_opt(body); - set_curlet(sc, olde); - }} - - if (!is_iterator(seq1)) - { - if (!is_mappable(seq1)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); - sc->z = s7_make_iterator(sc, seq1); - } - else sc->z = seq1; - if (!is_iterator(seq2)) - { - if (!is_mappable(seq2)) - wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); - sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2)); - } - else sc->z = list_2(sc, sc->z, seq2); - push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static inline bool for_each_arg_is_null(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = args; - bool got_nil = false; - for (s7_int i = 2; is_pair(p); p = cdr(p), i++) - { - s7_pointer obj = car(p); - if (!is_mappable(obj)) - { - if (is_null(obj)) - got_nil = true; - else wrong_type_error_nr(sc, sc->for_each_symbol, i, obj, a_sequence_string); - }} - return(got_nil); -} - -static s7_pointer g_for_each(s7_scheme *sc, s7_pointer args) -{ - #define H_for_each "(for-each proc object . objects) applies proc to each element of the objects traversed in parallel. \ -Each object can be a list, string, vector, hash-table, or any other sequence." - #define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->is_unspecified_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) - - s7_pointer f = car(args); - s7_int len = proper_list_length(cdr(args)); - bool arity_ok = false; - - /* try the normal case first */ - sc->value = f; - if (is_closure(f)) /* not lambda* that might get confused about arg names */ - { - if ((len == 1) && - (is_pair(closure_args(f))) && - (is_null(cdr(closure_args(f))))) - arity_ok = true; - } - else - if (is_c_object(f)) /* see note in g_map; s7_is_aritable can clobber sc->args=plist=args */ - args = copy_proper_list(sc, args); - else - if (!is_applicable(f)) - return(method_or_bust(sc, f, sc->for_each_symbol, args, something_applicable_string, 1)); - - if ((!arity_ok) && - (!s7_is_aritable(sc, f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "for-each ~A: ~A argument~P?", 27), f, wrap_integer(sc, len), wrap_integer(sc, len))); - - if (for_each_arg_is_null(sc, cdr(args))) return(sc->unspecified); - - /* if function is safe c func, do the for-each locally */ - if (is_safe_c_function(f)) - { - s7_function func; - s7_pointer iters; - - s7_p_p_t fp = s7_p_p_function(f); - if ((fp) && (len == 1)) - { - if (is_pair(cadr(args))) - { - for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - fp(sc, car(fast)); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - fp(sc, car(fast)); - }} - return(sc->unspecified); - } - if (is_any_vector(cadr(args))) - { - s7_pointer v = cadr(args); - s7_int vlen = vector_length(v); - if (is_float_vector(v)) - { - s7_pointer rl = s7_make_mutable_real(sc, 0.0); - sc->temp7 = rl; - for (s7_int i = 0; i < vlen; i++) - { - real(rl) = float_vector(v, i); - fp(sc, rl); - }} - else - if (is_int_vector(v)) - { - s7_pointer iv = make_mutable_integer(sc, 0); - sc->temp7 = iv; - for (s7_int i = 0; i < vlen; i++) - { - integer(iv) = int_vector(v, i); - fp(sc, iv); - }} - else - for (s7_int i = 0; i < vlen; i++) - fp(sc, vector_getter(v)(sc, v, i)); /* LOOP_4 here gains almost nothing */ - return(sc->unspecified); - } - if (is_string(cadr(args))) - { - s7_pointer str = cadr(args); - const char *s = string_value(str); - s7_int slen = string_length(str); - for (s7_int i = 0; i < slen; i++) fp(sc, chars[(uint8_t)(s[i])]); - return(sc->unspecified); - }} - func = c_function_call(f); /* presumably this is either display/write, or method call? */ - sc->z = make_iterators(sc, sc->for_each_symbol, args); - sc->z = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); - push_stack_no_let(sc, OP_GC_PROTECT, sc->args, sc->z); /* temporary GC protection */ - if (len == 1) - { - s7_pointer x = caar(sc->z), y = cdr(sc->z); - sc->z = sc->unused; - while (true) - { - set_car(y, s7_iterate(sc, x)); - if (iterator_is_at_end(x)) - { - /* not pop_stack here since that can clobber sc->code et al, and if this for-each call is - * being treated as safe, fn_proc(for-each) assumes everywhere that sc->code is left alone. - */ - unstack(sc); /* free_cell(sc, x); */ /* 16-Jan-19 */ - return(sc->unspecified); - } - func(sc, y); - }} - iters = sc->z; - sc->z = sc->unused; - while (true) - { - for (s7_pointer x = car(iters), y = cdr(iters); is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) - { - unstack(sc); - return(sc->unspecified); - }} - func(sc, cdr(iters)); - }} - - /* if closure call is straightforward, use OP_FOR_EACH_1 */ - if ((len == 1) && - (((is_closure(f)) && - (closure_arity_to_int(sc, f) == 1) && - (!is_constant_symbol(sc, car(closure_args(f))))) || - ((is_closure_star(f)) && - (closure_star_arity_to_int(sc, f) == 1) && - (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))))) - return(g_for_each_closure(sc, f, cadr(args))); - - push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, make_iterators(sc, sc->for_each_symbol, args), make_list(sc, len, sc->nil)), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static bool op_for_each(s7_scheme *sc) -{ - s7_pointer iterators = car(sc->args); - s7_pointer saved_args = cdr(sc->args); - for (s7_pointer x = saved_args, y = iterators; is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(x, s7_iterate(sc, car(y))); - if (iterator_is_at_end(car(y))) - { - sc->value = sc->unspecified; - free_cell(sc, sc->args); - return(true); - }} - push_stack_direct(sc, OP_FOR_EACH); - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, saved_args) : saved_args; - return(false); -} - -/* for-each et al remake the local let, but that's only needed if the local let is exported, - * and that can only happen through make-closure in various guises and curlet. - * owlet captures, but it would require a deliberate error to use it in this context. - * c_objects call object_set_let but that requires a prior curlet or sublet. So we have - * sc->capture_let_counter that is incremented every time an environment is captured, then - * here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and - * can reuse let. But that reuse assumes no new slots were added (by define etc), because - * update_let* only update the symbol_id's they expect, and that can happen even in op_for_each_2. - */ - -static Inline bool inline_op_for_each_1(s7_scheme *sc) /* called once in eval, case fb gc iter */ -{ - s7_pointer counter = sc->args, code; - s7_pointer p = counter_list(counter); - s7_pointer arg = s7_iterate(sc, p); - if (iterator_is_at_end(p)) - { - sc->value = sc->unspecified; - free_cell(sc, counter); - return(true); - } - code = T_Clo(sc->code); - if (counter_capture(counter) != sc->capture_let_counter) - { - s7_pointer sym = car(closure_args(code)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(code), (is_symbol(sym)) ? sym : car(sym), arg); - counter_set_let(counter, sc->curlet); - counter_set_slots(counter, let_slots(sc->curlet)); - counter_set_capture(counter, sc->capture_let_counter); - } - else - { - let_set_slots(counter_let(counter), counter_slots(counter)); /* this is needed (unless safe_closure but that costs more to check than this set) */ - sc->curlet = update_let_with_slot(sc, counter_let(counter), arg); - } - push_stack(sc, OP_FOR_EACH_1, counter, code); - sc->code = T_Pair(closure_body(code)); - return(false); -} - -static Inline bool inline_op_for_each_2(s7_scheme *sc) /* called once in eval, lg set */ -{ - s7_pointer c = sc->args; - s7_pointer lst = counter_list(c); - if (!is_pair(lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ - { - sc->value = sc->unspecified; - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } - counter_set_list(c, cdr(lst)); - if (sc->cur_op == OP_FOR_EACH_3) - { - counter_set_result(c, cdr(counter_result(c))); - if (counter_result(c) == counter_list(c)) - { - sc->value = sc->unspecified; - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } - push_stack_direct(sc, OP_FOR_EACH_2); - } - else push_stack_direct(sc, OP_FOR_EACH_3); - if (counter_capture(c) != sc->capture_let_counter) - { - sc->curlet = inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_args(sc->code)), car(lst)); - counter_set_let(c, sc->curlet); - counter_set_slots(c, let_slots(sc->curlet)); - counter_set_capture(c, sc->capture_let_counter); - } - else - { - let_set_slots(counter_let(c), counter_slots(c)); - sc->curlet = update_let_with_slot(sc, counter_let(c), car(lst)); - } - sc->code = car(closure_body(sc->code)); - return(false); -} - - -/* ---------------------------------------- map ---------------------------------------- */ - -static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence argument */ -{ - s7_pointer body = closure_body(f); - sc->value = f; - /* fprintf(stderr, "%s[%d]: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); */ - - if (!no_cell_opt(body)) - { - s7_pfunc func = NULL; - s7_pointer old_e = sc->curlet, pars = closure_args(f), slot; - s7_pointer val = seq_init(sc, seq); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), (is_pair(car(pars))) ? caar(pars) : car(pars), val); - slot = let_slots(sc->curlet); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_cell_optimize(sc, body, false); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ - }} - if (func) - { - s7_pointer z, res = NULL; - /* fprintf(stderr, "%s[%d]: push map unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); */ - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); - sc->map_call_ctr++; - if (is_pair(seq)) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - slot_set_value(slot, car(fast)); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - slot_set_value(slot, car(fast)); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - }} - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_float_vector(seq)) - { - s7_double *vals = float_vector_floats(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, make_real(sc, vals[i])); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_int_vector(seq)) - { - s7_int *vals = int_vector_ints(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, make_integer(sc, vals[i])); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_normal_vector(seq)) - { - s7_pointer *vals = vector_elements(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, vals[i]); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_string(seq)) - { - s7_int len = string_length(seq); - const char *str = string_value(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, chars[(uint8_t)(str[i])]); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - if (res) return(res); - } - set_no_cell_opt(body); - set_curlet(sc, old_e); - } - if (is_closure_star(f)) - { - sc->z = make_iterators(sc, sc->map_symbol, set_plist_2(sc, sc->nil, seq)); - push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->nil); - } - if ((is_null(cdr(body))) && - (is_pair(seq))) - { - closure_set_map_list(f, seq); - push_stack(sc, OP_MAP_2, inline_make_counter(sc, seq), f); - return(sc->unspecified); - } - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string); - sc->z = s7_make_iterator(sc, seq); - } - else sc->z = seq; - push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->nil); -} - -static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) /* two sequences */ -{ - s7_pointer body = closure_body(f); - /* fprintf(stderr, "%s[%d]: %" ld64 " %s %s\n", __func__, __LINE__, sc->map_call_ctr, display(seq1), display(seq2)); */ - if (!no_cell_opt(body)) - { - s7_pfunc func = NULL; - s7_pointer old_e = sc->curlet, pars = closure_args(f), slot1, slot2; - s7_pointer val1 = seq_init(sc, seq1); - s7_pointer val2 = seq_init(sc, seq2); - sc->curlet = make_let_with_two_slots(sc, closure_let(f), - (is_pair(car(pars))) ? caar(pars) : car(pars), val1, - (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2); - slot1 = let_slots(sc->curlet); - slot2 = next_slot(slot1); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_cell_optimize(sc, body, false); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); - }} - if (func) - { - s7_pointer res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); - sc->map_call_ctr++; - if ((is_pair(seq1)) && (is_pair(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on stack_protected3 */ - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if ((is_any_vector(seq1)) && (is_any_vector(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false); - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if ((is_string(seq1)) && (is_string(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false); - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - set_curlet(sc, old_e); - if (res) return(res); - set_no_cell_opt(body); - } - else /* not func */ - { - set_no_cell_opt(body); - set_curlet(sc, old_e); - }} - - if (!is_iterator(seq1)) - { - if (!is_mappable(seq1)) - wrong_type_error_nr(sc, sc->map_symbol, 2, seq1, a_sequence_string); - sc->z = s7_make_iterator(sc, seq1); - } - else sc->z = seq1; - if (!is_iterator(seq2)) - { - if (!is_mappable(seq2)) - wrong_type_error_nr(sc, sc->map_symbol, 3, seq2, a_sequence_string); - sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2)); - } - else sc->z = list_2(sc, sc->z, seq2); - - push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static s7_pointer g_map(s7_scheme *sc, s7_pointer args) -{ - #define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \ -a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects." - #define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) - - s7_pointer p, f = car(args); - s7_int len; - bool got_nil = false; - - for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++) - if (!is_mappable(car(p))) - { - if (is_null(car(p))) - got_nil = true; - else wrong_type_error_nr(sc, sc->map_symbol, len + 2, car(p), a_sequence_string); - } - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - case T_C_RST_NO_REQ_FUNCTION: - /* if function is safe c func, do the map locally */ - if (got_nil) return(sc->nil); - if (is_safe_procedure(f)) - { - s7_pointer val, val1, old_args, iter_list; - s7_function func = c_function_call(f); - if (is_pair(cadr(args))) - { - if (len == 1) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - s7_pointer z = fp(sc, car(fast)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - z = fp(sc, car(fast)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - }} - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - if ((len == 2) && (is_pair(caddr(args)))) - { - s7_p_pp_t fp = s7_p_pp_function(f); - if (fp) - { - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - for (s7_pointer fast1 = cadr(args), slow1 = cadr(args), fast2 = caddr(args), slow2 = caddr(args); - (is_pair(fast1)) && (is_pair(fast2)); - fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) - { - s7_pointer z = fp(sc, car(fast1), car(fast2)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) - { - fast1 = cdr(fast1); - if (fast1 == slow1) break; - fast2 = cdr(fast2); - if (fast2 == slow2) break; - z = fp(sc, car(fast1), car(fast2)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - }} - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }}} - if ((is_string(cadr(args))) && (len == 1)) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - s7_pointer str = cadr(args); - const char *s = string_value(str); - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - len = string_length(str); - for (s7_int i = 0; i < len; i++) - { - s7_pointer z = fp(sc, chars[(uint8_t)(s[i])]); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - } - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - if ((is_any_vector(cadr(args))) && (len == 1)) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - s7_pointer vec = cadr(args); - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - len = vector_length(vec); - for (s7_int i = 0; i < len; i++) - { - s7_pointer z = fp(sc, vector_getter(vec)(sc, vec, i)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - } - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - - sc->z = make_iterators(sc, sc->map_symbol, args); - val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); - iter_list = sc->z; - old_args = sc->args; - push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ - sc->z = sc->unused; - while (true) - { - s7_pointer z; - for (s7_pointer x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) - { - unstack(sc); /* free_cell(sc, car(x)); */ /* 16-Jan-19 iterator in circular list -- see s7test */ - sc->args = T_Pos(old_args); /* can be # */ - return(proper_list_reverse_in_place(sc, car(val))); - }} - z = func(sc, cdr(val1)); /* multiple-values? values is unsafe, but s7_values used externally and claims to be safe? */ /* func = c_function_call(f) */ - if (z != sc->no_value) - set_car(val, cons(sc, z, car(val))); - }} - - else /* not safe procedure */ - if ((f == global_value(sc->values_symbol)) && - (len == 1) && - (!has_methods(cadr(args)))) /* iterator should be ok here -- object_to_list can handle it */ - { - p = object_to_list(sc, cadr(args)); - if (p != cadr(args)) - return(p); - } - break; - - case T_CLOSURE: - case T_CLOSURE_STAR: - { - int32_t fargs = (is_closure(f)) ? closure_arity_to_int(sc, f) : closure_star_arity_to_int(sc, f); - if ((len == 1) && - (fargs == 1) && - (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))) - { - if (got_nil) return(sc->nil); - if (is_closure_star(f)) - return(g_map_closure(sc, f, cadr(args))); - - /* don't go to OP_MAP_2 here! It assumes no recursion */ - sc->z = (!is_iterator(cadr(args))) ? s7_make_iterator(sc, cadr(args)) : cadr(args); - push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - symbol_increment_ctr(car(closure_args(f))); - return(sc->nil); - } - if (((fargs >= 0) && (fargs < len)) || - ((is_closure(f)) && (abs(fargs) > len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - if (got_nil) return(sc->nil); - } - break; - - case T_C_OBJECT: - /* args if sc->args (plist + c_object) can be clobbered here by s7_is_aritable, so we need to protect it */ - args = copy_proper_list(sc, args); - sc->temp10 = args; - - default: - if (!is_applicable(f)) - return(method_or_bust(sc, f, sc->map_symbol, args, something_applicable_string, 1)); - if ((!is_pair(f)) && - (!s7_is_aritable(sc, f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - if (got_nil) return(sc->nil); - break; - } - - sc->z = make_iterators(sc, sc->map_symbol, args); - push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->nil); -} - -static bool op_map(s7_scheme *sc) -{ - s7_pointer iterators = counter_list(sc->args); - sc->x = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */ - for (s7_pointer y = iterators; is_pair(y); y = cdr(y)) - { - s7_pointer x = s7_iterate(sc, car(y)); - if (iterator_is_at_end(car(y))) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(sc->args)); - free_cell(sc, sc->args); /* not sc->args = sc->nil; */ - return(true); - } - sc->x = cons(sc, x, sc->x); - } - sc->x = proper_list_reverse_in_place(sc, sc->x); - push_stack_direct(sc, OP_MAP_GATHER); - sc->args = sc->x; - sc->x = sc->unused; - if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); - return(false); -} - -static bool op_map_1(s7_scheme *sc) -{ - s7_pointer args = sc->args, code = sc->code; - s7_pointer p = counter_list(args); - s7_pointer x = s7_iterate(sc, p); - - if (iterator_is_at_end(p)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(args)); - free_cell(sc, sc->args); /* not sc->args = sc->nil; */ - return(true); - } - push_stack_direct(sc, OP_MAP_GATHER_1); - if (counter_capture(args) != sc->capture_let_counter) - { - sc->curlet = inline_make_let_with_slot(sc, closure_let(code), car(closure_args(code)), x); - counter_set_let(args, sc->curlet); - counter_set_slots(args, let_slots(sc->curlet)); - counter_set_capture(args, sc->capture_let_counter); - } - else - { - /* the counter_slots field saves the original local let slot(s) representing the function - * argument. If the function has internal defines, they get added to the front of the - * slots list, but update_let_with_slot (maybe stupidly) assumes only the one original - * slot exists when it updates its symbol_id from the (possibly changed) let_id. So, - * a subsequent reference to the parameter name causes "unbound variable", or a segfault - * if the check has been optimized away. I think each function call should start with - * the original let slots, so counter_slots saves that pointer, and resets it here. - */ - let_set_slots(counter_let(args), counter_slots(args)); - sc->curlet = update_let_with_slot(sc, counter_let(args), x); - } - sc->code = T_Pair(closure_body(code)); - return(false); -} - -static bool op_map_2(s7_scheme *sc) /* possibly inline lg */ -{ - s7_pointer x, c = sc->args, code = sc->code; - s7_pointer p = counter_list(c); - if (!is_pair(p)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(c)); - free_cell(sc, sc->args); /* not sc->args = sc->nil; */ - return(true); - } - x = car(p); - counter_set_list(c, cdr(p)); - - if (sc->cur_op == OP_MAP_GATHER_3) - { - closure_set_map_list(code, cdr(closure_map_list(code))); - /* this depends on code (the function) being non-recursive, else closure_setter gets stepped on */ - if (closure_map_list(code) == counter_list(c)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(c)); - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } - push_stack_direct(sc, OP_MAP_GATHER_2); - } - else push_stack_direct(sc, OP_MAP_GATHER_3); - - if (counter_capture(c) != sc->capture_let_counter) - { - sc->curlet = inline_make_let_with_slot(sc, closure_let(code), car(closure_args(code)), x); - counter_set_let(c, sc->curlet); - counter_set_slots(c, let_slots(sc->curlet)); - counter_set_capture(c, sc->capture_let_counter); - } - else - { - let_set_slots(counter_let(c), counter_slots(c)); /* needed -- see comment under for-each above */ - sc->curlet = update_let_with_slot(sc, counter_let(c), x); - } - sc->code = car(closure_body(code)); - return(false); -} - -static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list (in op_map_gather) */ - s7_pointer p = b; - if (is_not_null(a)) - { - a = copy_proper_list(sc, a); - do { - s7_pointer q = cdr(a); - set_cdr(a, p); - p = a; - a = q; - } while (is_pair(a)); - } - return(p); -} - -static Inline void inline_op_map_gather(s7_scheme *sc) /* called thrice in eval, cb lg map */ -{ - if (sc->value != sc->no_value) - { - if (is_multiple_value(sc->value)) - counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); - else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); - } -} - - -/* -------------------------------- multiple-values -------------------------------- */ -static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) -{ - int64_t top = current_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */ - s7_pointer x; - if (SHOW_EVAL_OPS) - safe_print(fprintf(stderr, "%s[%d]: splice %s %s\n", __func__, __LINE__, - (top > 0) ? op_names[stack_op(sc->stack, top)] : "no stack!", display_80(args))); - if ((S7_DEBUGGING) && ((is_null(args)) || (is_null(cdr(args))))) fprintf(stderr, "%s: %s\n", __func__, display(args)); - - switch (stack_op(sc->stack, top)) - { - /* the normal case -- splice values into caller's args */ - case OP_EVAL_ARGS1: case OP_EVAL_ARGS2: case OP_EVAL_ARGS3: case OP_EVAL_ARGS4: - /* code = args yet to eval in order, args = evalled args reversed. - * it is not safe to simply reverse args and tack the current stacked args onto its (new) end, - * setting stacked args to cdr of reversed-args and returning car because the list (args) - * can be some variable's value in a macro expansion via ,@ and reversing it in place - * (all this to avoid consing), clobbers the variable's value. - */ - sc->w = args; - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); - sc->w = sc->unused; - return(car(x)); - - /* in the next set, the main evaluator branches blithely assume no multiple-values, - * and if it happens anyway, we go to a different branch here - */ - case OP_ANY_CLOSURE_NP_2: - stack_element(sc->stack, top) = (s7_pointer)OP_ANY_CLOSURE_NP_MV; - goto FP_MV; - - case OP_ANY_C_NP_2: - stack_element(sc->stack, top) = (s7_pointer)OP_ANY_C_NP_MV; - goto FP_MV; - - case OP_ANY_C_NP_1: case OP_ANY_CLOSURE_NP_1: - stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 1); /* replace with mv version */ - - case OP_ANY_C_NP_MV: case OP_ANY_CLOSURE_NP_MV: - FP_MV: - if ((is_immutable(args)) || /* (let () (define (func) (with-output-to-string (lambda () (apply-values (write '(1 2)))))) (func) (func)) */ - (needs_copied_args(args))) - { - clear_needs_copied_args(args); - args = copy_proper_list(sc, args); - } - set_multiple_value(args); - return(args); - - case OP_SAFE_C_SSP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SSP_MV; - return(args); - - case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: case OP_SAFE_ADD_SP_1: case OP_SAFE_MULTIPLY_SP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SP_MV; - return(args); - - case OP_SAFE_C_PS_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PS_MV; - return(args); - - case OP_SAFE_C_PC_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PC_MV; - return(args); - - case OP_SAFE_C_PA_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PA_MV; - return(args); - - case OP_C_P_1: case OP_SAFE_C_P_1: - stack_element(sc->stack, top) = (s7_pointer)OP_C_P_MV; - return(args); - - case OP_C_AP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_C_AP_MV; - /* sc->value = args; */ /* removed 29-Mar-22 -- seems redundant */ - return(args); - - case OP_SAFE_CLOSURE_P_1: case OP_CLOSURE_P_1: case OP_SAFE_CLOSURE_P_A_1: - case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1: - case OP_SAFE_CLOSURE_PP_1: case OP_CLOSURE_PP_1: - case OP_SAFE_CLOSURE_PA_1: case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_closure_sym) */ - case OP_ANY_CLOSURE_3P_1: case OP_ANY_CLOSURE_3P_2: case OP_ANY_CLOSURE_3P_3: - case OP_ANY_CLOSURE_4P_1: case OP_ANY_CLOSURE_4P_2: case OP_ANY_CLOSURE_4P_3: case OP_ANY_CLOSURE_4P_4: - if (is_multiple_value(sc->value)) clear_multiple_value(sc->value); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, too_many_arguments_string, stack_code(sc->stack, top), sc->value)); - - case OP_SAFE_C_PP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_3_MV; - return(args); - - case OP_SAFE_C_PP_5: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_6_MV; - return(args); - - case OP_SAFE_C_3P_1: case OP_SAFE_C_3P_2: case OP_SAFE_C_3P_3: - stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 3); - case OP_SAFE_C_3P_1_MV: case OP_SAFE_C_3P_2_MV: case OP_SAFE_C_3P_3_MV: - return(cons(sc, sc->unused, copy_proper_list(sc, args))); - - case OP_EVAL_ARGS5: - /* code = previous arg saved, args = ante-previous args reversed, we'll take value->code->args and reverse in args5 */ - if (is_null(args)) - return(sc->unspecified); - if (is_null(cdr(args))) - return(car(args)); - - stack_args(sc->stack, top) = cons(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); - for (x = args; is_not_null(cddr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); - stack_code(sc->stack, top) = car(x); - return(cadr(x)); - - /* look for errors here rather than glomming up the set! and let code */ - case OP_SET_SAFE: /* symbol is sc->code after pop */ - case OP_SET1: - case OP_SET_FROM_LET_TEMP: /* (set! var (values 1 2 3)) */ - case OP_SET_FROM_SETTER: - syntax_error_with_caller_nr(sc, "set!: can't set ~A to ~S", 24, stack_code(sc->stack, top), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_SET_opSAq_P_1: case OP_SET_opSAAq_P_1: - syntax_error_nr(sc, "too many values to set! ~S", 26, set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LET1: /* (let ((var (values 1 2 3))) ...) */ - { - s7_pointer let_code, vars, sym, p = stack_args(sc->stack, top); - for (let_code = p; is_pair(cdr(let_code)); let_code = cdr(let_code)); - for (vars = caar(let_code); is_pair(cdr(p)); p = cdr(p), vars = cdr(vars)); - sym = caar(vars); - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, sym, set_ulist_1(sc, sc->values_symbol, args)); - /* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x) - * (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x) - */ - } - - case OP_LET_ONE_NEW_1: case OP_LET_ONE_P_NEW_1: - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - opt2_sym(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LET_ONE_OLD_1: case OP_LET_ONE_P_OLD_1: - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - slot_symbol(let_slots(opt3_let(stack_code(sc->stack, top)))), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, - caar(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LETREC1: /* here sc->args is the slot about to receive a value */ - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_symbol, - slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LETREC_STAR1: - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_star_symbol, - slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_AND_P1: - case OP_AND_SAFE_P_REST: /* from OP_AND_SAFE_P1 or P2 */ - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - if (car(x) == sc->F) - return(sc->F); - return(car(x)); - - case OP_OR_P1: - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - if (car(x) != sc->F) - return(car(x)); - return(car(x)); - - case OP_IF1: /* (if (values ...) ...) -- see s7.html at the end of the values writeup for explanation (we're following CL here) */ - case OP_IF_PP: case OP_IF_PPP: case OP_IF_PR: case OP_IF_PRR: - case OP_WHEN_PP: case OP_UNLESS_PP: case OP_WITH_LET1: - case OP_CASE_G_G: case OP_CASE_G_S: case OP_CASE_E_G: case OP_CASE_E_S: case OP_CASE_I_S: - case OP_COND1: case OP_COND1_SIMPLE: - return(car(args)); - - case OP_IF_PN: /* (if|when (not (values...)) ...) as opposed to (if|unless (values...)...) which follows CL and drops trailing values */ - syntax_error_nr(sc, "too many arguments to not: ~S", 29, set_ulist_1(sc, sc->values_symbol, args)); - - case OP_DYNAMIC_UNWIND: case OP_DYNAMIC_UNWIND_PROFILE: - { - s7_pointer old_value = sc->value; - bool mv = is_multiple_value(args); - if (mv) clear_multiple_value(args); - sc->value = cons(sc, sc->values_symbol, args); - dynamic_unwind(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); /* position (curlet), this applies code to sc->value */ - sc->value = old_value; - if (mv) set_multiple_value(args); - sc->stack_end -= 4; /* either op is possible I think */ - return(splice_in_values(sc, args)); - } - - case OP_BARRIER: - pop_stack(sc); - return(splice_in_values(sc, args)); - - case OP_GC_PROTECT: - sc->stack_end -= 4; - return(splice_in_values(sc, args)); - - case OP_BEGIN_HOOK: case OP_BEGIN_NO_HOOK: case OP_BEGIN_2_UNCHECKED: - case OP_SIMPLE_DO_STEP: case OP_DOX_STEP_O: case OP_DOX_STEP: - /* here we have a values call with nothing to splice into. So flush it... - * otherwise the multiple-values bit gets set in some innocent list and never unset: - * (let ((x '((1 2)))) (eval `(apply apply values x)) x) -> ((values 1 2)) - * other cases: (+ 1 (begin (values 5 6) (values 2 3)) 4) -> 10 -- the (5 6) is dropped - * (let () (values 1 2 3) 4) but (+ (let () (values 1 2))) -> 3 - */ - return(args); - - case OP_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */ - call_exit_active(stack_args(sc->stack, top)) = false; - - case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: case OP_CATCH_ALL: /* (+ (catch #t (lambda () (values 3 4)) (lambda args args))) */ - pop_stack(sc); - return(splice_in_values(sc, args)); - - case OP_EXPANSION: - /* we get here if a reader-macro (define-expansion) returns multiple values. - * these need to be read in order into the current reader lists (we'll assume OP_READ_LIST is next in the stack. - * and that it will be expecting the next arg entry in sc->value). - */ - top -= 4; - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); - pop_stack(sc); /* need GC protection in loop above, so do this afterwards */ - return(car(x)); /* sc->value from OP_READ_LIST point of view */ - - case OP_EVAL_DONE: - if (stack_op(sc->stack, (top - 4)) == OP_NO_VALUES) - error_nr(sc, sc->error_symbol, - set_elist_1(sc, wrap_string(sc, "function-port should not return multiple-values", 47))); - stack_element(sc->stack, top) = (s7_pointer)OP_SPLICE_VALUES; /* tricky -- continue from eval_done with the current splice */ - stack_args(sc->stack, top) = args; - push_stack_op(sc, OP_EVAL_DONE); - return(args); - - default: - /* fprintf(stderr, "%s[%d]: splice on: %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)]); */ - break; - } - - /* let it meander back up the call chain until someone knows where to splice it - * the is_immutable check protects against setting the multiple value bit on (say) sc->hash_table_signature - */ - if (is_immutable(args)) - args = copy_proper_list(sc, args); /* copy needed else (apply values x) where x is a list can leave the mv bit on for x's value */ - if (needs_copied_args(args)) - { - clear_needs_copied_args(args); - args = copy_proper_list(sc, args); - } - set_multiple_value(args); - return(args); -} - - -/* -------------------------------- values -------------------------------- */ -s7_pointer s7_values(s7_scheme *sc, s7_pointer args) -{ - #define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')" - #define Q_values s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) - - if (is_null(args)) /* ((lambda () (let ((x 1)) (set! x (boolean? (values)))))) */ - return(sc->no_value); - if (is_null(cdr(args))) - return(car(args)); - set_needs_copied_args(args); - /* copy needed: see s7test (test `(,x ,@y ,x) '(3 a b c 3)) -> (append (list-values x (apply-values y)) x), and apply_values calls s7_values directly */ - return(splice_in_values(sc, args)); -} - -#define g_values s7_values - -static s7_pointer values_p(s7_scheme *sc) {return(sc->no_value);} -static s7_pointer values_p_p(s7_scheme *unused_sc, s7_pointer p) {return(p);} - -static s7_pointer values_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args > 1) return(sc->values_uncopied); /* splice_in_values */ - return(f); -} - -bool s7_is_multiple_value(s7_pointer obj) {return(is_multiple_value(obj));} - - -/* -------------------------------- list-values -------------------------------- */ -static s7_pointer splice_out_values(s7_scheme *sc, s7_pointer args) -{ - s7_pointer tp; - while (car(args) == sc->no_value) {args = cdr(args); if (is_null(args)) return(sc->nil);} - tp = list_1(sc, car(args)); - sc->temp8 = tp; - for (s7_pointer p = cdr(args), np = tp; is_pair(p); p = cdr(p)) - if (car(p) != sc->no_value) - { - set_cdr(np, list_1(sc, car(p))); - np = cdr(np); - } - sc->temp8 = sc->unused; - return(tp); -} - -static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) -{ - #define H_list_values "(list-values ...) returns its arguments in a list (internal to quasiquote)" - #define Q_list_values s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T) - - /* list-values can't be replaced by list(-n) because (list-values (values)) -> () and anything can be # (see s7test) */ - /* but (list-values ) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */ - - s7_pointer x; - bool checked = false; - for (x = args; is_pair(x); x = cdr(x)) - if (is_pair(car(x))) - { - if (is_checked(car(x))) - checked = true; - } - else - if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ - break; - if (is_null(x)) - { - if (!checked) /* (!tree_has_definers(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */ - { - for (s7_pointer p = args; is_pair(p); p = cdr(p)) /* embedded list can be immutable, so we need to copy (sigh) */ - if (is_immutable(p)) - return(copy_proper_list(sc, args)); - return(args); - } - sc->temp5 = args; - check_free_heap_size(sc, 8192); - if (sc->safety > NO_SAFETY) - { - if (!tree_is_cyclic(sc, args)) /* we're copying to clear optimizations I think, and a cyclic list here can't be optimized */ - args = cons_unchecked(sc, /* since list-values is a safe function, args can be immutable, which should not be passed through the copy */ - (is_unquoted_pair(car(args))) ? copy_tree_with_type(sc, car(args)) : car(args), - (is_unquoted_pair(cdr(args))) ? copy_tree_with_type(sc, cdr(args)) : cdr(args)); - } - else args = copy_tree(sc, args); /* not copy_any_list here -- see comment below */ - sc->temp5 = sc->unused; - return(args); - } - /* if a macro expands into a recursive function with a macro argument as its body (or reasonable facsimile thereof), - * and the safety (as in safe_closure) of the body changes from safe to unsafe, then (due to the checked bits - * protecting against cycles in optimize_expression|syntax), the possible safe_closure call will not be fixed, - * the safe_closure's assumption about the saved local let will be violated, and we'll get " unbound" (see tgen.scm). - * clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows - * everything down intolerably, so if the checked bit is on in a macro expansion, that means we're re-expanding this macro, - * and therefore have to copy the tree. But isn't that only the case if the macro expands into closures? - */ - return(splice_out_values(sc, args)); -} - -static s7_pointer g_simple_list_values(s7_scheme *sc, s7_pointer args) -{ - /* if just (code-)constant/symbol, symbol->pair won't be checked (not optimized/re-expanded code), but might be no-values */ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - if (car(p) == sc->no_value) - return(splice_out_values(sc, args)); - if (is_immutable(args)) - return(copy_proper_list(sc, args)); - return(args); -} - -static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && (caar(p) != sc->quote_symbol)) - return(f); - return(sc->simple_list_values); -} - - -/* -------------------------------- apply-values -------------------------------- */ -static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args) -{ - #define H_apply_values "(apply-values var) applies values to var. This is an internal function." - #define Q_apply_values s7_make_signature(sc, 2, sc->T, sc->is_list_symbol) - s7_pointer x; - /* apply-values takes 1 arg: ,@a -> (apply-values a) */ - if (is_null(args)) - return(sc->no_value); - x = car(args); - if (is_null(x)) - return(sc->no_value); - if (!s7_is_proper_list(sc, x)) - apply_list_error_nr(sc, args); - return(g_values(sc, x)); -} - -/* (apply values ...) replaces (unquote_splicing ...) - * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a) - * (define-macro (hi a) `(+ 1 ,@a) == (list '+ 1 (apply values a)) - * - * this is not the same as CL's quasiquote; for example: - * [1]> (let ((a 1) (b 2)) `(,a ,@b)) -> '(1 . 2) but in s7 this is an error. - * also in CL the target of ,@ can apparently be a circular list - * one surprising twist: write/display return their first argument directly, so (apply-values (write `(+ x 1))) is the same as (apply-values `(+ x 1)) - */ - - -/* -------------------------------- quasiquote -------------------------------- */ -static bool is_simple_code(s7_scheme *sc, s7_pointer form) -{ - /* if nested with quasiquotes say 20 levels, this is really slow, but to tag intermediate results burns up 2 type bits */ - s7_pointer tmp, slow; - for (tmp = form, slow = form; is_pair(tmp); tmp = cdr(tmp), slow = cdr(slow)) - { - if (is_pair(car(tmp))) - { - if (!is_simple_code(sc, car(tmp))) - return(false); - } - else - if (car(tmp) == sc->unquote_symbol) - return(false); - tmp = cdr(tmp); - if (!is_pair(tmp)) return(is_null(tmp)); - if (tmp == slow) return(false); - if (is_pair(car(tmp))) - { - if (!is_simple_code(sc, car(tmp))) - return(false); - } - else - if (car(tmp) == sc->unquote_symbol) - return(false); - } - return(is_null(tmp)); -} - -/* since the reader expands unquote et al, and the printer does not unexpand them, the standard scheme quine in s7 is: - * ((lambda (x) (list-values x (list-values 'quote x))) '(lambda (x) (list-values x (list-values 'quote x)))) - * but that depends on the "p" in repl... - */ - -static s7_pointer g_quasiquote_1(s7_scheme *sc, s7_pointer form, bool check_cycles) -{ - #define H_quasiquote "(quasiquote arg) is the same as `arg. If arg is a list, it can contain \ -comma (\"unquote\") and comma-atsign (\"apply values\") to pre-evaluate portions of the list. \ -unquoted expressions are evaluated and plugged into the list, apply-values evaluates the expression \ -and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -> (1 2 3 4)." - - if (!is_pair(form)) - { - if (is_normal_symbol(form)) - return(list_2(sc, (is_global(sc->quote_symbol)) ? sc->quote_symbol : initial_value(sc->quote_symbol), form)); - /* things that evaluate to themselves don't need to be quoted */ - return(form); - } - if (car(form) == sc->unquote_symbol) - { - if (!is_pair(cdr(form))) /* (unquote) or (unquote . 1) */ - { - if (is_null(cdr(form))) - syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); - syntax_error_nr(sc, "unquote: stray dot, ~S", 22, form); - } - if (is_not_null(cddr(form))) - syntax_error_nr(sc, "unquote: too many arguments, ~S", 31, form); - return(cadr(form)); - } - - /* it's a list, so return the list with each element handled as above. - * we try to support dotted lists which makes the code much messier. - * if no element of the list is a list or unquote, just return the original quoted - */ - if (((check_cycles) && (tree_is_cyclic(sc, form))) || - (is_simple_code(sc, form))) - /* we can't lookup sc->quote_symbol because this gets called in op_read_quasiquote (at read-time), and sc->curlet can be junk in that context */ - return(list_2(sc, (is_global(sc->quote_symbol)) ? sc->quote_symbol : initial_value(sc->quote_symbol), form)); - - { - s7_int i; - s7_pointer orig, bq, old_scw = sc->w; /* very often, sc->w is in use here */ - bool dotted = false; - s7_int len = s7_list_length(sc, form); - if (len < 0) - { - len = -len; - dotted = true; - } - s7_gc_protect_via_stack(sc, sc->w); - - check_free_heap_size(sc, len + 1); - sc->w = sc->nil; - for (i = 0; i <= len; i++) - sc->w = cons_unchecked(sc, sc->nil, sc->w); - - set_car(sc->w, sc->list_values_symbol); - if (!dotted) - { - for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) - if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */ - (cadr(orig) == sc->unquote_symbol)) /* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2) etc */ - { - if (!is_pair(cddr(orig))) - { - sc->w = old_scw; - unstack(sc); - syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); - } - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - set_cdr(bq, sc->nil); - sc->w = list_3(sc, sc->qq_append_symbol, sc->w, caddr(orig)); /* `(f . ,(string-append "h" "i")) */ - break; - } - else set_car(bq, g_quasiquote_1(sc, car(orig), false)); - } - else /* `(1 2 . 3) */ - { - len--; - for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - sc->w = list_3(sc, sc->qq_append_symbol, sc->w, g_quasiquote_1(sc, cdr(orig), false)); - /* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */ - } - bq = sc->w; - sc->w = old_scw; - unstack(sc); - return(bq); - } -} - -static s7_pointer g_quasiquote(s7_scheme *sc, s7_pointer args) -{ - /* this is for explicit quasiquote support, not the backquote stuff in macros - * but it is problematic. g_quasiquote_1 above expands (for example) `(+ ,x) into (list (quote +) x), - * so (multiple-value-bind (quote) quasiquote `(+ ,x)) expands to ((lambda (quote) (list '+ x)) quasiquote) - * which is an infinite loop. Guile says syntax error (because it thinks "quote" can't be a parameter name, I think). - */ - return(g_quasiquote_1(sc, car(args), true)); -} - -static s7_pointer g_qq_append(s7_scheme *sc, s7_pointer args) -{ - #define H_qq_append "[list*]: CL list* (I think) for quasiquote's internal use" - #define Q_qq_append s7_make_circular_signature(sc, 0, 1, sc->T) - s7_pointer a = car(args), b = cadr(args); - s7_pointer p, tp, np; - if (is_null(a)) return(b); - p = cdr(a); - if (is_null(p)) return(cons(sc, car(a), b)); - tp = list_1(sc, car(a)); - s7_gc_protect_via_stack(sc, tp); - for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, list_1(sc, car(p))); - set_cdr(np, b); - unstack(sc); - return(tp); -} - - -/* -------------------------------- choosers -------------------------------- */ -static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg) -{ - s7_pointer uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); - s7_function_set_class(sc, uf, cls); - c_function_signature(uf) = c_function_signature(cls); - return(uf); -} - -static s7_pointer make_unsafe_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg) -{ - s7_pointer uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); /* was s7_make_safe_function! 14-Dec-20 */ - s7_function_set_class(sc, uf, cls); - c_function_signature(uf) = c_function_signature(cls); - return(uf); -} - -static s7_pointer set_function_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops)) -{ - s7_pointer f = global_value(sym); - c_function_chooser(f) = chooser; - return(f); -} - -static void init_choosers(s7_scheme *sc) -{ - s7_pointer f; - - /* + */ - f = set_function_chooser(sc->add_symbol, add_chooser); - sc->add_class = c_function_class(f); - sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false); - sc->add_3 = make_function_with_class(sc, f, "+", g_add_3, 3, 0, false); - sc->add_1x = make_function_with_class(sc, f, "+", g_add_1x, 2, 0, false); - sc->add_x1 = make_function_with_class(sc, f, "+", g_add_x1, 2, 0, false); - sc->add_i_random = make_function_with_class(sc, f, "+", g_add_i_random, 2, 0, false); - sc->add_2_ff = make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false); - sc->add_2_ii = make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false); - sc->add_2_if = make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false); - sc->add_2_fi = make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false); - sc->add_2_xi = make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false); - sc->add_2_ix = make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false); - sc->add_2_fx = make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false); - sc->add_2_xf = make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false); - - /* - */ - f = set_function_chooser(sc->subtract_symbol, subtract_chooser); - sc->subtract_class = c_function_class(f); - sc->subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false); - sc->subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false); - sc->subtract_3 = make_function_with_class(sc, f, "-", g_subtract_3, 3, 0, false); - sc->subtract_x1 = make_function_with_class(sc, f, "-", g_subtract_x1, 2, 0, false); - sc->subtract_2f = make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false); - sc->subtract_f2 = make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false); - - /* * */ - f = set_function_chooser(sc->multiply_symbol, multiply_chooser); - sc->multiply_class = c_function_class(f); - sc->multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false); - sc->mul_2_ff = make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false); - sc->mul_2_ii = make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false); - sc->mul_2_if = make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false); - sc->mul_2_fi = make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false); - sc->mul_2_xi = make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false); - sc->mul_2_ix = make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false); - sc->mul_2_fx = make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false); - sc->mul_2_xf = make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false); - - /* / */ - f = set_function_chooser(sc->divide_symbol, divide_chooser); - sc->invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false); - sc->divide_2 = make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false); - sc->invert_x = make_function_with_class(sc, f, "/", g_invert_x, 2, 0, false); - sc->divide_by_2 = make_function_with_class(sc, f, "/", g_divide_by_2, 2, 0, false); - - /* = */ - f = set_function_chooser(sc->num_eq_symbol, num_eq_chooser); - sc->num_eq_class = c_function_class(f); - sc->num_eq_2 = make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false); - sc->num_eq_xi = make_function_with_class(sc, f, "=", g_num_eq_xi, 2, 0, false); - sc->num_eq_ix = make_function_with_class(sc, f, "=", g_num_eq_ix, 2, 0, false); - - /* min */ - f = set_function_chooser(sc->min_symbol, min_chooser); - sc->min_2 = make_function_with_class(sc, f, "min", g_min_2, 2, 0, false); - sc->min_3 = make_function_with_class(sc, f, "min", g_min_3, 3, 0, false); - - /* max */ - f = set_function_chooser(sc->max_symbol, max_chooser); - sc->max_2 = make_function_with_class(sc, f, "max", g_max_2, 2, 0, false); - sc->max_3 = make_function_with_class(sc, f, "max", g_max_3, 3, 0, false); - - /* < */ - f = set_function_chooser(sc->lt_symbol, less_chooser); - sc->less_xi = make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false); - sc->less_x0 = make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false); - sc->less_xf = make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false); - sc->less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false); - - /* > */ - f = set_function_chooser(sc->gt_symbol, greater_chooser); - sc->greater_xi = make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false); - sc->greater_xf = make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false); - sc->greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false); - - /* <= */ - f = set_function_chooser(sc->leq_symbol, leq_chooser); - sc->leq_xi = make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false); - sc->leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false); - sc->leq_ixx = make_function_with_class(sc, f, "<=", g_leq_ixx, 3, 0, false); - - /* >= */ - f = set_function_chooser(sc->geq_symbol, geq_chooser); - sc->geq_xi = make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false); - sc->geq_xf = make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false); - sc->geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false); - - /* log */ - f = set_function_chooser(sc->log_symbol, log_chooser); - sc->int_log2 = make_function_with_class(sc, f, "log", g_int_log2, 2, 0, false); - - /* random */ - f = set_function_chooser(sc->random_symbol, random_chooser); - sc->random_1 = make_function_with_class(sc, f, "random", g_random_1, 1, 0, false); - sc->random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false); - sc->random_f = make_function_with_class(sc, f, "random", g_random_f, 1, 0, false); - - /* defined? */ - f = set_function_chooser(sc->is_defined_symbol, is_defined_chooser); - sc->is_defined_in_rootlet = make_function_with_class(sc, f, "defined?", g_is_defined_in_rootlet, 2, 0, false); - - /* char=? */ - f = set_function_chooser(sc->char_eq_symbol, char_equal_chooser); - sc->simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false); - sc->char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false); - - /* char>? */ - f = set_function_chooser(sc->char_gt_symbol, char_greater_chooser); - sc->char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false); - - /* charchar_lt_symbol, char_less_chooser); - sc->char_less_2 = make_function_with_class(sc, f, "charread_char_symbol, read_char_chooser); - sc->read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false); - - /* char-position */ - f = set_function_chooser(sc->char_position_symbol, char_position_chooser); - sc->char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false); - - /* string=? */ - f = set_function_chooser(sc->string_eq_symbol, string_equal_chooser); - sc->string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false); - sc->string_equal_2c = make_function_with_class(sc, f, "string=?", g_string_equal_2c, 2, 0, false); - - /* substring */ - sc->substring_uncopied = s7_make_safe_function(sc, "substring", g_substring_uncopied, 2, 1, false, NULL); - s7_function_set_class(sc, sc->substring_uncopied, global_value(sc->substring_symbol)); - - /* string>? */ - f = set_function_chooser(sc->string_gt_symbol, string_greater_chooser); - sc->string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false); - - /* stringstring_lt_symbol, string_less_chooser); - sc->string_less_2 = make_function_with_class(sc, f, "stringstring_symbol, string_chooser); - sc->string_c1 = make_function_with_class(sc, f, "string", g_string_c1, 1, 0, false); - - /* string-append */ - f = set_function_chooser(sc->string_append_symbol, string_append_chooser); - sc->string_append_2 = make_function_with_class(sc, f, "string-append", g_string_append_2, 2, 0, false); - - /* string-ref et al */ - set_function_chooser(sc->string_ref_symbol, string_substring_chooser); - set_function_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here */ - set_function_chooser(sc->string_to_keyword_symbol, string_substring_chooser); - set_function_chooser(sc->string_downcase_symbol, string_substring_chooser); - set_function_chooser(sc->string_upcase_symbol, string_substring_chooser); - /* if the function assumes a null-terminated string, substring needs to return a copy */ -#if (!WITH_PURE_S7) - set_function_chooser(sc->string_length_symbol, string_substring_chooser); - set_function_chooser(sc->string_to_list_symbol, string_substring_chooser); -#endif - set_function_chooser(sc->string_copy_symbol, string_copy_chooser); - - /* symbol->string */ - f = global_value(sc->symbol_to_string_symbol); - sc->symbol_to_string_uncopied = s7_make_safe_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL); - s7_function_set_class(sc, sc->symbol_to_string_uncopied, f); - - /* display */ - f = set_function_chooser(sc->display_symbol, display_chooser); - sc->display_f = make_function_with_class(sc, f, "display", g_display_f, 2, 0, false); - sc->display_2 = make_function_with_class(sc, f, "display", g_display_2, 2, 0, false); - - /* vector */ - f = set_function_chooser(sc->vector_symbol, vector_chooser); - sc->vector_2 = make_function_with_class(sc, f, "vector", g_vector_2, 2, 0, false); - sc->vector_3 = make_function_with_class(sc, f, "vector", g_vector_3, 3, 0, false); - - /* vector-ref */ - f = set_function_chooser(sc->vector_ref_symbol, vector_ref_chooser); - sc->vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false); - sc->vector_ref_3 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0, false); - - /* vector-set! */ - f = set_function_chooser(sc->vector_set_symbol, vector_set_chooser); - sc->vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false); - sc->vector_set_4 = make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4, 0, false); - - /* float-vector-ref */ - f = set_function_chooser(sc->float_vector_ref_symbol, float_vector_ref_chooser); - sc->fv_ref_2 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2, 0, false); - sc->fv_ref_3 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3, 0, false); - - /* float-vector-set */ - f = set_function_chooser(sc->float_vector_set_symbol, float_vector_set_chooser); - sc->fv_set_3 = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3, 0, false); - sc->fv_set_unchecked = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_unchecked, 3, 0, false); - - /* int-vector-ref */ - f = set_function_chooser(sc->int_vector_ref_symbol, int_vector_ref_chooser); - sc->iv_ref_2 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0, false); - sc->iv_ref_3 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0, false); - - /* int-vector-set */ - f = set_function_chooser(sc->int_vector_set_symbol, int_vector_set_chooser); - sc->iv_set_3 = make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3, 0, false); - - /* byte-vector-ref */ - f = set_function_chooser(sc->byte_vector_ref_symbol, byte_vector_ref_chooser); - sc->bv_ref_2 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2, 0, false); - sc->bv_ref_3 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3, 0, false); - - /* byte-vector-set */ - f = set_function_chooser(sc->byte_vector_set_symbol, byte_vector_set_chooser); - sc->bv_set_3 = make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3, 0, false); - - /* list-set! */ - f = set_function_chooser(sc->list_set_symbol, list_set_chooser); - sc->list_set_i = make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0, false); - - /* hash-table-ref */ - f = set_function_chooser(sc->hash_table_ref_symbol, hash_table_ref_chooser); - sc->hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false); - - /* hash-table-set! */ - set_function_chooser(sc->hash_table_set_symbol, hash_table_set_chooser); - - /* hash-table */ - f = set_function_chooser(sc->hash_table_symbol, hash_table_chooser); - sc->hash_table_2 = make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0, false); - - /* format */ - f = set_function_chooser(sc->format_symbol, format_chooser); - sc->format_f = make_function_with_class(sc, f, "format", g_format_f, 1, 0, true); - sc->format_no_column = make_function_with_class(sc, f, "format", g_format_no_column, 1, 0, true); - sc->format_just_control_string = make_function_with_class(sc, f, "format", g_format_just_control_string, 2, 0, false); - sc->format_as_objstr = make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, true); - - /* list */ - f = set_function_chooser(sc->list_symbol, list_chooser); - sc->list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false); - sc->list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false); - sc->list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false); - sc->list_3 = make_function_with_class(sc, f, "list", g_list_3, 3, 0, false); - sc->list_4 = make_function_with_class(sc, f, "list", g_list_4, 4, 0, false); - - /* append */ - f = set_function_chooser(sc->append_symbol, append_chooser); - sc->append_2 = make_function_with_class(sc, f, "append", g_append_2, 2, 0, false); - - /* list-ref */ - f = set_function_chooser(sc->list_ref_symbol, list_ref_chooser); - sc->list_ref_at_0 = make_function_with_class(sc, f, "list", g_list_ref_at_0, 2, 0, false); - sc->list_ref_at_1 = make_function_with_class(sc, f, "list", g_list_ref_at_1, 2, 0, false); - sc->list_ref_at_2 = make_function_with_class(sc, f, "list", g_list_ref_at_2, 2, 0, false); - - /* assoc */ - set_function_chooser(sc->assoc_symbol, assoc_chooser); - - /* member */ - set_function_chooser(sc->member_symbol, member_chooser); - - /* memq */ - f = set_function_chooser(sc->memq_symbol, memq_chooser); /* is pure-s7, use member here */ - sc->memq_2 = make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false); - sc->memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false); - sc->memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false); - sc->memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false); - - /* tree-set-memq */ - f = set_function_chooser(sc->tree_set_memq_symbol, tree_set_memq_chooser); - sc->tree_set_memq_syms = make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_1, 2, 0, false); - - /* eval-string */ - set_function_chooser(sc->eval_string_symbol, eval_string_chooser); - - /* dynamic-wind */ - f = set_function_chooser(sc->dynamic_wind_symbol, dynamic_wind_chooser); - sc->dynamic_wind_unchecked = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false); - sc->dynamic_wind_body = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_body, 3, 0, false); - sc->dynamic_wind_init = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_init, 3, 0, false); - - /* inlet */ - f = set_function_chooser(sc->inlet_symbol, inlet_chooser); - sc->simple_inlet = make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0, true); - - /* sublet */ - f = set_function_chooser(sc->sublet_symbol, sublet_chooser); - sc->sublet_curlet = make_function_with_class(sc, f, "sublet", g_sublet_curlet, 3, 0, false); - - /* let-ref */ - f = set_function_chooser(sc->let_ref_symbol, let_ref_chooser); - sc->lint_let_ref = make_function_with_class(sc, f, "let-ref", g_lint_let_ref, 2, 0, false); - - /* let-set */ - f = set_function_chooser(sc->let_set_symbol, let_set_chooser); - sc->lint_let_set = make_function_with_class(sc, f, "let-set!", g_lint_let_set, 3, 0, false); - - /* values */ - f = set_function_chooser(sc->values_symbol, values_chooser); - sc->values_uncopied = make_unsafe_function_with_class(sc, f, "values", splice_in_values, 0, 0, true); - - /* list-values */ - f = set_function_chooser(sc->list_values_symbol, list_values_chooser); - sc->simple_list_values = make_function_with_class(sc, f, "list-values", g_simple_list_values, 0, 0, true); -} - - -/* ---------------- *unbound-variable-hook* ---------------- */ -static s7_pointer loaded_library(s7_scheme *sc, const char *file) -{ - for (s7_pointer p = global_value(sc->libraries_symbol); is_pair(p); p = cdr(p)) - if (local_strcmp(file, string_value(caar(p)))) - return(cdar(p)); - return(sc->nil); -} - -static void pair_set_current_input_location(s7_scheme *sc, s7_pointer p) -{ - if (current_input_port(sc) != sc->standard_input) /* (port_file_number(current_input_port(sc)) > 1) -- maybe 0 is legit? */ - { - pair_set_location(p, port_location(current_input_port(sc))); - set_has_location(p); /* current_input_port(sc) above can't be nil(?) -- it falls back on stdin now */ - } -} - -static noreturn void unbound_variable_error_nr(s7_scheme *sc, s7_pointer sym) -{ - s7_pointer err_code = NULL; - - if ((is_pair(current_code(sc))) && (s7_tree_memq(sc, sym, current_code(sc)))) err_code = current_code(sc); - if ((is_pair(sc->code)) && (s7_tree_memq(sc, sym, sc->code))) err_code = sc->code; -#if WITH_HISTORY - { - s7_pointer p; - for (p = cdr(sc->cur_code); cdr(p) != sc->cur_code; p = cdr(p)); - if ((is_pair(car(p))) && (s7_tree_memq(sc, sym, car(p)))) err_code = car(p); - } -#endif - if (err_code) - error_nr(sc, sc->unbound_variable_symbol, - set_elist_3(sc, wrap_string(sc, "unbound variable ~S in ~S", 25), sym, err_code)); - - if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',') && - (lookup_unexamined(sc, make_symbol(sc, symbol_name(sym), symbol_name_length(sym) - 1)))) - error_nr(sc, sc->unbound_variable_symbol, - set_elist_2(sc, wrap_string(sc, "unbound variable ~S (perhaps a stray comma?)", 44), sym)); - - error_nr(sc, sc->unbound_variable_symbol, - set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19), sym)); -} - -static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) -{ - /* this always occurs in a context where we're trying to find anything, so I'll move a couple of those checks here */ - if (has_let_ref_fallback(sc->curlet)) /* an experiment -- see s7test (with-let *db* (+ int32_t (length str))) */ - return(call_let_ref_fallback(sc, sc->curlet, sym)); - /* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */ - - if (sym == sc->unquote_symbol) - syntax_error_nr(sc, "unquote (',') occurred outside quasiquote: ~S", 45, current_code(sc)); - - if (safe_strcmp(symbol_name(sym), "|#")) - read_error_nr(sc, "unmatched |#"); - - /* check *autoload*, autoload_names, then *unbound-variable-hook* */ - if ((sc->autoload_names) || - (is_hash_table(sc->autoload_table)) || - ((is_procedure(sc->unbound_variable_hook)) && - (hook_has_functions(sc->unbound_variable_hook)))) - { - s7_pointer cur_code = current_code(sc); - s7_pointer value = sc->value; - s7_pointer code = sc->code; - s7_pointer current_let = sc->curlet; - s7_pointer x = sc->x; - s7_pointer z = sc->z; - /* sc->args and sc->code are pushed on the stack by s7_call, then - * restored by eval, so they are normally protected, but sc->value and current_code(sc) are - * not protected. We need current_code(sc) so that the possible eventual error - * call can tell where the error occurred, and we need sc->value because it might - * be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered - * by the hook function. (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value - * is not protected. We also need to save/restore sc->curlet in case s7_load is called. - */ - s7_pointer args = (sc->args) ? sc->args : sc->nil; - s7_pointer result = sc->undefined; - sc->temp7 = cons_unchecked(sc, current_let, cons_unchecked(sc, code, /* perhaps elist_7 except we use elist_3 above? */ - cons_unchecked(sc, args, list_4(sc, value, cur_code, x, z)))); /* not s7_list (debugger checks) */ - if (!is_pair(cur_code)) - { - /* isolated typo perhaps -- no pair to hold the position info, so make one. current_code(sc) is GC-protected, so this should be safe */ - cur_code = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */ - pair_set_current_input_location(sc, cur_code); - } - -#if (!DISABLE_AUTOLOAD) - /* check sc->autoload_names */ - if ((sc->is_autoloading) && - (sc->autoload_names)) - { - bool loaded = false; - const char *file = find_autoload_name(sc, sym, &loaded, true); - if ((file) && (!loaded)) - { - /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...] - * here it was possible to get caught in a loop: - * change file, reload, unbound var seen, check autoload, it says "load file"... (where file does not get added to *libraries*) - * so the "loaded" arg tries to catch such cases - */ - s7_pointer e = loaded_library(sc, file); - if ((!e) || (!is_let(e))) - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, s7_make_string(sc, file))); - e = s7_load(sc, file); /* s7_load can return NULL */ - } - result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ - if ((result == sc->undefined) && - (e) && (is_let(e))) - { - result = let_ref(sc, e, sym); - /* I think to be consistent we should add '(sym . result) to the global let */ - if (result != sc->undefined) - s7_define(sc, sc->nil, sym, result); - }}} -#endif - if (result == sc->undefined) - { -#if (!DISABLE_AUTOLOAD) - /* check the *autoload* hash table */ - if ((sc->is_autoloading) && - (is_hash_table(sc->autoload_table))) - { - /* it was possible to get in a loop here: missing paren in x.scm, checks last symbol, sees - * autoload sym -> x.scm, loads x.scm, missing paren... - */ - s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); - if (is_string(val)) /* val should be a filename. *load-path* is searched if necessary */ - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); - s7_load(sc, string_value(val)); - } - else - if (is_closure(val)) /* val should be a function of one argument, the current (calling) environment */ - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); - s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil)); - } - result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ - } -#endif - /* check *unbound-variable-hook* */ - if ((result == sc->undefined) && - (is_procedure(sc->unbound_variable_hook)) && - (hook_has_functions(sc->unbound_variable_hook))) - { - /* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */ - s7_pointer old_hook = sc->unbound_variable_hook; - bool old_history_enabled = s7_set_history_enabled(sc, false); - gc_protect_via_stack(sc, old_hook); - sc->unbound_variable_hook = sc->nil; - result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ - sc->unbound_variable_hook = old_hook; - s7_set_history_enabled(sc, old_history_enabled); - unstack(sc); - }} - sc->value = T_Ext(value); - sc->args = T_Pos(args); /* can be # */ - sc->code = code; - set_curlet(sc, current_let); - sc->x = x; - sc->z = z; - sc->temp7 = sc->unused; - if ((result != sc->undefined) && - (result != sc->unspecified)) - return(result); - } - unbound_variable_error_nr(sc, sym); - return(sc->unbound_variable_symbol); -} - -static bool gx_annotate_arg(s7_scheme *sc, s7_pointer p, s7_pointer e) -{ - if (is_gxable(car(p))) - { - opcode_t old_op = optimize_op(car(p)); - s7_pointer fxf; - set_optimize_op(car(p), old_op + 1); - fxf = (s7_pointer)fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); - if (fxf) - { - set_has_gx(p); - set_opt2(p, fxf, OPT2_FX); - } - set_optimize_op(car(p), old_op); - return(fxf); - } - return(false); -} - -static void gx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - gx_annotate_arg(sc, p, e); -} - -#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true)) - -static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e) -{ -#if S7_DEBUGGING - s7_function fx; - if (has_fx(arg)) return; - fx = fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); - if (fx) set_fx_direct(arg, fx); -#else - if (has_fx(arg)) return; - set_fx(arg, fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); -#endif -} - -static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) -#if S7_DEBUGGING - fx_annotate_arg(sc, p, e); /* checks has_fx */ -#else - if (!has_fx(p)) - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); -#endif -} - -static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) -{ - if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1; - - if ((is_closure(func)) || (is_closure_star(func))) - { - bool safe_case = is_safe_closure(func); - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)); - - if (is_immutable(func)) hop = 1; - if (is_null(closure_args(func))) /* no rest arg funny business */ - { - set_optimized(expr); - if ((one_form) && (safe_case) && (is_fxable(sc, car(body)))) /* fx stuff is not set yet */ - { - fx_annotate_arg(sc, body, e); - set_optimize_op(expr, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg(func); - set_opt1_lambda_add(expr, func); - return(OPT_T); - } - /* thunks with fully fxable bodies are rare apparently, and the time spent here overwhelms run time gains */ - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); - set_opt1_lambda_add(expr, func); - return((safe_case) ? OPT_T : OPT_F); - } - - if (is_symbol(closure_args(func))) /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */ - { - set_opt1_lambda_add(expr, func); - if (safe_case) - { - if (!has_fx(body)) - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, closure_args(func), NULL, NULL, false); - } - set_safe_optimize_op(expr, hop + OP_SAFE_THUNK_ANY); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ - return(OPT_F); - } - if (is_closure_star(func)) - { - set_opt1_lambda_add(expr, func); - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); - } - return(OPT_F); - } - if (is_c_function(func)) - { - if (c_function_min_args(func) != 0) - return(OPT_F); - if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; - if (is_safe_procedure(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); - choose_c_function(sc, expr, func, 0); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_C); - choose_c_function(sc, expr, func, 0); - return(OPT_F); - } - if (is_c_function_star(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR); - set_c_function(expr, func); - return(OPT_T); - } - return(OPT_F); -} - -static int32_t combine_ops(s7_scheme *sc, s7_pointer expr, combine_op_t cop, s7_pointer e1, s7_pointer e2) /* sc needed for debugger stuff */ -{ - switch (cop) - { - case E_C_P: - switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: return(OP_SAFE_C_opSq); - case OP_SAFE_C_NC: return(OP_SAFE_C_opNCq); - case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq); - case OP_SAFE_C_A: return(OP_SAFE_C_opAq); - case OP_SAFE_C_AA: return(OP_SAFE_C_opAAq); - case OP_SAFE_C_AAA: return(OP_SAFE_C_opAAAq); - case OP_SAFE_C_SS: - set_opt3_sym(expr, cadr(e1)); - set_opt1_sym(cdr(expr), caddr(e1)); - return(OP_SAFE_C_opSSq); - case OP_SAFE_C_opSq: - set_opt3_pair(expr, cadr(e1)); - set_opt3_sym(cdr(expr), cadadr(e1)); - return(OP_SAFE_C_op_opSqq); - case OP_SAFE_C_S_opSq: - set_opt3_pair(expr, caddr(e1)); - return(OP_SAFE_C_op_S_opSqq); - case OP_SAFE_C_opSq_S: - set_opt3_pair(expr, cadr(e1)); - return(OP_SAFE_C_op_opSq_Sq); - } - return(OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */ - - case E_C_SP: - switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: return(OP_SAFE_C_S_opSq); - case OP_SAFE_C_AA: return(OP_SAFE_C_S_opAAq); - case OP_SAFE_C_SC: - set_opt2_con(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opSCq); - case OP_SAFE_C_CS: /* expr is (* a (- 1 b)), e2 is (- 1 b) */ - set_opt2_sym(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opCSq); - case OP_SAFE_C_SS: /* (* a (- b c)) */ - set_opt2_sym(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opSSq); - case OP_SAFE_C_A: - set_opt3_pair(expr, cdaddr(expr)); - return(OP_SAFE_C_S_opAq); - } - return(OP_SAFE_C_SP); /* if fxable -> AA later */ - - case E_C_PS: - switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: - set_opt1_sym(cdr(expr), cadr(e1)); - set_opt3_sym(expr, e2); - return(OP_SAFE_C_opSq_S); - case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_S); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_S); - case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); - case OP_SAFE_C_opSSq: - set_opt1_pair(cdr(expr), cadadr(expr)); - set_opt3_pair(expr, cadr(e1)); - return(OP_SAFE_C_op_opSSqq_S); - } - return(OP_SAFE_C_PS); - - case E_C_PC: - switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: - set_opt1_sym(cdr(expr), cadr(e1)); - set_opt2_con(cdr(expr), e2); - return(OP_SAFE_C_opSq_C); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_C); - case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq_C); - case OP_SAFE_C_SS: - set_opt3_con(cdr(expr), caddr(expr)); - return(OP_SAFE_C_opSSq_C); - } - set_opt3_con(cdr(expr), caddr(expr)); - return(OP_SAFE_C_PC); - - case E_C_CP: - switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: - set_opt3_pair(expr, e2); - return(OP_SAFE_C_C_opSq); - case OP_SAFE_C_SC: - set_opt1_sym(cdr(expr), cadr(e2)); - set_opt2_con(cdr(expr), caddr(e2)); - return(OP_SAFE_C_C_opSCq); - case OP_SAFE_C_SS: - set_opt1_sym(cdr(expr), cadr(e2)); - return(OP_SAFE_C_C_opSSq); - } - return(OP_SAFE_C_CP); - - case E_C_PP: - switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: - if (is_safe_c_s(e1)) - return(OP_SAFE_C_opSq_opSq); - if (optimize_op_match(e1, OP_SAFE_C_SS)) - return(OP_SAFE_C_opSSq_opSq); - break; - case OP_SAFE_C_SS: - if (optimize_op_match(e1, OP_SAFE_C_SS)) - return(OP_SAFE_C_opSSq_opSSq); - if (is_safe_c_s(e1)) - return(OP_SAFE_C_opSq_opSSq); - break; - } - return(OP_SAFE_C_PP); - - default: - break; - } - return(OP_UNOPT); -} - -static bool arg_findable(s7_scheme *sc, s7_pointer arg1, s7_pointer e) -{ - if (pair_symbol_is_safe(sc, arg1, e)) return(true); /* includes global_slot check */ - return((!sc->in_with_let) && - (is_slot(lookup_slot_from(arg1, sc->curlet)))); -} - -static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop) -{ - if (fx_proc(cddr(arg)) == fx_s) {set_opt3_sym(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);} - if (fx_proc(cdr(arg)) == fx_s) {set_opt3_sym(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);} - if (fx_proc(cddr(arg)) == fx_c) {set_opt3_con(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} - if (fx_proc(cdr(arg)) == fx_c) {set_opt3_con(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - if (fx_proc(cddr(arg)) == fx_q) {set_opt3_con(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} - if (fx_proc(cdr(arg)) == fx_q) {set_opt3_con(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - return(false); -} - -static opt_t check_c_aa(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) -{ - fx_annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ag_ga(sc, expr, hop)) - { - set_optimize_op(expr, hop + OP_SAFE_C_AA); - set_opt3_pair(expr, cddr(expr)); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); -} - -static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int32_t n_args, int32_t hop, s7_pointer e) -{ - set_opt3_arglen(cdr(expr), n_args); - if (is_c_function(func)) - { - set_safe_optimize_op(expr, hop + ((is_safe_procedure(func)) ? - ((n_args == 1) ? OP_SAFE_C_A : OP_SAFE_C_AA) : - ((n_args == 1) ? ((is_semisafe(func)) ? OP_CL_A : OP_C_A) : - ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)))); - if (op_no_hop(expr) == OP_SAFE_C_AA) - { - set_opt3_pair(expr, cddr(expr)); - if (optimize_op(expr) == HOP_SAFE_C_AA) return(check_c_aa(sc, expr, func, hop, e)); - } - set_c_function(expr, func); - return(OPT_T); - } - if ((is_closure(func)) && - (!arglist_has_rest(sc, closure_args(func)))) - { - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)), safe_case = is_safe_closure(func); - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - if (one_form) - set_optimize_op(expr, hop + ((safe_case) ? - ((n_args == 1) ? OP_SAFE_CLOSURE_A_O : OP_SAFE_CLOSURE_AA_O) : - ((n_args == 1) ? OP_CLOSURE_A_O : OP_CLOSURE_AA_O))); - else - set_optimize_op(expr, hop + ((safe_case) ? - ((n_args == 1) ? OP_SAFE_CLOSURE_A : OP_SAFE_CLOSURE_AA) : - ((n_args == 1) ? OP_CLOSURE_A : OP_CLOSURE_AA))); - return(OPT_F); - } - if ((is_closure_star(func)) && - (lambda_has_simple_defaults(func)) && - (closure_star_arity_to_int(sc, func) >= n_args) && - (!arglist_has_rest(sc, closure_args(func)))) - { - set_unsafely_optimized(expr); - if (n_args == 1) - set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - else - if (closure_star_arity_to_int(sc, func) == 2) - set_optimize_op(expr, ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : - OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); - else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(expr, func); - } - return(OPT_F); -} - -static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e) -{ - s7_pointer x; - int64_t id; - - if ((symbol_is_in_list(sc, symbol)) && - (direct_memq(symbol, e))) /* it's probably a local variable reference */ - return(sc->nil); - /* ((!symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) can happen if there's an intervening lambda: - * (let loop () (with-let (for-each (lambda (a) a) (list))) (loop)) - * misses 'loop (it's not in symbol_list when recursive call is encountered) -- tricky to fix - */ - - if (is_global(symbol)) - return(global_slot(symbol)); - - /* see 59108 (OP_DEFINE_* in optimize_syntax) -- keyword version of name is used if a definition is - * contingent on some run-time decision, so we're looking here for local defines that might not happen. - * s7test.scm has a test case using acos. - */ - if ((has_keyword(symbol)) && - (symbol_is_in_list(sc, symbol_to_keyword(sc, symbol)))) - return(sc->nil); - - for (x = sc->curlet, id = symbol_id(symbol); id < let_id(x); x = let_outlet(x)); - for (; is_let(x); x = let_outlet(x)) - { - if (let_id(x) == id) - return(local_slot(symbol)); - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - } - return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */ -} - -static bool is_ok_lambda(s7_scheme *sc, s7_pointer arg2) -{ - return((is_pair(arg2)) && - (is_lambda(sc, car(arg2))) && /* must start (lambda ...) */ - (is_pair(cdr(arg2))) && /* must have arg(s) */ - (is_pair(cddr(arg2))) && /* must have body */ - (s7_is_proper_list(sc, cdddr(arg2)))); -} - -static bool hop_if_constant(s7_scheme *sc, s7_pointer sym) -{ - return(((!sc->in_with_let) && (symbol_id(sym) == 0)) ? 1 : 0); /* for with-let, see s7test atanh (77261) */ -} - -static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1 = cadr(expr); - bool func_is_safe = is_safe_procedure(func); - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - if (pairs == 0) - { - if (func_is_safe) /* safe c function */ - { - set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_NC : OP_SAFE_C_S)); - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - /* c function is not safe */ - if (symbols == 0) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); /* OP_C_C never happens */ - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - } - else - { - set_unsafely_optimized(expr); - if (c_function_call(func) == g_read) - set_optimize_op(expr, hop + OP_READ_S); - else set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_S : OP_C_S)); - } - choose_c_function(sc, expr, func, 1); - return(OPT_F); - } - /* pairs == 1 */ - if (bad_pairs == 0) - { - if (func_is_safe) - { - int32_t op = combine_ops(sc, expr, E_C_P, arg1, NULL); - /* if ((hop == 1) && (!op_has_hop(arg1))) hop = 0; *//* probably not the right way to fix this (s7test tc_or_a_and_a_a_la) */ - set_safe_optimize_op(expr, hop + op); - - if ((op == OP_SAFE_C_P) && - (is_fxable(sc, arg1))) - { - set_optimize_op(expr, hop + OP_SAFE_C_A); - fx_annotate_arg(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - choose_c_function(sc, expr, func, 1); - return(OPT_F); - }} - else /* bad_pairs == 1 */ - { - if (quotes == 1) - { - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - if (func_is_safe) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_A); - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); - choose_c_function(sc, expr, func, 1); - return(OPT_F); - } - /* quotes == 0 */ - if (!func_is_safe) - { - s7_pointer lambda_expr = arg1; - if ((is_ok_lambda(sc, lambda_expr)) && - (!direct_memq(car(lambda_expr), e))) /* (let ((lambda #f)) (call-with-exit (lambda ...))) */ - { - if (((c_function_call(func) == g_call_with_exit) || - (c_function_call(func) == g_call_cc) || - (c_function_call(func) == g_call_with_output_string)) && - (is_proper_list_1(sc, cadr(lambda_expr))) && - (is_symbol(caadr(lambda_expr))) && - (!is_probably_constant(caadr(lambda_expr)))) /* (call-with-exit (lambda (pi) ...) */ - { - if (c_function_call(func) == g_call_cc) - set_unsafe_optimize_op(expr, OP_CALL_CC); - else - if (c_function_call(func) == g_call_with_exit) - set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : OP_CALL_WITH_EXIT); - else - { - set_unsafe_optimize_op(expr, OP_CALL_WITH_OUTPUT_STRING); - set_opt2_pair(expr, cddr(lambda_expr)); - set_opt3_sym(expr, caadr(lambda_expr)); - set_local(caadr(lambda_expr)); - return(OPT_F); - } - choose_c_function(sc, expr, func, 1); - set_opt2_pair(expr, cdr(lambda_expr)); - set_local(caadr(lambda_expr)); /* check_lambda_args normally handles this, but if hop==1, we'll skip that step */ - return(OPT_F); - } - if ((c_function_call(func) == g_with_output_to_string) && - (is_null(cadr(lambda_expr)))) - { - set_unsafe_optimize_op(expr, OP_WITH_OUTPUT_TO_STRING); - set_opt2_pair(expr, cddr(lambda_expr)); - return(OPT_F); - }}}} - set_unsafe_optimize_op(expr, hop + ((func_is_safe) ? OP_SAFE_C_P : OP_C_P)); - choose_c_function(sc, expr, func, 1); - return(OPT_F); -} - -static bool walk_fxable(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = cdr(tree); is_pair(p); p = cdr(p)) - { - s7_pointer q = car(p); - if ((is_pair(q)) && - (is_optimized(q))) - { - opcode_t op = optimize_op(q); - if (is_safe_c_op(op)) return(true); - if ((op >= OP_TC_AND_A_OR_A_LA) || - ((op >= OP_THUNK) && (op < OP_BEGIN)) || - (!walk_fxable(sc, q))) - return(false); - }} - return(true); -} - -static bool is_safe_fxable(s7_scheme *sc, s7_pointer p) -{ - if (!is_pair(p)) return(true); - if (is_optimized(p)) - { - if ((fx_function[optimize_op(p)]) && - (walk_fxable(sc, (p)))) - return(true); - } - if (is_proper_quote(sc, p)) return(true); - if ((S7_DEBUGGING) && (is_optimized(p)) && (fx_function[optimize_op(p)])) fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)], display(p)); - return(false); -} - -static opt_t fxify_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t hop) -{ - s7_pointer body = closure_body(func); - fx_annotate_arg(sc, body, e); - /* we can't currently fx_annotate_arg(sc, cdr(expr), e) here because that opt2 field is in use elsewhere (opt2_sym, not sure where it's set) */ - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A); - if ((is_pair(car(body))) && (is_pair(cdar(body))) && (car(closure_args(func)) == cadar(body))) - { - if (optimize_op(car(body)) == HOP_SAFE_C_S) - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S); - else - if (optimize_op(car(body)) == HOP_SAFE_C_SC) - { - s7_pointer body_arg2 = caddar(body); - set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); - if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) - set_fx_direct(cdr(expr), fx_safe_closure_s_to_vref); - else - { - set_fx_direct(cdr(expr), fx_safe_closure_s_to_sc); - if ((is_t_integer(body_arg2)) && (integer(body_arg2) == 1)) - { - if (caar(body) == sc->subtract_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_sub1); - if (caar(body) == sc->add_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_add1); - }}}} - set_closure_one_form_fx_arg(func); - fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); - return(OPT_T); -} - -static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool safe_case, int32_t hop, s7_pointer expr, s7_pointer e) -{ - if (!one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_A_O); - else - { - s7_pointer body = closure_body(func); - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O); - else - { - fx_annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); - if ((is_pair(car(body))) && - (optimize_op(car(body)) == HOP_SAFE_C_SC) && - (car(closure_args(func)) == cadar(body))) - { - s7_pointer body_arg2 = caddar(body); - set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC); - /* why is this setting expr whereas _s case above sets cdr(expr)? */ - if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) - set_fx_direct(expr, fx_safe_closure_a_to_vref); - else set_fx_direct(expr, fx_safe_closure_a_to_sc); - } - set_closure_one_form_fx_arg(func); - fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); - return(true); - }} - return(false); -} - -static opt_t optimize_closure_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e) -{ - if (fx_count(sc, expr) != args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */ - return(OPT_F); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - fx_annotate_args(sc, cdr(expr), e); - if (is_safe_closure(func)) - { - s7_pointer body = closure_body(func); - if (!has_fx(body)) /* does this have any effect? */ - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, closure_args(func), NULL, NULL, false); - } - set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); - return(OPT_F); -} - -static opt_t optimize_closure_a_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e) -{ - if (fx_count(sc, expr) != args) return(OPT_F); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - fx_annotate_args(sc, cdr(expr), e); - if (is_safe_closure(func)) - { - s7_pointer body = closure_body(func); - if (!has_fx(body)) /* does this have any effect? */ - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cdr(closure_args(func)), NULL, false); - } - set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); - return(OPT_F); -} - -static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t symbols, s7_pointer e) -{ - bool one_form, safe_case; - s7_pointer body, arg1 = cadr(expr); - int32_t arit = closure_arity_to_int(sc, func); - if (arit != 1) - { - if (is_symbol(closure_args(func))) /* (arit == -1) is ambiguous: (define (f . a)...) and (define (f a . b)...) both are -1 here */ - return(optimize_closure_sym(sc, expr, func, hop, 1, e)); - if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) - return(optimize_closure_a_sym(sc, expr, func, hop, 1, e)); - return(OPT_F); - } - safe_case = is_safe_closure(func); - body = closure_body(func); - one_form = is_null(cdr(body)); - if (is_immutable(func)) hop = 1; - - if (symbols == 1) - { - set_opt2_sym(expr, arg1); - set_opt1_lambda_add(expr, func); - if (one_form) - { - if (safe_case) - { - if (is_fxable(sc, car(body))) - return(fxify_closure_s(sc, func, expr, e, hop)); - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O); /* tleft 7638 if _O here, 7692 if not (and claims 80 in the begin setup) */ - } - else set_optimize_op(expr, hop + OP_CLOSURE_S_O); - } - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_S : OP_CLOSURE_S)); - set_unsafely_optimized(expr); - return(OPT_F); - } - if (fx_count(sc, expr) == 1) - { - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e)) return(OPT_T); - set_unsafely_optimized(expr); - return(OPT_F); - } - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_P : OP_CLOSURE_P)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 1); - set_unsafely_optimized(expr); - if ((safe_case) && (one_form) && (is_fxable(sc, car(closure_body(func))))) - { - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_P_A); /* other possibilities: 3p fp (ap|pa only get a few hits), but none of these matter much */ - fx_annotate_arg(sc, closure_body(func), e); - } - return(OPT_F); /* don't check is_optimized here for OPT_T */ -} - -static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1; - /* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */ - if (quotes > 0) - { - if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - } - arg1 = cadr(expr); - /* need in_with_let -> search only rootlet not lookup */ - if ((symbols == 1) && - (!arg_findable(sc, arg1, e))) - { - /* wrap the bad arg in a check symbol lookup */ - if (s7_is_aritable(sc, func, 1)) - { - set_fx_direct(cdr(expr), fx_unsafe_s); - return(wrap_bad_args(sc, func, expr, 1, hop, e)); - } - return(OPT_F); - } - if ((is_c_function(func)) && (c_function_is_aritable(func, 1))) - return(optimize_c_function_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - - if (is_closure(func)) - return(optimize_closure_one_arg(sc, expr, func, hop, symbols, e)); - - if (is_closure_star(func)) - { - if (is_null(closure_args(func))) - return(OPT_F); - if (fx_count(sc, expr) == 1) - { - bool safe_case = is_safe_closure(func); - if (is_immutable(func)) hop = 1; - fx_annotate_arg(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 1); - set_unsafely_optimized(expr); - - if ((safe_case) && (is_null(cdr(closure_args(func))))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); - else - if (lambda_has_simple_defaults(func)) - { - if (arglist_has_rest(sc, closure_args(func))) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - } - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - } - return(OPT_F); - } - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == 1) && - (c_function_max_args(func) >= 1) && - (!is_symbol_and_keyword(arg1))) /* the only arg should not be a keyword (needs error checks later) */ - { - if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1; - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - set_c_function(expr, func); - return(OPT_T); - } - - if (((is_any_vector(func)) || (is_pair(func))) && - (is_fxable(sc, arg1))) - { - set_unsafe_optimize_op(expr, (is_pair(func) ? OP_IMPLICIT_PAIR_REF_A : OP_IMPLICIT_VECTOR_REF_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - return(OPT_T); - } - - if ((func == sc->s7_starlet) && /* (*s7* ...) */ - (((quotes == 1) && (is_symbol(cadr(arg1)))) || - (is_symbol_and_keyword(arg1)))) - { - s7_pointer sym = (quotes == 1) ? cadr(arg1) : arg1; - if (is_keyword(sym)) sym = keyword_symbol(sym); /* might even be ':print-length */ - set_safe_optimize_op(expr, OP_IMPLICIT_S7_STARLET_REF_S); - set_opt3_int(expr, s7_starlet_symbol(sym)); - return(OPT_T); - } - - if (is_let(func)) - { - if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) - { - set_opt3_con(expr, cadr(arg1)); - set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); - return(OPT_T); - } - if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_A); - set_opt3_any(expr, arg1); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - return(OPT_T); - }} - - /* unknown_* for other cases is set later(? -- we're getting eval-args...) */ - /* op_safe_c_p for (< (values 1 2 3)) op_s_s for (op arg) - * but is it better to wait for unknown* ? These are not hit often at this point (except in s7test). - * do they end up in op_s_a or whatever after unknown*? - */ - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static bool unsafe_is_safe(s7_scheme *sc, s7_pointer f, s7_pointer e) -{ - if (!is_symbol(f)) return(false); - f = find_uncomplicated_symbol(sc, f, e); /* how to catch local c-funcs here? */ - if (!is_slot(f)) return(false); - return(is_safe_c_function(slot_value(f))); -} - -static opt_t set_any_closure_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) -{ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); - set_opt3_arglen(cdr(expr), num_args); - set_unsafe_optimize_op(expr, op); - set_opt1_lambda_add(expr, func); - return(OPT_F); -} - -static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer e) -{ - if ((is_symbol(car(expr))) && ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol))) return(true); - return(unsafe_is_safe(sc, cadr(expr), e)); -} - -static void opt_sp_1(s7_scheme *sc, s7_function g, s7_pointer expr) -{ - set_opt1_any(cdr(expr), - (s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 : - (((g == g_multiply) || (g == g_multiply_2)) ? OP_SAFE_MULTIPLY_SP_1 : - (((g == g_add) || (g == g_add_2)) ? OP_SAFE_ADD_SP_1 : OP_SAFE_C_SP_1))))); -} - -static opt_t set_any_c_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) -{ - /* we get safe/semisafe funcs here of 2 args and up! very few more than 5 */ - /* would safe_c_pp work for cl? or should unknown_* deal with op_cl_*? why aren't unknown* used in op_safe_c and op_c? - * 2 | 3 args store on stack rather than consing? then use sc->t2|3 to pass to fn_proc (unless unsafe) - * or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p? - * all: 3 1 0 any_c_np (* 0.5 (- n 1) y)?? - */ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); - if (!has_fx(p)) - gx_annotate_arg(sc, p, e); - } - set_opt3_arglen(cdr(expr), num_args); /* for op_unknown_np */ - set_unsafe_optimize_op(expr, op); - choose_c_function(sc, expr, func, num_args); /* we can use num_args -- mv will redirect to generic call */ - return(OPT_F); -} - -static s7_function io_function(s7_function func) -{ - if (func == g_with_input_from_string) return(with_string_in); - if (func == g_with_input_from_file) return(with_file_in); - if (func == g_with_output_to_file) return(with_file_out); - if (func == g_call_with_input_string) return(call_string_in); - if (func == g_call_with_input_file) return(call_file_in); - return(call_file_out); /* call_with_output_to_file */ -} - -static void fixup_closure_star_aa(s7_scheme *sc, s7_pointer f, s7_pointer code, int32_t hop) -{ - int32_t arity = closure_star_arity_to_int(sc, f); - bool safe_case = is_safe_closure(f); - s7_pointer arg1 = cadr(code), par1 = car(closure_args(f)); - - if (is_pair(par1)) par1 = car(par1); - set_opt3_arglen(cdr(code), 2); - set_unsafely_optimized(code); - - if ((arity == 1) && (is_symbol_and_keyword(arg1)) && (keyword_symbol(arg1) == par1)) - set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA)); - else - if ((lambda_has_simple_defaults(f)) && (arity == 2)) - set_optimize_op(code, hop + ((is_safe_closure(f)) ? ((is_null(cdr(closure_body(f)))) ? OP_SAFE_CLOSURE_STAR_AA_O : - OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); - else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_2 : OP_CLOSURE_STAR_NA)); -} - -static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool optl); - -static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (quotes > 0) - { - if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - } - if (((is_symbol(arg1)) && - (!arg_findable(sc, arg1, e))) || - ((is_symbol(arg2)) && - (!arg_findable(sc, arg2, e)))) - { - /* wrap bad args */ - if ((is_fxable(sc, arg1)) && - (is_fxable(sc, arg2)) && - (s7_is_aritable(sc, func, 2))) - { - fx_annotate_args(sc, cdr(expr), e); - return(wrap_bad_args(sc, func, expr, 2, hop, e)); - } - return(OPT_F); - } - /* end of bad symbol wrappers */ - - if (is_c_function(func) && (c_function_is_aritable(func, 2))) - { - /* this is a mess */ - bool func_is_safe = is_safe_procedure(func); - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - - if (pairs == 0) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - /* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */ - if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_NC); - else - if (symbols == 2) /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */ - { - set_optimize_op(expr, hop + OP_SAFE_C_SS); - set_opt2_sym(cdr(expr), arg2); - } - else - if (is_normal_symbol(arg1)) - { - set_opt2_con(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SC); - } - else - { - set_opt1_con(cdr(expr), arg1); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - } - set_optimized(expr); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - - set_unsafely_optimized(expr); - if (symbols == 2) - { - if (c_function_call(func) == g_apply) - { - set_optimize_op(expr, OP_APPLY_SS); - set_opt1_cfunc(expr, func); /* not quite set_c_function */ - set_opt2_sym(expr, arg2); - } - else - { - if (is_semisafe(func)) - { - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_CL_SS); - } - else set_optimize_op(expr, hop + OP_C_SS); - choose_c_function(sc, expr, func, 2); - }} - else - { - set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - choose_c_function(sc, expr, func, 2); - if (is_safe_procedure(opt1_cfunc(expr))) - { - clear_unsafe(expr); - /* symbols can be 0..2 here, no pairs */ - set_optimized(expr); - if (symbols == 1) - { - if (is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_SC); - set_opt2_con(cdr(expr), arg2); - } - else - { - set_opt1_con(cdr(expr), arg1); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - }} - return(OPT_T); - }} - return(OPT_F); - } - - /* pairs != 0 */ - if ((bad_pairs == 0) && - (pairs == 2)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - int32_t op = combine_ops(sc, expr, E_C_PP, arg1, arg2); - set_safe_optimize_op(expr, hop + op); - if (op == OP_SAFE_C_PP) - { - if (((op_no_hop(cadr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && - ((op_no_hop(caddr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && - (is_global(caadr(expr))) && (is_global(caaddr(expr)))) - { - /* ideally this would be OP not HOP, but safe_closure_s_to_sc is too picky */ - /* set_opt3_pair(expr, caddr(expr)); */ /* set_opt3_arglen(cdr(expr), 2); */ - set_safe_optimize_op(expr, HOP_SAFE_C_FF); - } - - opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(cdr(expr)) to OP_SAFE_CONS_SP_1 and friends */ - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - return(check_c_aa(sc, expr, func, hop, e)); /* AA case */ - set_optimize_op(expr, hop + OP_SAFE_C_AP); - fx_annotate_arg(sc, cdr(expr), e); - gx_annotate_arg(sc, cddr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - fx_annotate_arg(sc, cddr(expr), e); - gx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else gx_annotate_args(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ - return(OPT_T); - }} - - if ((bad_pairs == 0) && - (pairs == 1)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - combine_op_t orig_op; - int32_t op; - - if (is_pair(arg1)) - { - orig_op = (is_normal_symbol(arg2)) ? E_C_PS : E_C_PC; - op = combine_ops(sc, expr, orig_op, arg1, arg2); - } - else - { - orig_op = (is_normal_symbol(arg1)) ? E_C_SP : E_C_CP; - op = combine_ops(sc, expr, orig_op, arg1, arg2); - } - if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) && - (is_fxable(sc, arg2))) || - (((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) && - (is_fxable(sc, arg1)))) - { - fx_annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ag_ga(sc, expr, hop)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); - set_opt3_pair(expr, cddr(expr)); - }} - else - { - set_safe_optimize_op(expr, hop + op); - if ((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) - { - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), arg1); - } - else - if (op == OP_SAFE_C_PC) - set_opt3_con(cdr(expr), arg2); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); - }} - - if ((bad_pairs == 1) && (quotes == 1)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - if (symbols == 1) - { - set_optimized(expr); - if (is_normal_symbol(arg1)) - { - set_opt2_con(cdr(expr), cadr(arg2)); - set_optimize_op(expr, hop + OP_SAFE_C_SC); - } - else - { - set_opt1_con(cdr(expr), cadr(arg1)); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */ - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); - set_opt2_con(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - if (!is_safe_c_s(arg1)) - { - if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - return(check_c_aa(sc, expr, func, hop, e)); - }} - else - if (pairs == 1) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }} - - if (quotes == 2) - { - if (func_is_safe) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); /* op_safe_c_nc -> fx_c_nc appears to leave quoted pairs quoted? */ - set_opt3_pair(expr, cddr(expr)); - } - else - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - set_opt3_arglen(cdr(expr), 2); - } - fx_annotate_args(sc, cdr(expr), e); - choose_c_function(sc, expr, func, 2); - return((func_is_safe) ? OPT_T : OPT_F); - } - - if ((pairs == 1) && - (quotes == 0) && - ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) - { - if (symbols == 1) - { - set_optimized(expr); - if (is_normal_symbol(arg1)) /* this is what optimize_expression uses to count symbols */ - { - set_optimize_op(expr, hop + OP_SAFE_C_SP); - opt_sp_1(sc, c_function_call(func), expr); - } - else set_optimize_op(expr, hop + OP_SAFE_C_PS); - choose_c_function(sc, expr, func, 2); - if (bad_pairs == 0) - return(OPT_T); - set_unsafe(expr); - return(OPT_F); - } - if (symbols == 0) - { - set_optimized(expr); - if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - return(check_c_aa(sc, expr, func, hop, e)); - if (is_pair(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PC); - set_opt3_con(cdr(expr), arg2); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_CP); - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), arg1); - } - choose_c_function(sc, expr, func, 2); - if (bad_pairs == 0) - return(OPT_T); - set_unsafe(expr); - return(OPT_F); - }} - - if ((pairs == 2) && - ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) - { - if ((bad_pairs == 1) && - (is_safe_c_s(arg1))) - { - /* unsafe func here won't work unless we check that later and make the new arg list (for list-values etc) - * (and it has to be the last pair else the unknown_g stuff can mess up) - */ - if ((car(arg2) == sc->quote_symbol) && - (is_global(sc->quote_symbol))) - { - if (!is_proper_list_1(sc, cdr(arg2))) - return(OPT_OOPS); - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C); - set_opt1_sym(cdr(expr), cadr(arg1)); - set_opt2_con(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - }} - if (quotes == 0) - { - set_unsafely_optimized(expr); - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - return(check_c_aa(sc, expr, func, hop, e)); - set_optimize_op(expr, hop + OP_SAFE_C_AP); - opt_sp_1(sc, c_function_call(func), expr); - fx_annotate_arg(sc, cdr(expr), e); - gx_annotate_arg(sc, cddr(expr), e); - } - else - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - fx_annotate_arg(sc, cddr(expr), e); - gx_annotate_arg(sc, cdr(expr), e); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_PP); - opt_sp_1(sc, c_function_call(func), expr); - gx_annotate_args(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - if (quotes == 1) - { - if ((car(arg1) == sc->quote_symbol) && - (is_global(sc->quote_symbol))) - { - if (!is_proper_list_1(sc, cdr(arg1))) - return(OPT_OOPS); - set_optimize_op(expr, hop + OP_SAFE_C_CP); - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), cadr(arg1)); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_PC); - set_opt3_con(cdr(expr), cadr(arg2)); - } - set_unsafely_optimized(expr); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }} - - if (func_is_safe) - { - if (fx_count(sc, expr) == 2) - return(check_c_aa(sc, expr, func, hop, e)); - } - else - { - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - { - if ((c_function_call(func) == g_apply) && - (is_normal_symbol(arg1))) - { - set_optimize_op(expr, OP_APPLY_SA); - if ((is_pair(arg2)) && - (is_normal_symbol(car(arg2)))) /* arg2 might be ((if expr op1 op2) ...) */ - { - s7_pointer lister = lookup(sc, car(arg2)); - if ((is_c_function(lister)) && - (is_pair(c_function_signature(lister))) && - (car(c_function_signature(lister)) == sc->is_proper_list_symbol)) - set_optimize_op(expr, OP_APPLY_SL); - } - set_opt1_cfunc(expr, func); /* not quite set_c_function */ - } - else set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else - { - if (((c_function_call(func) == g_with_input_from_string) || - (c_function_call(func) == g_with_input_from_file) || - (c_function_call(func) == g_with_output_to_file)) && - (is_ok_lambda(sc, arg2)) && - (is_null(cadr(arg2))) && - (!direct_memq(car(arg2), e))) /* lambda is redefined?? */ - { - set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); - set_opt2_pair(expr, cddr(arg2)); - set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); - return(OPT_F); - } - if (((c_function_call(func) == g_call_with_input_string) || - (c_function_call(func) == g_call_with_input_file) || - (c_function_call(func) == g_call_with_output_file)) && - (is_ok_lambda(sc, arg2)) && - (is_proper_list_1(sc, cadr(arg2))) && - (is_symbol(caadr(arg2))) && - (!is_probably_constant(caadr(arg2))) && - (!direct_memq(sc->lambda_symbol, e))) /* lambda is redefined?? */ - { - set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); - set_opt2_pair(expr, cddr(arg2)); - set_opt3_sym(expr, caadr(arg2)); - set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); - return(OPT_F); - } - set_unsafe_optimize_op(expr, hop + OP_C_AP); - fx_annotate_arg(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - - if ((is_semisafe(func)) && - (is_symbol(car(expr))) && - (car(expr) != sc->values_symbol) && - (is_fxable(sc, arg2)) && - (is_pair(arg1)) && - (car(arg1) == sc->lambda_symbol)) - { - fx_annotate_arg(sc, cddr(expr), e); - set_unsafe_optimize_op(expr, hop + OP_CL_FA); - check_lambda(sc, arg1, true); /* this changes symbol_list */ - - clear_symbol_list(sc); /* so restore it */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - /* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */ - choose_c_function(sc, expr, func, 2); - if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */ - (!is_possibly_constant(caadr(arg1))))) /* parameter name not trouble */ - { - /* built-in permanent closure here was not much faster */ - set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure : NULL); - set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA); - } - return(OPT_F); - }} - return(set_any_c_np(sc, func, expr, e, 2, hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist */ - } - - if (is_closure(func)) - { - bool one_form, safe_case; - s7_pointer body; - int32_t arit = closure_arity_to_int(sc, func); - - if (arit != 2) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, 2, e)); - if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) /* (define (f a . b) ...) */ - return(optimize_closure_a_sym(sc, expr, func, hop, 2, e)); - return(OPT_F); - } - if (is_immutable(func)) hop = 1; - - body = closure_body(func); - one_form = is_null(cdr(body)); - safe_case = is_safe_closure(func); - - if ((pairs == 0) && - (symbols >= 1)) - { - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - if (symbols == 2) - { - set_opt2_sym(expr, arg2); - if (!one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_SS_O); - else - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_O); - else - { - fx_annotate_arg(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), NULL, false); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); - /* fx_annotate_args(sc, cdr(expr), e); */ - set_closure_one_form_fx_arg(func); - return(OPT_T); - } - return(OPT_F); - } - if (is_normal_symbol(arg1)) - { - if (one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); /* _A case is very rare */ - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); - set_opt2_con(expr, arg2); - return(OPT_F); - }} - - if ((!arglist_has_rest(sc, closure_args(func))) && - (fx_count(sc, expr) == 2)) - { - if (!one_form) - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_AA_O); - else - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_O); - else - { - fx_annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A); /* safe_closure_as|sa_a? */ - set_closure_one_form_fx_arg(func); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); - return(OPT_T); - } - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); - return(OPT_F); - } - - if (is_fxable(sc, arg1)) - { - set_unsafely_optimized(expr); - fx_annotate_arg(sc, cdr(expr), e); - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } - - if ((is_pair(arg1)) && - (car(arg1) == sc->lambda_symbol) && - (is_pair(cdr(arg1))) && /* not (lambda) */ - (is_fxable(sc, arg2)) && - (is_null(cdr(closure_body(func))))) - { - fx_annotate_arg(sc, cddr(expr), e); - set_opt2_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA); - check_lambda(sc, arg1, false); - - clear_symbol_list(sc); /* clobbered in check_lambda so restore it? */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - /* check_lambda calls optimize_lambda if define in progress, else just optimize on the body */ - clear_safe_closure_body(cddr(arg1)); /* otherwise we need to fixup the local let for the optimizer -- see s7test intersection case 91492 */ - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - - if (is_fxable(sc, arg2)) - { - set_unsafely_optimized(expr); - fx_annotate_arg(sc, cddr(expr), e); - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } - - if (is_safe_closure(func)) /* clo* too */ - return(set_any_closure_np(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP)); - - set_unsafely_optimized(expr); - set_optimize_op(expr, hop + OP_CLOSURE_PP); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } - - if (is_closure_star(func)) - { - if (is_immutable(func)) hop = 1; - if (fx_count(sc, expr) == 2) - { - fixup_closure_star_aa(sc, func, expr, hop); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - return(OPT_F); - }} - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == 2) && - (c_function_max_args(func) >= 1) && - (!is_symbol_and_keyword(arg2))) - { - if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1; - set_optimized(expr); - set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */ - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - set_c_function(expr, func); - return(OPT_T); - } - - if ((((is_any_vector(func)) && (vector_rank(func) == 2)) || (is_pair(func))) && - (is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - { - set_unsafe_optimize_op(expr, ((is_pair(func)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - return(OPT_T); - } - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, s7_pointer e) -{ - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); - if (pairs == 0) - { - set_optimized(expr); - if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_NC); - else - { - clear_has_fx(cdr(expr)); - if (symbols == 3) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - if (symbols == 2) - if (!is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - if (!is_normal_symbol(arg3)) - { - set_opt2_con(cdr(expr), arg3); - set_opt1_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SSC); - } - else - { - set_opt1_con(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); - } - else - if (is_normal_symbol(arg1)) - { - set_opt1_con(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCC); - } - else - if (is_normal_symbol(arg2)) - { - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_con(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - } - else - { - set_opt1_sym(cdr(expr), arg3); - set_opt2_con(cdr(expr), arg2); - set_opt3_con(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CCS); - }} - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - - /* pairs != 0 */ - if (fx_count(sc, expr) == 3) - { - set_optimized(expr); - if (quotes == 1) - { - if ((symbols == 2) && - (is_normal_symbol(arg1)) && - (is_normal_symbol(arg3))) - { - set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if (symbols == 1) - { - if ((is_normal_symbol(arg3)) && - (is_proper_quote(sc, arg2)) && - (is_safe_c_s(arg1))) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); /* lg */ - set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Pos|Ext (unchecked) */ - set_opt2_sym(cdr(expr), arg3); - set_opt3_sym(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if ((is_normal_symbol(arg2)) && - (is_proper_quote(sc, arg1)) && - (!is_pair(arg3))) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_con(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - }}} - - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - set_opt3_pair(expr, cddr(expr)); - set_optimize_op(expr, hop + OP_SAFE_C_AAA); - - if (pairs == 1) - { - if (is_pair(arg1)) set_optimize_op(expr, hop + OP_SAFE_C_AGG); - - if ((symbols == 0) && (is_pair(arg2))) - set_optimize_op(expr, hop + OP_SAFE_C_CAC); - else - { - if ((symbols == 1) && (is_pair(arg3))) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_C_CSA : OP_SAFE_C_SCA)); - else - { - if (symbols == 2) - { - if (is_normal_symbol(arg1)) - { - if (is_normal_symbol(arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSA); - clear_has_fx(cdr(expr)); /* has_fx might have been on (see s7test) */ - } - else set_optimize_op(expr, hop + OP_SAFE_C_SAS); - } - else - if (is_pair(arg1)) - set_optimize_op(expr, hop + OP_SAFE_C_ASS); - }}}} - else - if ((is_normal_symbol(arg1)) && (pairs == 2)) - set_optimize_op(expr, hop + OP_SAFE_C_SAA); - - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - return(OPT_F); /* tell caller to try something else */ -} - -static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1, arg2, arg3; - if ((quotes > 0) && - (direct_memq(sc->quote_symbol, e))) - return(OPT_OOPS); - - arg1 = cadr(expr); - arg2 = caddr(expr); - arg3 = cadddr(expr); - if (((is_symbol(arg1)) && - (!arg_findable(sc, arg1, e))) || - ((is_symbol(arg2)) && - (!arg_findable(sc, arg2, e))) || - ((is_symbol(arg3)) && - (!arg_findable(sc, arg3, e)))) - { - /* wrap bad args */ - if ((is_fxable(sc, arg1)) && - (is_fxable(sc, arg2)) && - (is_fxable(sc, arg3)) && - (s7_is_aritable(sc, func, 3))) - { - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - if (is_c_function(func)) - { - if (is_safe_procedure(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); - set_opt3_pair(cdr(expr), cdddr(expr)); - set_opt3_pair(expr, cddr(expr)); - } - else set_safe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); - set_c_function(expr, func); - return(OPT_T); - } - if ((is_closure(func)) && - (closure_arity_to_int(sc, func) == 3) && - (!arglist_has_rest(sc, closure_args(func)))) - { - set_unsafely_optimized(expr); - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3A : OP_CLOSURE_3A)); - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - if ((is_closure_star(func)) && - (lambda_has_simple_defaults(func)) && - (closure_star_arity_to_int(sc, func) != 0) && - (closure_star_arity_to_int(sc, func) != 1)) - { - set_unsafely_optimized(expr); - if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) - set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); - else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(expr, func); - }} - return(OPT_F); - } /* end of bad symbol wrappers */ - - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - - if (is_c_function(func) && (c_function_is_aritable(func, 3))) - { - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - if ((is_safe_procedure(func)) || - ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) - { - if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T) - return(OPT_T); - if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) - { - set_opt3_pair(expr, arg3); - set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP); - choose_c_function(sc, expr, func, 3); - return(OPT_F); - } - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); - } - /* func is not safe */ - if (fx_count(sc, expr) == 3) - { - set_optimized(expr); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - if (is_semisafe(func)) - set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) ? OP_CL_SAS : OP_CL_NA)); - else set_optimize_op(expr, hop + OP_C_NA); - choose_c_function(sc, expr, func, 3); - set_unsafe(expr); - return(OPT_F); - } - - /* (define (hi) (catch #t (lambda () 1) (lambda args 2))) - * first arg list must be (), second a symbol - */ - if (c_function_call(func) == g_catch) - { - if (((bad_pairs == 2) && (!is_pair(arg1))) || - ((bad_pairs == 3) && (car(arg1) == sc->quote_symbol))) - { - s7_pointer body_lambda = arg2, error_lambda = arg3; - if ((is_ok_lambda(sc, body_lambda)) && - (is_ok_lambda(sc, error_lambda)) && - (is_null(cadr(body_lambda))) && - (((is_symbol(cadr(error_lambda))) && /* (lambda args ... */ - (!is_probably_constant(cadr(error_lambda)))) || - ((is_pair(cadr(error_lambda))) && /* (lambda (type info) ... */ - (is_pair(cdadr(error_lambda))) && - (is_null(cddadr(error_lambda))) && - (!is_probably_constant(caadr(error_lambda))) && /* (lambda (pi ...) ...) */ - (!is_probably_constant(cadadr(error_lambda)))))) - { - s7_pointer error_result = caddr(error_lambda); - set_unsafely_optimized(expr); - if ((arg1 == sc->T) && /* tag is #t */ - (is_null(cdddr(error_lambda))) && /* error lambda body is one expr */ - ((!is_symbol(error_result)) || /* (lambda args #f) */ - ((is_pair(cadr(error_lambda))) && - (error_result == caadr(error_lambda)))) && /* (lambda (type info) type) */ - ((!is_pair(error_result)) || - (car(error_result) == sc->quote_symbol) || /* (lambda args 'a) */ - ((car(error_result) == sc->car_symbol) && - (is_pair(cdr(error_result))) && /* (lambda (type info) (car)) */ - (cadr(error_result) == cadr(error_lambda))))) /* (lambda args (car args) -> error-type */ - { - set_optimize_op(expr, OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */ - set_c_function(expr, func); - - if (is_pair(error_result)) - error_result = (car(error_result) == sc->quote_symbol) ? cadr(error_result) : sc->unused; - else - if (is_symbol(error_result)) - error_result = sc->unused; - set_opt2_con(expr, error_result); /* for op_c_catch_all|_a -> stack */ - - set_opt1_pair(cdr(expr), cddr(body_lambda)); - if (is_null(cdddr(body_lambda))) - { - if (is_fxable(sc, caddr(body_lambda))) - { - set_optimize_op(expr, OP_C_CATCH_ALL_A); - set_fx_direct(cddr(body_lambda), fx_choose(sc, cddr(body_lambda), sc->curlet, let_symbol_is_safe)); - } - else - { - set_opt1_pair(cdr(expr), caddr(body_lambda)); - set_optimize_op(expr, OP_C_CATCH_ALL_O); - /* fn got no hits */ - }}} - else - { - set_optimize_op(expr, OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ - choose_c_function(sc, expr, func, 3); - } - return(OPT_F); - }}} - - if ((is_semisafe(func)) && - (is_symbol(car(expr))) && (car(expr) != sc->values_symbol) && - (is_fxable(sc, arg2)) && (is_fxable(sc, arg3)) && - (is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) - { - choose_c_function(sc, expr, func, 3); - if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */ - (is_symbol(caadr(arg1))) && (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ - (is_symbol(cadadr(arg1))) && (!is_possibly_constant(cadadr(arg1)))) - { - fx_annotate_args(sc, cddr(expr), e); - check_lambda(sc, arg1, true); /* this changes symbol_list */ - - clear_symbol_list(sc); /* so restore it */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure_2 : NULL); - set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA); - return(OPT_F); - }} - - if ((is_safe_procedure(func)) || - ((is_semisafe(func)) && - (((car(expr) != sc->assoc_symbol) && (car(expr) != sc->member_symbol)) || - (unsafe_is_safe(sc, arg3, e))))) - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_ANY_C_NP)); - } - - /* not c func */ - if (is_closure(func)) - { - int32_t arit = closure_arity_to_int(sc, func); - if (arit != 3) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, 3, e)); - return(OPT_F); - } - if (is_immutable(func)) hop = 1; - - if (symbols == 3) - { - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - - if (is_safe_closure(func)) - { - if ((one_form) && - (is_fxable(sc, car(body)))) - { - set_opt2_sym(expr, arg2); - set_opt3_sym(expr, arg3); - fx_annotate_arg(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A); - set_closure_one_form_fx_arg(func); - } - else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); - return(OPT_F); - } - - if (fx_count(sc, expr) == 3) - { - if (is_safe_closure(func)) - { - if ((!is_pair(arg2)) && (!is_pair(arg3))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AGG); - else - if (is_normal_symbol(arg1)) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); - else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3A); - } - else - if ((is_normal_symbol(arg2)) && (is_normal_symbol(arg3))) - set_optimize_op(expr, hop + OP_CLOSURE_ASS); - else - if (is_normal_symbol(arg1)) - set_optimize_op(expr, hop + ((is_normal_symbol(arg3)) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); - else - if (is_normal_symbol(arg3)) - set_optimize_op(expr, hop + OP_CLOSURE_AAS); - else set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_CLOSURE_ASA : OP_CLOSURE_3A)); - set_unsafely_optimized(expr); - fx_annotate_args(sc, cdr(expr), e); - - if (is_fx_treeable(cdr(expr))) - fx_tree(sc, closure_body(func), car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); - - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - return(OPT_F); - } - return(set_any_closure_np(sc, func, expr, e, 3, hop + OP_ANY_CLOSURE_3P)); - } - - if (is_closure_star(func)) - { - if ((!lambda_has_simple_defaults(func)) || - (closure_star_arity_to_int(sc, func) == 0) || - (closure_star_arity_to_int(sc, func) == 1)) - return(OPT_F); - if (fx_count(sc, expr) == 3) - { - if (is_immutable(func)) hop = 1; - if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) - set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); - else set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - return(OPT_F); - }} - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == 3) && - (c_function_max_args(func) >= 2)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - set_c_function(expr, func); - return(OPT_T); - } - /* implicit_vector_3a doesn't happen */ - - if (bad_pairs > quotes) return(OPT_F); - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_normal_symbol(arg)) && - (!arg_findable(sc, arg, e))) - return(false); - } - return(true); -} - -static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - bool func_is_closure; - if (quotes > 0) - { - if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - } - if ((is_c_function(func)) && (c_function_is_aritable(func, args))) - { - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - if (is_safe_procedure(func)) - { - if (pairs == 0) - { - if (symbols == 0) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); - choose_c_function(sc, expr, func, args); - return(OPT_T); - } - if (symbols == args) - { - if (symbols_are_safe(sc, cdr(expr), e)) - set_safe_optimize_op(expr, hop + OP_SAFE_C_NS); - else - { - set_safe_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - } - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - return(OPT_T); - }} - - if (fx_count(sc, expr) == args) - { - s7_pointer p; - set_optimized(expr); - set_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - - for (p = cdr(expr); (is_pair(p)) && (is_pair(cdr(p))); p = cddr(p)) - { - if (is_normal_symbol(car(p))) - break; - if ((is_pair(car(p))) && - ((!is_pair(cdar(p))) || (caar(p) != sc->quote_symbol))) - break; - } - if (is_null(p)) - { - set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA); - for (p = cdr(expr); is_pair(p); p = cddr(p)) - { - clear_has_fx(p); - set_opt2_con(p, (is_pair(car(p))) ? cadar(p) : car(p)); - }} - return(OPT_T); - } - return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); - } - /* c_func is not safe */ - if (fx_count(sc, expr) == args) /* trigger_size doesn't matter for unsafe funcs */ - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - return(OPT_F); - } - return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ - } - - func_is_closure = is_closure(func); - if (func_is_closure) - { - int32_t arit = closure_arity_to_int(sc, func); - if (arit != args) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, args, e)); - return(OPT_F); - } - if (is_immutable(func)) hop = 1; - - if (fx_count(sc, expr) == args) - { - bool safe_case = is_safe_closure(func); - set_unsafely_optimized(expr); - set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - - if ((symbols == args) && - (symbols_are_safe(sc, cdr(expr), e))) - { - if (safe_case) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); - else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : OP_CLOSURE_NS)); - } - return(OPT_F); - } - if (args == 4) - return(set_any_closure_np(sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P)); - return(set_any_closure_np(sc, func, expr, e, args, hop + OP_ANY_CLOSURE_NP)); - } - - if ((is_closure_star(func)) && - ((!lambda_has_simple_defaults(func)) || - (closure_star_arity_to_int(sc, func) == 0) || - (closure_star_arity_to_int(sc, func) == 1))) - return(OPT_F); - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == args) && - (c_function_max_args(func) >= (args / 2))) - { - if (is_immutable(func)) hop = 1; - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_c_function(expr, func); - return(OPT_T); - } - if (((func_is_closure) || - (is_closure_star(func))) && - (fx_count(sc, expr) == args)) - { - set_unsafely_optimized(expr); - if (func_is_closure) - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); - else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static bool vars_syntax_ok(s7_pointer vars) -{ - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_pair(var)) || - (!is_symbol(car(var))) || - (!is_pair(cdr(var)))) - return(false); - } - return(true); -} - -static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok); - -static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer e) -{ - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer init = cadar(p); - /* if ((is_slot(global_slot(caar(p)))) && (is_c_function(global_value(caar(p))))) return(false); */ /* too draconian (see snd-test) */ - if ((is_pair(init)) && - (!is_checked(init)) && - (optimize_expression(sc, init, hop, e, false) == OPT_OOPS)) - return(false); - } - return(true); -} - -static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e, bool export_ok) -{ - opcode_t op = syntax_opcode(func); - s7_pointer body = cdr(expr), vars; - bool body_export_ok = true; - - sc->w = e; - switch (op) - { - case OP_QUOTE: - case OP_MACROEXPAND: - return((is_proper_list_1(sc, body)) ? OPT_F : OPT_OOPS); - - case OP_LET: - case OP_LETREC: - case OP_LET_STAR: - case OP_LETREC_STAR: - if (is_symbol(cadr(expr))) - { - if (!is_pair(cddr(expr))) /* (let name . x) */ - return(OPT_F); - vars = caddr(expr); - if (!is_list(vars)) return(OPT_OOPS); - body = cdddr(expr); - } - else - { - vars = cadr(expr); - body = cddr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); /* () in e = empty let */ - else - if (!is_pair(vars)) - return(OPT_OOPS); - } - if (!is_pair(body)) return(OPT_OOPS); - - if (!vars_syntax_ok(vars)) - return(OPT_OOPS); - - if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) - { - e = collect_variables(sc, vars, e); - if (!vars_opt_ok(sc, vars, hop, e)) - return(OPT_OOPS); - } - else - if (op == OP_LET) - { - if (!vars_opt_ok(sc, vars, hop, e)) - return(OPT_OOPS); - e = collect_variables(sc, vars, e); - } - else - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - e = cons(sc, add_symbol_to_list(sc, car(var)), e); - sc->w = e; - } - if (is_symbol(cadr(expr))) - { - e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e); - sc->w = e; - } - break; - - case OP_LET_TEMPORARILY: - vars = cadr(expr); - if (!is_list(vars)) return(OPT_OOPS); - body = cddr(expr); - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(vars); - if ((is_pair(var)) && - (is_pair(cdr(var))) && - (is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - /* e = cons(sc, sc->nil, e); */ /* !? currently let-temporarily does not make a new let, so it is like begin? */ - body_export_ok = export_ok; /* (list x (let-temporarily () (define x 0))) just as in begin */ - break; - - case OP_DO: - vars = cadr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); - else - if (!is_pair(vars)) - return(OPT_OOPS); - body = cddr(expr); - - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_pair(var)) || - (!is_symbol(car(var))) || - (!is_pair(cdr(var)))) - return(OPT_OOPS); - if ((is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) /* the init field -- locals are not defined yet */ - return(OPT_OOPS); - } - e = collect_variables(sc, vars, e); - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = cddar(p); - if ((is_pair(var)) && - (is_pair(car(var))) && - (!is_checked(car(var))) && - (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) /* the step field -- locals are defined */ - return(OPT_OOPS); - } - break; - - case OP_BEGIN: - body_export_ok = export_ok; /* (list x (begin (define x 0))) */ - break; - - case OP_WITH_BAFFLE: - e = cons(sc, sc->nil, e); - break; - - case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: - case OP_BACRO: case OP_BACRO_STAR: - return(OPT_F); - - case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: - case OP_DEFINE_CONSTANT: case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: - case OP_DEFINE: case OP_DEFINE_STAR: - /* define adds a name to the incoming let (e), the added name is inserted into e after the first, so the caller - * can flush added symbols by maintaining its own pointer into the list if blockers set the car. - * the list is used both to see local symbols and to catch "complicated" functions (find_uncomplicated_symbol). - * In cases like (if expr (define...)) we can't tell at this level whether the define takes place, so - * its name should not be in "e", but it needs to be marked for find_uncomplicated_symbol in a way - * that can be distinguished from members of "e". So in that (rare) case, we use the associated keyword. - * Then find_uncomplicated_symbol can use has_keyword to tell if the keyword search is needed. - * export_ok is trying to protect against optimizing (list x (define x 0)) as op_safe_c_sp and all related cases - */ - vars = cadr(expr); - body = cddr(expr); - if (is_pair(vars)) - { - if ((export_ok) && - (is_symbol(car(vars)))) - { - add_symbol_to_list(sc, car(vars)); - if (is_pair(e)) - { - if (car(e) != sc->if_keyword) - set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */ - else add_symbol_to_list(sc, symbol_to_keyword(sc, car(vars))); - } - else e = cons(sc, car(vars), e); - } - e = collect_parameters(sc, cdr(vars), e); - body_export_ok = export_ok; - } - else - { - if ((export_ok) && - (is_symbol(vars))) - { - /* actually if this is defining a function, the name should probably be included in the local let - * but that's next-to-impossible to guarantee unless it's (define x (lambda...)) of course. - */ - sc->temp9 = e; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ - (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS)) /* "body" here is not body in terms of export_ok */ - { - sc->temp9 = sc->unused; - return(OPT_OOPS); - } - sc->temp9 = sc->unused; - - add_symbol_to_list(sc, vars); - if (is_pair(e)) - { - if (car(e) != sc->if_keyword) - set_cdr(e, cons(sc, vars, cdr(e))); /* export it */ - else add_symbol_to_list(sc, symbol_to_keyword(sc, vars)); - } - /* else e = cons(sc, vars, e); */ /* ?? should this be set-cdr etc? */ - return(OPT_F); - } - body_export_ok = false; - } - break; - - case OP_LAMBDA: case OP_LAMBDA_STAR: - case OP_MACRO: case OP_MACRO_STAR: - vars = cadr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); - else - if ((!is_pair(vars)) && (!is_symbol(vars))) - return(OPT_OOPS); - e = collect_parameters(sc, vars, e); - body = cddr(expr); - break; - - case OP_SET: - if ((is_pair(cadr(expr))) && (caadr(expr) == sc->outlet_symbol)) - return(OPT_OOPS); - if (!is_pair(cddr(expr))) - return(OPT_OOPS); - if ((is_pair(cadr(expr))) && - (!is_checked(cadr(expr)))) - { - set_checked(cadr(expr)); - for (s7_pointer lp = cdadr(expr); is_pair(lp); lp = cdr(lp)) - if ((is_pair(car(lp))) && - (!is_checked(car(lp))) && - (optimize_expression(sc, car(lp), hop, e, body_export_ok) == OPT_OOPS)) - return(OPT_OOPS); - } - if ((is_pair(caddr(expr))) && - (!is_checked(caddr(expr))) && - (optimize_expression(sc, caddr(expr), hop, e, body_export_ok) == OPT_OOPS)) - return(OPT_OOPS); - - if ((is_pair(cadr(expr))) && (caadr(expr) == sc->s7_starlet_symbol)) - return(OPT_T); - return(OPT_F); - - case OP_WITH_LET: - /* we usually can't trust anything here, so hop ought to be off. For example, - * (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1)))) - * returns 1 if hop is 1, but -2 otherwise. (with-let (unlet)...) is safe however. - */ - { - bool old_with_let = sc->in_with_let; - sc->in_with_let = (old_with_let) || (!is_pair(body)) || (!is_pair(car(body))) || - ((caar(body) != sc->unlet_symbol) && /* (caar(body) != sc->rootlet_symbol) && */ (caar(body) != sc->curlet_symbol)); - /* not rootlet here: (let ((i 0)) (_rd3_ (with-let (rootlet) ((null? i) i)))) */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && - (optimize_expression(sc, car(p), 0, sc->nil, body_export_ok) == OPT_OOPS)) - { - sc->in_with_let = old_with_let; - return(OPT_OOPS); - } - sc->in_with_let = old_with_let; - return(OPT_F); - } - - case OP_CASE: - if ((is_pair(cadr(expr))) && - (!is_checked(cadr(expr))) && - (optimize_expression(sc, cadr(expr), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - for (s7_pointer p = cddr(expr); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (is_pair(cdar(p)))) - for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) - if ((is_pair(car(rst))) && - (!is_checked(car(rst))) && - (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - return(OPT_F); - - case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - if (is_pair(car(p))) - { - s7_pointer test = caar(p); - e = cons(sc, sc->if_keyword, e); /* I think this is a marker in case define is encountered? (see above) */ - if ((is_pair(test)) && - (!is_checked(test)) && - (optimize_expression(sc, test, hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) - if ((is_pair(car(rst))) && - (!is_checked(car(rst))) && - (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - { - s7_pointer q; - if ((!is_pair(car(p))) || (!is_fxable(sc, caar(p)))) - break; - if (!is_pair(cdar(p))) - break; - for (q = cdar(p); is_pair(q); q = cdr(q)) - if ((car(q) == sc->feed_to_symbol) || (!is_fxable(sc, car(q)))) - break; - if (!is_null(q)) break; - } - if (!is_null(p)) return(OPT_F); - set_safe_optimize_op(expr, OP_COND_NA_NA); - } - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - set_fx_direct(car(p), fx_choose(sc, car(p), e, pair_symbol_is_safe)); - for (s7_pointer q = cdar(p); is_pair(q); q = cdr(q)) - set_fx_direct(q, fx_choose(sc, q, e, pair_symbol_is_safe)); - } - return(OPT_T); - - case OP_IF: case OP_WHEN: case OP_UNLESS: - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) - return(OPT_OOPS); - case OP_OR: case OP_AND: - e = cons(sc, sc->if_keyword, e); - break; - - default: - break; - } - - sc->temp9 = e; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ - (optimize_expression(sc, car(p), hop, e, body_export_ok) == OPT_OOPS)) - { - sc->temp9 = sc->unused; - return(OPT_OOPS); - } - sc->temp9 = sc->unused; - - if ((hop == 1) && - ((is_syntax(car(expr))) || - (symbol_id(car(expr)) == 0))) - { - if (op == OP_IF) - { - s7_pointer test = cdr(expr), b1, b2, p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - if ((is_pair(cdr(test))) && (is_pair(cddr(test))) && (!is_null(cdddr(test)))) - return(OPT_OOPS); - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - - b1 = cdr(test); - b2 = cdr(b1); - if ((fx_proc(b1) == fx_q) && - (is_pair(b2))) - { - set_opt3_con(test, cadar(b1)); - if (fx_proc(b2) == fx_q) - { - set_safe_optimize_op(expr, OP_IF_A_C_C); - set_opt1_con(expr, cadar(b1)); - set_opt2_con(expr, cadar(b2)); - return(OPT_T); - } - set_opt1_pair(expr, b1); - set_opt2_pair(expr, b2); - set_safe_optimize_op(expr, OP_IF_A_A_A); - } - else - { - if ((is_pair(car(test))) && - (caar(test) == sc->not_symbol) && - (is_fxable(sc, cadar(test)))) - { - set_fx_direct(cdar(test), fx_choose(sc, cdar(test), e, pair_symbol_is_safe)); - set_opt1_pair(expr, cdar(test)); - set_opt2_pair(expr, b1); - if (is_pair(b2)) set_opt3_pair(expr, b2); - set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_NOT_A_A : OP_IF_NOT_A_A_A); - } - else - { - if ((is_pair(b2)) && (fx_proc(b1) == fx_c) && (fx_proc(b2) == fx_c)) - { - set_safe_optimize_op(expr, OP_IF_A_C_C); - set_opt1_con(expr, car(b1)); - set_opt2_con(expr, car(b2)); - return(OPT_T); - } - if ((fx_proc(test) == fx_and_2a) && (fx_proc(b1) == fx_s)) - { - set_opt1_pair(expr, cdadr(expr)); - set_opt2_pair(expr, cddadr(expr)); - set_opt3_sym(expr, car(b1)); - set_safe_optimize_op(expr, OP_IF_AND2_S_A); - return(OPT_T); - } - set_opt1_pair(expr, b1); - if (is_pair(b2)) set_opt2_pair(expr, b2); - set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_A_A : ((fx_proc(test) == fx_s) ? OP_IF_S_A_A : OP_IF_A_A_A)); - }} - return(OPT_T); - } - else - { - if ((op == OP_OR) || (op == OP_AND)) - { - int32_t args, pairs = 0; - s7_pointer p, sym = NULL; - bool c_s_is_ok = true; - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - for (args = 0, p = cdr(expr); is_pair(p); p = cdr(p), args++) /* this only applies to or/and */ - if (is_pair(car(p))) - { - pairs++; - if ((c_s_is_ok) && - ((!is_h_safe_c_s(car(p))) || - ((sym) && (sym != cadar(p))))) - c_s_is_ok = false; - else sym = (is_pair(cdar(p))) ? cadar(p) : sc->unspecified; - } - - if ((c_s_is_ok) && (args == 2) && (pairs == 2)) - { - if (op == OP_OR) - { - set_opt3_sym(cdr(expr), cadadr(expr)); - if ((is_symbol(caadr(expr))) && (symbol_type(caadr(expr)) > 0) && (is_global(caadr(expr))) && - ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > 0) && (is_global(caaddr(expr))))) - { - set_opt3_int(expr, symbol_type(caadr(expr))); - set_opt2_int(cdr(expr), symbol_type(caaddr(expr))); - set_safe_optimize_op(expr, OP_OR_S_TYPE_2); - } - else set_safe_optimize_op(expr, OP_OR_S_2); - } - else - { - set_opt3_sym(cdr(expr), cadadr(expr)); - set_safe_optimize_op(expr, OP_AND_S_2); - } - return(OPT_T); - } - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - if (op == OP_OR) - { - if (args == 2) - set_safe_optimize_op(expr, OP_OR_2A); - else - { - if (args == 3) - set_safe_optimize_op(expr, OP_OR_3A); - else set_safe_optimize_op(expr, OP_OR_N); - } - return(OPT_T); - } - if (args == 2) - set_safe_optimize_op(expr, OP_AND_2A); - else set_safe_optimize_op(expr, (args == 3) ? OP_AND_3A : OP_AND_N); - return(OPT_T); - } - else - if (op == OP_BEGIN) - { - s7_pointer p; - if (!is_pair(cdr(expr))) return(OPT_F); - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - set_safe_optimize_op(expr, ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) ? OP_BEGIN_AA : OP_BEGIN_NA); - return(OPT_T); - }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ - return(OPT_F); -} - - -static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t orig_hop, s7_pointer e) -{ - int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0; - s7_pointer p; - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(expr)); - for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */ - { - s7_pointer car_p = car(p); - if (is_normal_symbol(car_p)) /* for opt func */ - symbols++; - else - if (is_pair(car_p)) - { - pairs++; - if (!is_checked(car_p)) - { - opt_t res; - if ((is_pair(car(car_p))) && (caar(car_p) == sc->let_symbol)) /* TODO: fix this! ((let () quasiquote) (vector i x)) -> apply in a function! */ - res = OPT_F; /* maybe: is_syntactic_symbol through car(car_p)? */ - else res = optimize_expression(sc, car_p, orig_hop, e, false); - if (res == OPT_F) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - } - else - if (res == OPT_OOPS) - return(OPT_OOPS); - } - else - if ((!is_optimized(car_p)) || - (is_unsafe(car_p))) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }}} - if (is_null(p)) /* if not null, dotted list of args, (cons 1 . 2) etc -- error perhaps? */ - { - switch (args) - { - case 0: return(optimize_thunk(sc, expr, func, hop, e)); - case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e)); - }} - return(OPT_OOPS); /* was OPT_F, but this is always an error */ -} - -static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok) -{ - s7_pointer car_expr = car(expr); - int32_t orig_hop = hop; - set_checked(expr); - - if (is_symbol(car_expr)) - { - s7_pointer slot; - if (is_syntactic_symbol(car_expr)) - { - if (!is_pair(cdr(expr))) - return(OPT_OOPS); - return(optimize_syntax(sc, expr, T_Syn(global_value(car_expr)), hop, e, export_ok)); - } - slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered complicated */ - if (is_slot(slot)) - { - s7_pointer func = slot_value(slot); - if (is_syntax(func)) /* not is_syntactic -- here we have the value */ - return((is_pair(cdr(expr))) ? optimize_syntax(sc, expr, func, hop, e, export_ok) : OPT_OOPS); /* e can be extended via set-cdr! here */ - - if (is_any_macro(func)) - return(OPT_F); - - /* we miss implicit indexing here because at this time, the data are not set */ - if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */ - ((is_applicable(func)) && - (is_safe_procedure(func)))) /* built-in applicable objects like vectors */ - { - if ((hop != 0) && - ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ - ((!is_global(car_expr)) && - ((!is_slot(global_slot(car_expr))) || - (global_value(car_expr) != func)))) && - (!is_immutable(car_expr)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */ - (!is_immutable(slot))) /* (define-constant...) */ - { - /* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a)) (f1 12)) - * (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a 1)) (f1 12)) - * and similar define* cases - */ - hop = 0; - /* this is very tricky! See s7test for some cases. Basically, we need to protect a recursive call - * of the current function being optimized from being confused with some previous definition - * of the same name. But method lists have global names so the global bit is off even though the - * thing is actually a safe global. But no closure can be considered safe in the hop sense -- - * even a global function might be redefined at any time, and previous uses of it in other functions - * need to reflect its new value. - * So, closures are always checked, but built-in functions are used as if never redefined until that redefinition. - * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't - * offend me much. Consider each a sort of reader macro until someone redefines it -- previous - * uses might not be affected because they might have been optimized away -- the result depends on the - * current optimizer. - * Another case (from K Matheussen): - * (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2) - * when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is - * not good enough -- if we load mockery.scm, nothing is global! - * Yet another case (define (test-abs) (define (abs x) (+ x 1)) (format *stderr* "abs ~A~%" (abs -1))) - * when optimize_syntax sees the (define abs ...), it inserts abs into e so that the caller's e is extended (set-cdr!) - * so that find_uncomplicated_symbol above will be unhappy when we reach (abs -1) as the format arg. - * This can be confused if lambda is redefined at some point, but... - */ - } - return(optimize_funcs(sc, expr, func, hop, orig_hop, e)); - }} - else - if ((sc->undefined_identifier_warnings) && - (slot == sc->undefined) && /* car_expr is not in e or global */ - (symbol_tag(car_expr) == 0)) /* and we haven't looked it up earlier */ - { - s7_pointer p = current_input_port(sc); - if ((is_input_port(p)) && - (port_file(p) != stdin) && - (!port_is_closed(p)) && - (port_filename(p))) - s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(car_expr), port_filename(p), port_line_number(p)); - else s7_warn(sc, 1024, "; %s might be undefined\n", display(car_expr)); - symbol_set_tag(car_expr, 1); /* one warning is enough */ - } - - /* car_expr is a symbol but it's not a built-in procedure or a safe case = vector etc */ - { - /* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */ - s7_pointer p; - int32_t len = 0, pairs = 0, symbols = 0; - - for (p = cdr(expr); is_pair(p); p = cdr(p), len++) - { - s7_pointer car_p = car(p); - if (is_pair(car_p)) - { - pairs++; - if ((!is_checked(car_p)) && - (optimize_expression(sc, car_p, hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - else - if (is_symbol(car_p)) - symbols++; - } - if ((is_null(p)) && /* (+ 1 . 2) */ - (!is_optimized(expr))) - { - /* len=0 case is almost entirely arglists */ - set_opt1_con(expr, sc->unused); - - if (pairs == 0) - { - if (len == 0) - { - /* hoping to catch object application here, as in readers in Snd */ - set_unsafe_optimize_op(expr, OP_UNKNOWN); - return(OPT_F); - } - if (len == 1) - { - if (car_expr != sc->quote_symbol) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */ - set_unsafe_optimize_op(expr, (is_normal_symbol(cadr(expr))) ? OP_UNKNOWN_S : OP_UNKNOWN_A); - fx_annotate_arg(sc, cdr(expr), e); /* g->a later if closure */ - return(OPT_F); - } - if (len == 2) - { - set_unsafely_optimized(expr); - set_optimize_op(expr, OP_UNKNOWN_GG); - return(OPT_F); - } - if (len >= 3) - { - if (len == symbols) - { - set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - } - if (fx_count(sc, expr) == len) - { - set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - }}} - else /* pairs != 0 */ - { - s7_pointer arg1 = cadr(expr); - if ((pairs == 1) && (len == 1)) - { - if ((car_expr == sc->quote_symbol) && - (direct_memq(sc->quote_symbol, e))) - return(OPT_OOPS); - - if (is_fxable(sc, arg1)) - { - set_opt3_arglen(cdr(expr), 1); - fx_annotate_arg(sc, cdr(expr), e); - set_unsafe_optimize_op(expr, OP_UNKNOWN_A); - return(OPT_F); - }} - if (fx_count(sc, expr) == len) - { - set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : ((len == 2) ? OP_UNKNOWN_AA : OP_UNKNOWN_NA)); - set_opt3_arglen(cdr(expr), len); - if (len <= 2) fx_annotate_args(sc, cdr(expr), e); - return(OPT_F); - } - set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - }}}} - else - { - /* car(expr) is not a symbol, but there might be interesting stuff here */ - /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */ - s7_pointer p; - - if (is_c_function(car_expr)) /* (#_abs x) etc */ - return(optimize_funcs(sc, expr, car_expr, 1, orig_hop, e)); - - if (is_syntax(car_expr)) /* (#_cond ...) */ - { - if (!is_pair(cdr(expr))) - return(OPT_OOPS); - return(optimize_syntax(sc, expr, car_expr, orig_hop, e, export_ok)); - } - if (is_any_macro(car_expr)) - return(OPT_F); - - /* if car is a pair, we can't easily tell whether its value is (say) + or cond, so we need to catch this case and fixup fx settings */ - for (p = expr; is_pair(p); p = cdr(p)) - if (((is_symbol(car(p))) && (is_syntactic_symbol(car(p)))) || - ((is_pair(car(p))) && (!is_checked(car(p))) && - (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS))) - return(OPT_OOPS); - /* here we get for example: - * ((if (not (let? p)) write write-to-vector) obj p) ; not uncomplicated/c-function [((if 3d fourth third) p) in index] - * ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol -- opif_a_aaq_a - * ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ; not safe I guess - */ - } - return(OPT_F); -} - -static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) -{ - s7_pointer x; - for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x)) - { - s7_pointer obj = car(x); - set_checked(x); - if (is_pair(obj)) - { - if ((!is_checked(obj)) && - (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) - { - s7_pointer p; - for (p = cdr(x); is_pair(p); p = cdr(p)); - if (!is_null(p)) - syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); - return(OPT_OOPS); - }} - else /* new 22-Sep-19, but I don't think this saves anything over falling into trailers */ - if (is_symbol(obj)) - set_optimize_op(obj, (is_keyword(obj)) ? OP_CONSTANT : OP_SYMBOL); - else set_optimize_op(obj, OP_CONSTANT); - } - if (!is_list(x)) - syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); - return(OPT_F); -} - - -static bool symbol_is_in_arg_list(s7_pointer sym, s7_pointer lst) -{ - s7_pointer x; - for (x = lst; is_pair(x); x = cdr(x)) - if ((sym == car(x)) || - ((is_pair(car(x))) && (sym == caar(x)))) - return(true); - return(sym == x); -} - -static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7_pointer form) -{ - s7_pointer x; - int32_t i; - - if (!is_list(args)) - { - if (is_constant(sc, args)) /* (lambda :a ...) or (define (f :a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda parameter is a constant: (~S ~S ...)", 43), car(form), cadr(form))); - /* we currently accept (lambda i i . i) (lambda quote i) (lambda : : . #()) (lambda : 1 . "") - * at this level, but when the lambda form is evaluated, it will trigger an error. - */ - if (is_symbol(args)) set_local(args); - if (arity) (*arity) = -1; - return; - } - for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) - { - s7_pointer car_x = car(x); - if (is_constant(sc, car_x)) /* (lambda (pi) pi), constant here means not a symbol */ - { - if (is_pair(car_x)) /* (lambda ((:hi . "hi") . "hi") 1) */ - error_nr(sc, sc->syntax_error_symbol, /* don't use ~A here or below, (lambda #\null do) for example */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a pair (perhaps use lambda*?): (~S ~S ...)", 65), - car_x, car(form), cadr(form))); - if ((car_x == sc->rest_keyword) && - ((car(form) == sc->define_symbol) || (car(form) == sc->lambda_symbol))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "lambda parameter is ~S? (~S ~S ...), perhaps use ~S", 51), - car_x, car(form), cadr(form), - (car(form) == sc->define_symbol) ? sc->define_star_symbol : sc->lambda_star_symbol)); - error_nr(sc, sc->syntax_error_symbol, /* (lambda (a :b c) 1) */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: (~S ~S ...)", 46), - car_x, car(form), cadr(form))); - } - if (symbol_is_in_arg_list(car_x, cdr(x))) /* (lambda (a a) ...) or (lambda (a . a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is used twice in the parameter list, (~S ~S ...)", 68), - car_x, car(form), cadr(form))); - set_local(car_x); - } - if (is_not_null(x)) - { - if (is_constant(sc, x)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda :rest parameter ~S is a constant in (~S ~S ...)", 54), - x, car(form), cadr(form))); - i = -i - 1; - } - if (arity) (*arity) = i; -} - -static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_pointer body, s7_pointer form) /* checks closure*, macro*, and bacro* */ -{ - s7_pointer top, v, w; - int32_t i; - bool has_defaults; - - if (!is_list(args)) - { - if (is_constant(sc, args)) /* (lambda* :a ...) or (define* (f . :a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda* parameter is a constant: (~S ~S ...)", 44), car(form), cadr(form))); - if (is_symbol(args)) set_local(args); - return(args); - } - - has_defaults = false; - top = args; - for (i = 0, v = args, w = args; is_pair(w); i++, v = w, w = cdr(w)) - { - s7_pointer car_w = car(w); - if (is_pair(car_w)) - { - has_defaults = true; - if (is_constant(sc, car(car_w))) /* (lambda* ((:a 1)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), - car(car_w), car(form), cadr(form))); - if (symbol_is_in_arg_list(caar(w), cdr(w))) /* (lambda* ((a 1) a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S occurs twice in the argument list: (~S ~S ...)", 67), - car(car_w), car(form), cadr(form))); - if (!is_pair(cdr(car_w))) - { - if (is_null(cdr(car_w))) /* (lambda* ((a)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value missing in (~S ~S ...)", 57), - car_w, car(form), cadr(form))); - error_nr(sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a dotted pair in (~S ~S ...)", 52), - car_w, car(form), cadr(form))); - } - if ((is_pair(cadr(car_w))) && /* (lambda* ((a (quote . -1))) ...) */ - (s7_list_length(sc, cadr(car_w)) < 0)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value is not a proper list in (~S ~S ...)", 70), - car_w, car(form), cadr(form))); - if (is_not_null(cddr(car_w))) /* (lambda* ((a 0.0 'hi)) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S has multiple default values in (~S ~S ...)", 63), - car_w, car(form), cadr(form))); - - set_local(car(car_w)); - } - else - if (car_w != sc->rest_keyword) - { - if (is_constant(sc, car_w)) - { - if (car_w != sc->allow_other_keys_keyword) - error_nr(sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), - car_w, car(form), cadr(form))); - if (is_not_null(cdr(w))) /* (lambda* (:allow-other-keys x) x) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, ":allow-other-keys should be the last parameter: (~S ~S ...)", 59), - car(form), cadr(form))); - if (w == top) /* (lambda* (:allow-other-keys) 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, ":allow-other-keys can't be the only parameter: (~S ~S ...)", 58), - car(form), cadr(form))); - set_allow_other_keys(top); - set_cdr(v, sc->nil); - } - if (symbol_is_in_arg_list(car_w, cdr(w))) /* (lambda* (a a) ...) or (lambda* (a . a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is used twice in the parameter list: (~S ~S ...)", 69), - car_w, car(form), cadr(form))); - - if (!is_keyword(car_w)) set_local(car_w); - } - else - { - has_defaults = true; - if (!is_pair(cdr(w))) /* (lambda* (:rest) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda* :rest parameter missing in (~S ~S ...)", 46), - car(form), cadr(form))); - if (!is_symbol(cadr(w))) /* (lambda* (:rest (a 1)) ...) */ - { - if (!is_pair(cadr(w))) /* (lambda* (:rest 1) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter is not a symbol: ~S in (~S ~S ...)", 58), - w, car(form), cadr(form))); - error_nr(sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter can't have a default value: ~S in (~S ~S ...)", 69), - w, car(form), cadr(form))); - } - if (is_constant(sc, cadr(w))) /* (lambda* (a :rest x) ...) where x is locally a constant */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "lambda*: ~S is immutable, so it can't be the :rest parameter name: (~S ~S ...)", 78), - cadr(w), car(form), cadr(form))); - set_local(cadr(w)); - }} - if (is_not_null(w)) - { - if (is_constant(sc, w)) /* (lambda* (a . 0.0) a) or (lambda* (a . :b) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter ~S is a constant, (~S ~S ...)", 53), - w, car(form), cadr(form))); - if (is_symbol(w)) - set_local(w); - } - else - if ((body) && (!has_defaults) && (is_pair(args))) - set_has_no_defaults(body); - return(top); -} - -static void set_rec_tc_args(s7_scheme *sc, s7_int args) -{ - if (sc->rec_tc_args == -1) - sc->rec_tc_args = args; - else - if (sc->rec_tc_args != args) - sc->rec_tc_args = -2; -} - -typedef enum {UNSAFE_BODY=0, RECUR_BODY, SAFE_BODY, VERY_SAFE_BODY} body_t; -static body_t min_body(body_t b1, body_t b2) {return((b1 < b2) ? b1 : b2);} -static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end); - -static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at_end) /* called only from body_is_safe */ -{ - s7_pointer expr = car(x); - body_t result = VERY_SAFE_BODY; - - if (is_symbol_and_syntactic(expr)) - { - if (!is_pair(cdr(x))) return(UNSAFE_BODY); - switch (symbol_syntax_op_checked(x)) - /* symbol_syntax_op(expr) here gets tangled in fx_annotation order problems! -- fix this?!? - * it appears that safe bodies are marked unsafe because the opts are out-of-order? - */ - { - case OP_OR: case OP_AND: case OP_BEGIN: case OP_WITH_BAFFLE: - return(body_is_safe(sc, func, cdr(x), at_end)); - - case OP_MACROEXPAND: - return(UNSAFE_BODY); - - case OP_QUOTE: case OP_QUOTE_UNCHECKED: - return(((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (quote . 1) or (quote 1 2) etc */ - - case OP_IF: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (is_pair(caddr(x))) - { - result = min_body(result, form_is_safe(sc, func, caddr(x), at_end)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if ((is_pair(cdddr(x))) && - (is_pair(cadddr(x)))) - return(min_body(result, form_is_safe(sc, func, cadddr(x), at_end))); - return(result); - - case OP_WHEN: case OP_UNLESS: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - return(min_body(result, body_is_safe(sc, func, cddr(x), at_end))); - - case OP_COND: - { - bool follow = false; - s7_pointer p = cdr(x); - for (s7_pointer sp = x; is_pair(p); p = cdr(p)) - { - s7_pointer ex = car(p); - if (!is_pair(ex)) return(UNSAFE_BODY); - if (is_pair(car(ex))) - { - result = min_body(result, form_is_safe(sc, func, car(ex), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (is_pair(cdr(ex))) - { - result = min_body(result, body_is_safe(sc, func, cdr(ex), at_end)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return((is_null(p)) ? result : UNSAFE_BODY); - } - - case OP_CASE: - { - bool follow = false; - s7_pointer sp, p; - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - sp = cdr(x); - for (p = cdr(sp); is_pair(p); p = cdr(p)) - { - if (!is_pair(car(p))) return(UNSAFE_BODY); - if (is_pair(cdar(p))) - { - result = min_body(result, body_is_safe(sc, func, cdar(p), at_end)); /* null cdar(p) ok here */ - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return(result); - } - - case OP_SET: - /* if we set func, we have to abandon the tail call scan: (let () (define (hi a) (let ((v (vector 1 2 3))) (set! hi v) (hi a))) (hi 1)) */ - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (cadr(x) == func) return(UNSAFE_BODY); - - /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */ - if (is_pair(caddr(x))) - { - result = form_is_safe(sc, func, caddr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); - /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ - - case OP_WITH_LET: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - return((is_pair(cadr(x))) ? UNSAFE_BODY : min_body(body_is_safe(sc, sc->F, cddr(x), at_end), SAFE_BODY)); - /* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */ - - case OP_LET_TEMPORARILY: - if (!is_pair(cadr(x))) return(UNSAFE_BODY); - for (s7_pointer p = cadr(x); is_pair(p); p = cdr(p)) - { - if ((!is_pair(car(p))) || - (!is_pair(cdar(p)))) - return(UNSAFE_BODY); - if (is_pair(cadar(p))) - { - result = min_body(result, form_is_safe(sc, sc->F, cadar(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - }} - return(min_body(result, body_is_safe(sc, sc->F, cddr(x), at_end))); - - /* in the name binders, we first have to check that "func" actually is the same thing as the caller's func */ - case OP_LET: case OP_LET_STAR: case OP_LETREC: case OP_LETREC_STAR: - { - bool follow = false; - s7_pointer let_name, sp, vars = cadr(x), body = cddr(x); - if (is_symbol(vars)) - { - if (!is_pair(body)) return(UNSAFE_BODY); /* (let name . res) */ - if (vars == func) return(UNSAFE_BODY); /* named let shadows caller */ - let_name = vars; - vars = caddr(x); - body = cdddr(x); - if (is_symbol(func)) - add_symbol_to_list(sc, func); - } - else let_name = func; - - for (sp = NULL; is_pair(vars); vars = cdr(vars)) - { - s7_pointer let_var = car(vars), var_name; - - if ((!is_pair(let_var)) || - (!is_pair(cdr(let_var)))) - return(UNSAFE_BODY); - var_name = car(let_var); - if ((!is_symbol(var_name)) || - (var_name == let_name) || /* let var shadows caller */ - (var_name == func)) - return(UNSAFE_BODY); - add_symbol_to_list(sc, var_name); - - if (is_pair(cadr(let_var))) - { - result = min_body(result, form_is_safe(sc, let_name, cadr(let_var), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - follow = (!follow); - if (follow) - { - if (!sp) - sp = vars; - else - { - sp = cdr(sp); - if (vars == sp) return(UNSAFE_BODY); - }}} - return(min_body(result, body_is_safe(sc, let_name, body, (let_name != func) || at_end))); - } - - case OP_DO: /* (do (...) (...) ...) */ - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - bool follow = false; - s7_pointer vars = cadr(x); - s7_pointer sp = vars; - for (; is_pair(vars); vars = cdr(vars)) - { - s7_pointer do_var = car(vars); - if ((!is_pair(do_var)) || - (!is_pair(cdr(do_var))) || /* (do ((a . 1) (b . 2)) ...) */ - (car(do_var) == func) || - (!is_symbol(car(do_var)))) - return(UNSAFE_BODY); - - add_symbol_to_list(sc, car(do_var)); - - if (is_pair(cadr(do_var))) - result = min_body(result, form_is_safe(sc, func, cadr(do_var), false)); - if ((is_pair(cddr(do_var))) && (is_pair(caddr(do_var)))) - result = min_body(result, form_is_safe(sc, func, caddr(do_var), false)); - if (result == UNSAFE_BODY) - return(UNSAFE_BODY); - if (sp != vars) - { - if (follow) {sp = cdr(sp); if (vars == sp) return(UNSAFE_BODY);} - follow = (!follow); - }}} - if (is_pair(caddr(x))) - result = min_body(result, body_is_safe(sc, func, caddr(x), at_end)); - return(min_body(result, body_is_safe(sc, func, cdddr(x), false))); - - /* define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current let, - * but in a safe func, that's a constant. See s7test L 1865 for an example. - */ - default: - /* OP_LAMBDA is major case here */ - /* try to catch weird cases like: - * (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) - * (let () (define (hi1 a) (define (ho1 b) b) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) - */ - return(UNSAFE_BODY); - }} - else /* car(x) is not syntactic */ - { - if (expr == func) /* try to catch tail call, expr is car(x) */ - { - bool follow = false; - s7_pointer sp = x, p; - sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ - set_rec_tc_args(sc, proper_list_length(cdr(x))); - if (!at_end) {result = RECUR_BODY; sc->not_tc = true;} - for (p = cdr(x); is_pair(p); p = cdr(p)) - { - if (is_pair(car(p))) - { - if (caar(p) == func) /* func called as arg, so not tail call */ - { - sc->not_tc = true; - result = RECUR_BODY; - } - result = min_body(result, form_is_safe(sc, func, car(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - else - if (car(p) == func) /* func itself as arg */ - return(UNSAFE_BODY); - - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - if ((at_end) && (!sc->not_tc) && (is_null(p))) /* tail call, so safe */ - { - sc->got_tc = true; - set_rec_tc_args(sc, proper_list_length(cdr(x))); - return(result); - } - if (result != UNSAFE_BODY) result = RECUR_BODY; - return(result); - } - - if (is_symbol(expr)) /* expr=car(x) */ - { - s7_pointer f, f_slot; - bool c_safe; - - if (symbol_is_in_list(sc, expr)) return(UNSAFE_BODY); - f_slot = lookup_slot_from(expr, sc->curlet); - if (!is_slot(f_slot)) - return(UNSAFE_BODY); - f = slot_value(f_slot); - if (is_c_function(f)) - { - if ((expr == sc->apply_symbol) && (is_pair(cdr(x))) && (is_symbol(cadr(x)))) /* (apply ...) */ - { - s7_pointer cadr_f = lookup_unexamined(sc, cadr(x)); /* "unexamined" to skip unbound_variable */ - c_safe = ((cadr_f) && /* (cadr_f != sc->undefined) && */ - ((is_safe_c_function(cadr_f)) || - ((is_closure(cadr_f)) && (is_very_safe_closure(cadr_f))))); - } - else c_safe = (is_safe_or_scope_safe_procedure(f)); - } - else c_safe = false; - - result = ((is_sequence(f)) || - ((is_closure(f)) && (is_very_safe_closure(f))) || - ((c_safe) && ((is_immutable(f_slot)) || (is_global(expr))))) ? VERY_SAFE_BODY : SAFE_BODY; - - if ((c_safe) || - ((is_any_closure(f)) && (is_safe_closure(f))) || - (is_sequence(f))) - { - bool follow = false; - s7_pointer sp = x, p = cdr(x); - - for (; is_pair(p); p = cdr(p)) - { - if (is_unquoted_pair(car(p))) - { - if (caar(p) == func) - { - sc->got_rec = true; /* (+ 1 (recur (- x 1))) t123 (and others) */ - set_rec_tc_args(sc, proper_list_length(cdar(p))); - return(RECUR_BODY); - } - if ((is_c_function(f)) && (is_scope_safe(f)) && - (caar(p) == sc->lambda_symbol)) - { - s7_pointer largs, lbody, q; - body_t lresult; - - if (!is_pair(cdar(p))) /* (lambda . /) */ - return(UNSAFE_BODY); - largs = cadar(p); - lbody = cddar(p); - for (q = largs; is_pair(q); q = cdr(q)) - { - if (!is_symbol(car(q))) - return(UNSAFE_BODY); - add_symbol_to_list(sc, car(q)); - } - lresult = body_is_safe(sc, func, lbody, false); - result = min_body(result, lresult); - } - else result = min_body(result, form_is_safe(sc, func, car(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - else - if (car(p) == func) /* the current function passed as an argument to something */ - return(UNSAFE_BODY); - - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return((is_null(p)) ? result : UNSAFE_BODY); - } - if ((expr == sc->quote_symbol) && - (is_proper_list_1(sc, cdr(x))) && - (is_global(sc->quote_symbol))) - return(result); - - if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x is: (values (define...)) */ - { - if (is_null(cdr(x))) return(result); - if ((is_pair(cdr(x))) && (is_null(cddr(x)))) - return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); - }} - return(UNSAFE_BODY); /* not recur_body here if at_end -- possible defines in body etc */ - } - return(result); -} - -static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end) -{ - bool follow = false; - s7_pointer p = body; - body_t result = VERY_SAFE_BODY; - for (s7_pointer sp = body; is_pair(p); p = cdr(p)) - { - if (is_pair(car(p))) - { - result = min_body(result, form_is_safe(sc, func, car(p), (at_end) && (is_null(cdr(p))))); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (p != body) - { - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - }} - return((is_null(p)) ? result : UNSAFE_BODY); -} - -static bool tree_has_definers_or_binders(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - if (tree_has_definers_or_binders(sc, car(p))) - return(true); - return((is_symbol(tree)) && - (is_definer_or_binder(tree))); -} - -static bool check_recur_if(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer test = cadr(body); - if (is_fxable(sc, test)) /* if_(A)... */ - { - s7_pointer obody = cddr(body), orig = NULL; - s7_pointer true_p = car(obody); /* if_a_(A)... */ - s7_pointer false_p = cadr(obody); /* if_a_a_(if...) */ - - if ((vars <= 2) && - (is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p))) - { - if (car(false_p) == sc->if_symbol) - { - s7_pointer test2 = cadr(false_p); - s7_pointer true2 = caddr(false_p); - s7_pointer false2 = cadddr(false_p); - if ((is_fxable(sc, test2)) && - (is_proper_list_3(sc, false2)) && /* opa_laaq or oplaa_laaq */ - (is_h_optimized(false2))) /* the c-op */ - { - s7_pointer la1 = cadr(false2); - s7_pointer la2 = caddr(false2); - if ((is_fxable(sc, true2)) && - (((vars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || - (((vars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))))) && - (car(la1) == name) && (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && - ((vars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2)))))) - { - set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_args(sc, cdr(false_p), args); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); - set_opt1_pair(body, cdr(false_p)); - set_opt3_pair(body, false2); - set_opt3_pair(false2, cdr(la2)); - return(true); - } - if ((vars == 2) && (is_proper_list_3(sc, true2)) && - (car(true2) == name) && - (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && - (is_fxable(sc, cadr(false2))) && - (is_proper_list_3(sc, la2)) && - (car(la2) == name) && /* actually, not needed because func is TC (not RECUR) if not == name */ - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq); - fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ - fx_annotate_arg(sc, obody, args); /* if_a_(A)... */ - fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_if_(A)... */ - fx_annotate_args(sc, cdr(true2), args); /* if_a_a_if_a_l(AA)... */ - fx_annotate_arg(sc, cdr(false2), args); /* if_a_a_if_a_laa_op(A).. */ - fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_laa_opa_l(AA)q */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, false2); - set_opt3_pair(false2, la2); - return(true); - }}} - - if (car(false_p) == sc->and_symbol) - { - s7_pointer a1 = cadr(false_p); - s7_pointer a2 = caddr(false_p); - s7_pointer a3 = cadddr(false_p); - if ((is_fxable(sc, a1)) && - (is_proper_list_3(sc, a2)) && (is_proper_list_3(sc, a3)) && - (car(a2) == name) && (car(a3) == name) && - (is_fxable(sc, cadr(a2))) && (is_fxable(sc, cadr(a3))) && - (is_fxable(sc, caddr(a2))) && (is_fxable(sc, caddr(a3)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_AND_A_LAA_LAA); - fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ - fx_annotate_arg(sc, cddr(body), args); /* if_a_(A)... */ - fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_and_(A)... */ - fx_annotate_args(sc, cdr(a2), args); /* if_a_a_and_a_l(AA)... */ - fx_annotate_args(sc, cdr(a3), args); /* if_a_a_and_a_laa_l(AA) */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, false_p); - return(true); - }}} - - if ((is_fxable(sc, true_p)) && - (is_pair(false_p)) && - (is_h_optimized(false_p)) && - (is_pair(cdr(false_p))) && - (is_pair(cddr(false_p)))) - orig = false_p; - else - if ((is_fxable(sc, false_p)) && - (is_pair(true_p)) && - (is_h_optimized(true_p)) && - (is_pair(cdr(true_p))) && - (is_pair(cddr(true_p)))) - { - orig = true_p; - /* true_p = false_p; */ - false_p = orig; - obody = cdr(obody); - } - - if (orig) - { - if (is_null(cdddr(false_p))) /* 2 args to outer (c) func */ - { - if ((is_fxable(sc, cadr(false_p))) || (is_fxable(sc, caddr(false_p)))) - { - s7_pointer la = (is_fxable(sc, cadr(false_p))) ? caddr(false_p) : cadr(false_p); - if ((is_pair(la)) && - (car(la) == name) && - (is_pair(cdr(la))) && - (is_fxable(sc, cadr(la)))) - { - if ((vars == 1) && (is_null(cddr(la)))) - set_safe_optimize_op(body, (orig == cadddr(body)) ? - ((la == cadr(false_p)) ? OP_RECUR_IF_A_A_opLA_Aq : OP_RECUR_IF_A_A_opA_LAq) : - ((la == cadr(false_p)) ? OP_RECUR_IF_A_opLA_Aq_A : OP_RECUR_IF_A_opA_LAq_A)); - else - if ((vars == 2) && - (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && - (is_null(cdddr(la)))) - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LAAq : OP_RECUR_IF_A_opA_LAAq_A); - else - { - if ((vars == 3) && - (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && - (is_pair(cdddr(la))) && (is_fxable(sc, cadddr(la))) && - (is_null(cddddr(la))) && - (orig == cadddr(body))) - set_safe_optimize_op(body, OP_RECUR_IF_A_A_opA_L3Aq); - else return(false); - } - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, (la == cadr(false_p)) ? cddr(false_p) : cdr(false_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la); - return(true); - }} - else - { - s7_pointer la1 = cadr(false_p); - s7_pointer la2 = caddr(false_p); - if ((vars == 1) && - (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) && - (car(la1) == name) && (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))) - { - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opLA_LAq : OP_RECUR_IF_A_opLA_LAq_A); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, cdr(la1), args); - fx_annotate_arg(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la2); - return(true); - }}} - else /* 3 args to c func */ - { - if ((vars == 1) && - (is_pair(cdddr(false_p))) && - (is_null(cddddr(false_p)))) - { - s7_pointer la1 = cadr(false_p); - s7_pointer la2 = caddr(false_p); - s7_pointer la3 = cadddr(false_p); - if ((is_proper_list_2(sc, la2)) && (is_proper_list_2(sc, la3)) && - (car(la2) == name) && (car(la3) == name) && - (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3)))) - { - if ((is_proper_list_2(sc, la1)) && (car(la1) == name) && (is_fxable(sc, cadr(la1)))) - { - if (orig != cadddr(body)) - return(false); - set_safe_optimize_op(body, OP_RECUR_IF_A_A_opLA_LA_LAq); - fx_annotate_arg(sc, cdr(la1), args); - } - else - if (is_fxable(sc, la1)) - { - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LA_LAq : OP_RECUR_IF_A_opA_LA_LAq_A); - fx_annotate_arg(sc, cdr(false_p), args); - } - else return(false); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, cdr(la2), args); - fx_annotate_arg(sc, cdr(la3), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - }}}}} - - if ((vars == 3) && - (is_fxable(sc, test))) - { - s7_pointer true_p = caddr(body); - s7_pointer false_p = cadddr(body); - if ((is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p)) && - (car(false_p) == name)) - { - s7_pointer l3a = cdr(false_p); - s7_pointer la1 = car(l3a); - s7_pointer la2 = cadr(l3a); - s7_pointer la3 = caddr(l3a); - if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) && (is_proper_list_4(sc, la3)) && - (car(la1) == name) && (car(la2) == name) && (car(la3) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3))) && - (is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))) && (is_fxable(sc, caddr(la3))) && - (is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2))) && (is_fxable(sc, cadddr(la3)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_annotate_args(sc, cdr(la3), args); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - }}} - return(false); -} - -static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - if ((car(body) == sc->if_symbol) && - (proper_list_length(body) == 4)) - return(check_recur_if(sc, name, vars, args, body)); - - if ((car(body) == sc->and_symbol) && - (vars == 2) && - (proper_list_length(body) == 3) && - (proper_list_length(caddr(body)) == 4) && - (caaddr(body) == sc->or_symbol) && - (is_fxable(sc, cadr(body)))) - { - s7_pointer or_p = caddr(body); - s7_pointer la1 = caddr(or_p); - s7_pointer la2 = cadddr(or_p); - if ((is_fxable(sc, cadr(or_p))) && - (proper_list_length(la1) == 3) && - (proper_list_length(la2) == 3) && - (car(la1) == name) && - (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && - (is_fxable(sc, caddr(la1))) && - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(or_p), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, or_p); - return(true); - }} - - if (car(body) == sc->cond_symbol) - { - s7_pointer clause = cadr(body), clause2 = NULL; - if ((is_proper_list_1(sc, (cdr(clause)))) && - (is_fxable(sc, car(clause))) && - (is_fxable(sc, cadr(clause)))) - { - s7_pointer la_clause = caddr(body); - s7_int len = proper_list_length(body); - if (len == 4) - { - if ((is_proper_list_2(sc, la_clause)) && - (is_fxable(sc, car(la_clause)))) - { - clause2 = la_clause; - la_clause = cadddr(body); - } - else return(false); - } - if ((is_proper_list_2(sc, la_clause)) && - ((car(la_clause) == sc->else_symbol) || (car(la_clause) == sc->T)) && - (is_pair(cadr(la_clause)))) - { - la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */ - if (is_proper_list_2(sc, cdr(la_clause))) - { - if (is_h_optimized(la_clause)) - { - if ((is_fxable(sc, cadr(la_clause))) && - ((len == 3) || - ((len == 4) && (vars == 2) && - (is_proper_list_3(sc, cadr(clause2))) && - (caadr(clause2) == name)))) - { - s7_pointer la = caddr(la_clause); - if ((is_pair(la)) && - (car(la) == name) && - (is_pair(cdr(la))) && - (is_fxable(sc, cadr(la))) && - (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && - (is_pair(cddr(la))) && - (is_fxable(sc, caddr(la))) && - (is_null(cdddr(la)))))) - { - if (len == 3) - set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_COND_A_A_opA_LAq : OP_RECUR_COND_A_A_opA_LAAq); - else - { - s7_pointer laa = cadr(clause2); - if ((is_fxable(sc, cadr(laa))) && /* args to first laa */ - (is_fxable(sc, caddr(laa)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_opA_LAAq); - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdr(laa), args); - } - else return(false); - } - fx_annotate_args(sc, clause, args); - fx_annotate_arg(sc, cdr(la_clause), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, la); - return(true); - }} - else - { - if ((len == 4) && - (is_fxable(sc, cadr(clause2)))) - { - s7_pointer la1 = cadr(la_clause); - s7_pointer la2 = caddr(la_clause); - bool happy = false; - - if ((vars == 1) && - (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) && - (car(la1) == name) && (car(la2) == name) && (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLA_LAq); - fx_annotate_arg(sc, cdr(la1), args); - happy = true; - } - else - if ((vars == 2) && - /* (is_fxable(sc, cadr(clause2))) && */ - (is_proper_list_3(sc, la2)) && (car(la2) == name) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, caddr(la2)))) - { - if (is_fxable(sc, la1)) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq); - fx_annotate_arg(sc, cdr(la_clause), args); - happy = true; - } - else - if ((is_proper_list_3(sc, la1)) && - (car(la1) == name) && - (is_fxable(sc, cadr(la1))) && - (is_fxable(sc, caddr(la1)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLAA_LAAq); - fx_annotate_args(sc, cdr(la1), args); - happy = true; - }} - if (happy) - { - set_opt3_pair(la_clause, cdr(la2)); - fx_annotate_args(sc, clause, args); - fx_annotate_args(sc, clause2, args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - return(true); - }}}} - else - { - if (clause2) - { - s7_pointer laa = cadr(clause2); - if ((vars == 2) && (len == 4) && - (is_proper_list_3(sc, laa)) && (car(laa) == name) && (is_fxable(sc, cadr(laa))) && (is_fxable(sc, caddr(laa)))) - { - s7_pointer la1 = cadr(la_clause); - s7_pointer la2 = caddr(la_clause); - if ((is_fxable(sc, la1)) && - (is_proper_list_3(sc, la2)) && (car(la2) == name) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq); - fx_annotate_args(sc, clause, args); - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdr(laa), args); - fx_annotate_arg(sc, cdr(la_clause), args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, cdr(la2)); - return(true); - }}}}}}}} - return(false); -} - -static bool check_tc_when(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer test_expr = cadr(body); - if (is_fxable(sc, test_expr)) - { - s7_pointer p; - for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if ((is_proper_list_1(sc, p)) && /* i.e. p is the last form in the when body */ - (is_pair(car(p))) && - (caar(p) == name)) - { - s7_pointer laa = car(p); - if ((is_pair(cdr(laa))) && (is_fxable(sc, cadr(laa)))) - { - if (is_null(cddr(laa))) - { - if (vars != 1) return(false); - set_safe_optimize_op(body, OP_TC_WHEN_LA); - } - else - if (is_fxable(sc, caddr(laa))) - { - if (is_null(cdddr(laa))) - { - if (vars != 2) return(false); - set_safe_optimize_op(body, OP_TC_WHEN_LAA); - } - else - if ((vars == 3) && (is_fxable(sc, cadddr(laa))) && (is_null(cddddr(laa)))) - set_safe_optimize_op(body, OP_TC_WHEN_L3A); - else return(false); - } - fx_annotate_arg(sc, cdr(body), args); - for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) - fx_annotate_arg(sc, p, args); - fx_annotate_args(sc, cdr(laa), args); - fx_tree(sc, cdr(body), car(args), (is_pair(cdr(args))) ? cadr(args) : NULL, ((is_pair(cdr(args))) && (is_pair(cddr(args)))) ? caddr(args) : NULL, false); - return(true); - }}} - return(false); -} - -static bool check_tc_case(s7_scheme *sc, s7_pointer name, s7_pointer args, s7_pointer body) -{ - /* vars == 1, opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ - s7_pointer clauses; - s7_int len; - bool got_else = false, results_fxable = true; - for (clauses = cddr(body), len = 0; is_pair(clauses); clauses = cdr(clauses), len++) - { - s7_pointer clause = car(clauses), result; - if (is_proper_list_1(sc, car(clause))) - { - if (!is_simple(caar(clause))) - return(false); /* even if key is a small int, selector might be a mutable alias of that, so = will fail */ - set_opt1_any(clauses, caar(clause)); - } - else - { - if ((car(clause) != sc->else_symbol) || - (!is_null(cdr(clauses)))) - return(false); - got_else = true; - } - set_opt2_any(clauses, NULL); - result = cdr(clause); - if (is_null(result)) - return(false); - if (is_proper_list_1(sc, result)) - { - if (is_fxable(sc, car(result))) - { - fx_annotate_arg(sc, result, args); - set_opt2_any(clauses, result); - } - else - if ((is_proper_list_2(sc, car(result))) && - (caar(result) == name) && - (is_fxable(sc, cadar(result)))) - { - set_has_tc(car(result)); - set_opt2_any(clauses, car(result)); - fx_annotate_arg(sc, cdar(result), args); - } - else results_fxable = false; - } - else results_fxable = false; - if (!opt2_any(clauses)) - { - if (car(result) == sc->feed_to_symbol) - return(false); - if (tree_count(sc, name, result, 0) != 0) - return(false); - set_opt2_any(clauses, result); - }} - if ((!got_else) || (!is_null(clauses))) - return(false); - set_optimize_op(body, OP_TC_CASE_LA); - set_opt3_arglen(cdr(body), (len < 6) ? len : 0); - fx_annotate_arg(sc, cdr(body), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, true); - if (results_fxable) set_optimized(body); - return(results_fxable); -} - -static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer p = cdr(body), clause1 = car(p); - if ((is_proper_list_2(sc, clause1)) && (is_fxable(sc, car(clause1)))) /* cond_a... */ - { - p = cdr(p); - if ((is_pair(p)) && (is_null(cdr(p))) && ((caar(p) == sc->else_symbol) || (caar(p) == sc->T))) - { - s7_pointer else_clause; - if (((vars != 1) && (vars != 2)) || (tree_count(sc, name, body, 0) != 1)) return(false); - else_clause = cdar(p); - if (is_proper_list_1(sc, else_clause)) - { - s7_pointer la = car(else_clause); - fx_annotate_arg(sc, clause1, args); - if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) - { - if ((is_fxable(sc, cadr(la))) && - ((((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))))) - { - bool zs_fxable = is_fxable(sc, cadr(clause1)); - set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_Z_LA : OP_TC_COND_A_Z_LAA); - if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (zs_fxable) set_optimized(body); - set_opt1_pair(cdr(body), cdadr(body)); - set_opt3_pair(cdr(body), cdadr(caddr(body))); - return(zs_fxable); - }} - else - { - la = cadr(clause1); - if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) - { - if ((is_fxable(sc, cadr(la))) && - (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))))) - { - bool zs_fxable = is_fxable(sc, car(else_clause)); - set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_LA_Z : OP_TC_COND_A_LAA_Z); - if (zs_fxable) fx_annotate_arg(sc, else_clause, args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (zs_fxable) set_optimized(body); - set_opt1_pair(cdr(body), cdaddr(body)); - set_opt3_pair(cdr(body), cdadr(cadr(body))); - return(zs_fxable); - }}}} - return(false); - } - if (is_proper_list_2(sc, p)) - { - s7_pointer clause2 = car(p); - if ((is_proper_list_2(sc, clause2)) && - (is_fxable(sc, car(clause2)))) - { - s7_pointer else_p = cdr(p); - s7_pointer else_clause = car(else_p); - - if ((is_proper_list_2(sc, else_clause)) && - ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T))) - { - bool zs_fxable = true; - if ((vars == 2) && /* ...laa_laa case */ - (is_proper_list_3(sc, cadr(clause2))) && (caadr(clause2) == name) && - (is_fxable(sc, cadadr(clause2))) && (is_safe_fxable(sc, caddadr(clause2))) && - (is_proper_list_3(sc, cadr(else_clause))) && (caadr(else_clause) == name) && - (is_fxable(sc, cadadr(else_clause))) && (is_safe_fxable(sc, caddadr(else_clause)))) - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdadr(clause2), args); - fx_annotate_args(sc, cdadr(else_clause), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, cadr(else_clause)); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - } - - if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ - - (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && - (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(else_clause))) && - (((vars == 1) && (is_null(cddadr(else_clause)))) || - ((vars == 2) && (is_proper_list_3(sc, cadr(else_clause))) && (is_fxable(sc, caddadr(else_clause)))))) || - - ((is_pair(cadr(clause2))) && (caadr(clause2) == name) && - (is_pair(cdadr(clause2))) && (is_fxable(sc, cadadr(clause2))) && - (((vars == 1) && (is_null(cddadr(clause2)))) || - ((vars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) - { - s7_pointer test2 = clause2; - s7_pointer la_test = else_clause; - if (vars == 1) - { - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); - else - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LA_Z); - test2 = else_clause; - la_test = clause2; - fx_annotate_arg(sc, clause2, args); - }} - else - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - { - set_opt3_pair(body, cdadr(else_clause)); - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); - } - else - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); - test2 = else_clause; - la_test = clause2; - set_opt3_pair(body, cdadr(la_test)); - fx_annotate_arg(sc, clause2, args); - } - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - if (is_fxable(sc, cadr(test2))) - fx_annotate_args(sc, test2, args); - else - { - fx_annotate_arg(sc, test2, args); - zs_fxable = false; - } - fx_annotate_args(sc, cdadr(la_test), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}}} - return(false); -} - -static bool check_tc_let(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ - if (((vars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) || - ((vars == 1) && (car(let_body) == sc->if_symbol))) - { - s7_pointer test_expr = cadr(let_body); - if (is_fxable(sc, test_expr)) - { - if ((car(let_body) == sc->if_symbol) && (is_pair(cdddr(let_body)))) - { - s7_pointer laa = cadddr(let_body); - if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */ - (car(laa) == name) && - (((vars == 1) && (is_proper_list_2(sc, laa))) || - ((vars == 2) && (is_proper_list_3(sc, laa)) && (is_safe_fxable(sc, caddr(laa))))) && - (is_fxable(sc, cadr(laa)))) - { - bool z_fxable; - set_optimize_op(body, (vars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_LAA); - fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ - fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); /* these are references to laa args, applied to the let var binding */ - fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ - fx_annotate_args(sc, cdr(laa), args); - z_fxable = is_fxable(sc, caddr(let_body)); - if (z_fxable) fx_annotate_arg(sc, cddr(let_body), args); - fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); - fx_tree_outer(sc, cdr(let_body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (z_fxable) set_optimized(body); - return(z_fxable); - }} - else - { - s7_pointer p; - for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if ((is_proper_list_1(sc, p)) && - (is_proper_list_3(sc, car(p))) && - (caar(p) == name)) - { - s7_pointer laa = car(p); - if ((is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) - { - set_optimize_op(body, (car(let_body) == sc->when_symbol) ? OP_TC_LET_WHEN_LAA : OP_TC_LET_UNLESS_LAA); - fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ - fx_annotate_arg(sc, cdr(let_body), args); /* test */ - for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) - fx_annotate_arg(sc, p, args); - fx_annotate_args(sc, cdr(laa), args); - fx_tree(sc, cdaadr(body), car(args), cadr(args), NULL, false); /* these are references to the outer let */ - fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); - fx_tree_outer(sc, cdr(let_body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - }}}}} - else - { - if (car(let_body) == sc->cond_symbol) /* vars=#loop pars, args=names thereof (arglist) */ - { - s7_pointer var_name; - bool all_fxable = true; - for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) - { - s7_pointer clause = car(p); - if ((is_proper_list_2(sc, clause)) && - (is_fxable(sc, car(clause)))) /* test is ok */ - { - s7_pointer result; - - if ((!is_pair(cdr(p))) && - (car(clause) != sc->else_symbol) && (car(clause) != sc->T)) - return(false); - - result = cadr(clause); - if ((is_pair(result)) && - (car(result) == name)) /* result is recursive call */ - { - s7_int i = 0; - for (s7_pointer arg = cdr(result); is_pair(arg); i++, arg = cdr(arg)) - if (!is_fxable(sc, car(arg))) - return(false); - if (i != vars) - return(false); - }} - else return(false); - } - /* cond form looks ok */ - set_optimize_op(body, OP_TC_LET_COND); - set_opt3_arglen(cdr(body), vars); - fx_annotate_arg(sc, cdaadr(body), args); /* let var */ - if (vars > 0) - fx_tree(sc, cdaadr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); - var_name = caaadr(body); - for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) - { - s7_pointer clause = car(p); - s7_pointer result = cadr(clause); - fx_annotate_arg(sc, clause, args); - if ((is_pair(result)) && (car(result) == name)) - { - set_has_tc(cdr(clause)); - fx_annotate_args(sc, cdr(result), args); - } - else - if (is_fxable(sc, result)) - fx_annotate_arg(sc, cdr(clause), args); - else all_fxable = false; - fx_tree(sc, clause, var_name, NULL, NULL, false); /* just 1 let var */ - if (vars > 0) - fx_tree_outer(sc, clause, car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); - } - if (all_fxable) set_optimized(body); - return(all_fxable); - }} - return(false); -} - -/* tc lets can be let* or let+vars that don't refer to previous names, and there are more cond/if choices */ - -static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - if (!is_pair(body)) return(false); - - if (((vars == 1) || (vars == 2) || (vars == 3)) && - ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && - (is_pair(cdr(body))) && - (is_fxable(sc, cadr(body))) && - (is_pair(cddr(body)))) - { - s7_pointer orx = caddr(body); - if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) && - (car(body) != car(orx)) && - (is_fxable(sc, cadr(orx)))) - { - s7_int len = proper_list_length(orx); - if ((len == 3) || - ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) /* the ...or|and_a_a_la case below? */ - { - s7_pointer tc = (len == 3) ? caddr(orx) : cadddr(orx); - if ((is_pair(tc)) && - (car(tc) == name) && - (is_pair(cdr(tc))) && - (is_fxable(sc, cadr(tc))) && - (((vars == 1) && (is_null(cddr(tc)))) || - ((vars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_safe_fxable(sc, caddr(tc)))) || - ((vars == 3) && (is_pair(cddr(tc))) && (is_pair(cdddr(tc))) && (is_null(cddddr(tc))) && - (is_safe_fxable(sc, caddr(tc))) && (is_safe_fxable(sc, cadddr(tc)))))) - { - if (vars == 1) - set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? - ((len == 3) ? OP_TC_AND_A_OR_A_LA : OP_TC_AND_A_OR_A_A_LA) : - ((len == 3) ? OP_TC_OR_A_AND_A_LA : OP_TC_OR_A_AND_A_A_LA)); - else - if (vars == 2) - set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA); - else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L3A : OP_TC_OR_A_AND_A_L3A); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(orx), args); - if (len == 4) fx_annotate_arg(sc, cddr(orx), args); - fx_annotate_args(sc, cdr(tc), args); - /* if ((fx_proc(cdr(tc)) == fx_c_sca) && (fn_proc(cadr(tc)) == g_substring)) -> g_substring_uncopied); */ - /* for that to be safe we need to be sure nothing in the body looks for null-termination (e.g.. string->number) */ - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), (vars == 3) ? caddr(args) : NULL, false); - return(true); - }}} - else - { - if ((vars == 1) && - (car(body) == sc->or_symbol) && - (is_fxable(sc, orx)) && - (is_pair(cdddr(body))) && - (is_pair(cadddr(body)))) - { - s7_pointer and_p = cadddr(body); - if ((is_proper_list_4(sc, and_p)) && - (car(and_p) == sc->and_symbol) && - (is_fxable(sc, cadr(and_p))) && - (is_fxable(sc, caddr(and_p)))) - { - s7_pointer la = cadddr(and_p); - if ((is_proper_list_2(sc, la)) && - (car(la) == name) && - (is_fxable(sc, cadr(la)))) - { - set_safe_optimize_op(body, OP_TC_OR_A_A_AND_A_A_LA); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cddr(body), args); - fx_annotate_arg(sc, cdr(and_p), args); - fx_annotate_arg(sc, cddr(and_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - return(true); - }}} - else - { - if ((vars == 1) && (car(body) == sc->and_symbol) && (car(orx) == sc->if_symbol) && - (is_proper_list_4(sc, orx)) && (is_fxable(sc, cadr(orx))) && (tree_count(sc, name, orx, 0) == 1)) - { - bool z_first = ((is_pair(cadddr(orx))) && (car(cadddr(orx)) == name)); - s7_pointer la = (z_first) ? cadddr(orx) : caddr(orx); - if ((car(la) == name) && (is_proper_list_2(sc, la)) && (is_fxable(sc, cadr(la)))) - { - bool z_fxable = true; - s7_pointer z = (z_first) ? cddr(orx) : cdddr(orx); - set_optimize_op(body, (z_first) ? OP_TC_AND_A_IF_A_Z_LA : OP_TC_AND_A_IF_A_LA_Z); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(orx), args); - fx_annotate_arg(sc, cdr(la), args); - if (is_fxable(sc, car(z))) fx_annotate_arg(sc, z, args); else z_fxable = false; - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - if (z_fxable) set_optimized(body); - return(z_fxable); - }}}}} - - if ((vars == 3) && - (((car(body) == sc->or_symbol) && (is_proper_list_2(sc, cdr(body)))) || - ((car(body) == sc->if_symbol) && (is_proper_list_3(sc, cdr(body))) && (caddr(body) == sc->T))) && - (is_fxable(sc, cadr(body)))) - { - s7_pointer and_p = (car(body) == sc->or_symbol) ? caddr(body) : cadddr(body); - if ((is_proper_list_4(sc, and_p)) && - (car(and_p) == sc->and_symbol) && - (is_fxable(sc, cadr(and_p))) && - (is_fxable(sc, caddr(and_p)))) - { - s7_pointer la = cadddr(and_p); - if ((is_proper_list_4(sc, la)) && - (car(la) == name) && - (is_fxable(sc, cadr(la))) && - (is_safe_fxable(sc, caddr(la))) && - (is_safe_fxable(sc, cadddr(la)))) - { - set_safe_optimize_op(body, OP_TC_OR_A_AND_A_A_L3A); - set_opt3_pair(cdr(body), (car(body) == sc->or_symbol) ? cdaddr(body) : cdr(cadddr(body))); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(and_p), args); - fx_annotate_arg(sc, cddr(and_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - return(true); - }}} - - if (((vars >= 1) && (vars <= 3)) && - (car(body) == sc->if_symbol) && - (proper_list_length(body) == 4)) - { - s7_pointer test = cadr(body); - if (is_fxable(sc, test)) - { - s7_pointer true_p = caddr(body); - s7_pointer false_p = cadddr(body); - s7_int true_len = proper_list_length(true_p); - s7_int false_len = proper_list_length(false_p); - - fx_annotate_arg(sc, cdr(body), args); - - if (vars == 1) - { - if ((false_len == 2) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_LA); - fx_annotate_arg(sc, cdr(false_p), args); /* arg */ - set_opt1_pair(cdr(body), cddr(body)); - set_opt3_pair(cdr(body), cdar(cdddr(body))); - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); /* result */ - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_optimized(body); /* split here and elsewhere from set_optimize_op is deliberate */ - return(true); - } - if ((true_len == 2) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_LA_Z); - fx_annotate_arg(sc, cdr(true_p), args); /* arg */ - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); /* result */ - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_optimized(body); - return(true); - }} - - if (vars == 2) - { - if ((false_len == 3) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p))) && - (is_safe_fxable(sc, caddr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_LAA); - fx_annotate_args(sc, cdr(false_p), args); - set_opt1_pair(cdr(body), cddr(body)); /* body == code in op, if_z */ - set_opt3_pair(cdr(body), cdar(cdddr(body))); /* la */ - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - } - if ((true_len == 3) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p))) && - (is_safe_fxable(sc, caddr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_LAA_Z); - fx_annotate_args(sc, cdr(true_p), args); - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - }} - - if (vars == 3) - { - if ((false_len == 4) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p))) && (is_safe_fxable(sc, caddr(false_p))) && (is_safe_fxable(sc, cadddr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_L3A); - fx_annotate_args(sc, cdr(false_p), args); - set_opt1_pair(cdr(body), cddr(body)); - set_opt3_pair(cdr(body), cdar(cdddr(body))); - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_optimized(body); - return(true); - } - if ((true_len == 4) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p))) && (is_safe_fxable(sc, caddr(true_p))) && (is_safe_fxable(sc, cadddr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_L3A_Z); - fx_annotate_args(sc, cdr(true_p), args); - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_optimized(body); - return(true); - }} - - if ((false_len == 4) && - (car(false_p) == sc->if_symbol)) - { - s7_pointer in_test = cadr(false_p); - s7_pointer in_true = caddr(false_p); - s7_pointer in_false = cadddr(false_p); - if (is_fxable(sc, in_test)) - { - s7_pointer la = NULL, z; - if ((is_pair(in_false)) && - (car(in_false) == name) && - (is_pair(cdr(in_false))) && - (is_fxable(sc, cadr(in_false)))) - { - la = in_false; - z = cddr(false_p); - } - else - if ((is_pair(in_true)) && - (car(in_true) == name) && - (is_pair(cdr(in_true))) && - (is_fxable(sc, cadr(in_true)))) - { - la = in_true; - z = cdddr(false_p); - } - if ((la) && ((vars == 3) || (!s7_tree_memq(sc, name, car(z))))) - { - if (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_safe_fxable(sc, caddr(la)))) || - ((vars == 3) && (is_proper_list_4(sc, in_true)) && (car(in_true) == name) && - (is_proper_list_4(sc, in_false)) && (is_safe_fxable(sc, caddr(la))) && (is_safe_fxable(sc, cadddr(la))) && - (is_fxable(sc, cadr(in_true))) && (is_safe_fxable(sc, caddr(in_true))) && (is_safe_fxable(sc, cadddr(in_true))))) - { - bool zs_fxable = true; - if (vars == 1) - set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LA : OP_TC_IF_A_Z_IF_A_LA_Z); - else - if (vars == 2) - set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LAA : OP_TC_IF_A_Z_IF_A_LAA_Z); - else set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L3A_L3A); - if (is_fxable(sc, true_p)) /* outer (z) result */ - fx_annotate_arg(sc, cddr(body), args); - else zs_fxable = false; - fx_annotate_arg(sc, cdr(false_p), args); /* inner test */ - fx_annotate_args(sc, cdr(la), args); /* la arg(s) */ - if (vars == 3) - fx_annotate_args(sc, cdr(in_true), args); - else - if (is_fxable(sc, car(z))) - fx_annotate_arg(sc, z, args); /* inner (z) result */ - else zs_fxable = false; - if ((has_fx(cddr(body))) && (has_fx(z))) - fx_tree(sc, cdr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}} - - if ((vars == 2) && - (false_len == 3) && - (car(false_p) == sc->let_star_symbol)) - { - s7_pointer letv = cadr(false_p), letb, v; - - if (!is_pair(letv)) return(false); - letb = caddr(false_p); - for (v = letv; is_pair(v); v = cdr(v)) - if (!is_fxable(sc, cadar(v))) - return(false); - if ((is_proper_list_4(sc, letb)) && - (car(letb) == sc->if_symbol) && - (is_fxable(sc, cadr(letb)))) - { - s7_pointer laa = cadddr(letb); - if ((car(laa) == name) && - (is_proper_list_3(sc, laa)) && - (is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) - { - bool zs_fxable; - set_safe_optimize_op(body, OP_TC_IF_A_Z_LET_IF_A_Z_LAA); - fx_annotate_args(sc, cdr(laa), args); - zs_fxable = is_fxable(sc, caddr(letb)); - fx_annotate_args(sc, cdr(letb), args); - for (v = letv; is_pair(v); v = cdr(v)) - fx_annotate_arg(sc, cdar(v), args); - fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */ - fx_tree(sc, cdr(laa), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); - fx_tree(sc, cdr(letb), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); - fx_tree_outer(sc, cddr(letb), car(args), cadr(args), NULL, true); - if (!is_fxable(sc, caddr(body))) - return(false); - fx_annotate_arg(sc, cddr(body), args); - return(zs_fxable); - }}}}} - - /* let */ - if ((is_proper_list_3(sc, body)) && - (car(body) == sc->let_symbol) && - (is_proper_list_1(sc, cadr(body))) && - (is_fxable(sc, cadr(caadr(body)))) && /* let one var is fxable */ - (is_pair(caddr(body)))) - return(check_tc_let(sc, name, vars, args, body)); - - /* cond */ - if ((car(body) == sc->cond_symbol) && - (vars <= 2)) - return(check_tc_cond(sc, name, vars, args, body)); - - /* case */ - if ((vars == 1) && - (car(body) == sc->case_symbol) && - (is_pair(cdr(body))) && - (is_fxable(sc, cadr(body)))) - return(check_tc_case(sc, name, args, body)); - - /* when */ - if ((vars >= 1) && (vars <= 3) && - (car(body) == sc->when_symbol) && - (is_fxable(sc, cadr(body)))) - return(check_tc_when(sc, name, vars, args, body)); - return(false); -} - -static void mark_fx_treeable(s7_scheme *sc, s7_pointer body) -{ /* it is possible to encounter a cyclic body here -- should we protect against that if safety>0? */ - if (is_pair(body)) /* slightly faster than the other way of writing this */ - { - if (is_pair(car(body))) - { - set_is_fx_treeable(body); - mark_fx_treeable(sc, car(body)); - } - mark_fx_treeable(sc, cdr(body)); - } -} - -static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body) -{ /* func is either sc->unused or a symbol */ - s7_int len = s7_list_length(sc, body); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(body)); - if (len < 0) /* (define (hi) 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: function body messed up, ~A", 31), - (unstarred_lambda) ? sc->lambda_symbol : sc->lambda_star_symbol, - sc->code)); - if (len > 0) /* i.e. not circular */ - { - body_t result; - s7_pointer p, lst, cleared_args; - - clear_symbol_list(sc); - for (p = args; is_pair(p); p = cdr(p)) - add_symbol_to_list(sc, (is_symbol(car(p))) ? car(p) : caar(p)); - if (!is_null(p)) - add_symbol_to_list(sc, p); - sc->got_tc = false; - sc->not_tc = false; - sc->got_rec = false; - sc->rec_tc_args = -1; - result = ((is_symbol(func)) && (symbol_is_in_list(sc, func))) ? UNSAFE_BODY : body_is_safe(sc, func, body, true); /* (define (f f)...) */ - clear_symbol_list(sc); - - /* if the body is safe, we can optimize the calling sequence */ - if (!unstarred_lambda) - { - bool happy = true; - /* check default vals -- if none is an expression or symbol, set simple args */ - for (p = args; is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_pair(arg)) && /* has default value */ - (is_pair(cdr(arg))) && /* is not a ridiculous improper list */ - ((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */ - (is_unquoted_pair(cadr(arg))))) /* pair as default only ok if it is (quote ...) */ - { - happy = false; - if ((result > UNSAFE_BODY) && - (tree_has_definers_or_binders(sc, cadr(arg)))) /* if the default has a definer, body is not safe (funclet is not stable) */ - result = UNSAFE_BODY; - break; - }} - if (happy) - lambda_set_simple_defaults(body); - } - if (result >= SAFE_BODY) /* not RECUR_BODY here (need new let for cons-r in s7test) */ - { - set_safe_closure_body(body); - if (result == VERY_SAFE_BODY) - set_very_safe_closure_body(body); - } - if (is_symbol(func)) - { - lst = list_1(sc, add_symbol_to_list(sc, func)); - sc->temp1 = lst; - } - else lst = sc->nil; - - if (optimize(sc, body, 1, cleared_args = collect_parameters(sc, args, lst)) == OPT_OOPS) - clear_all_optimizations(sc, body); - else - if (result >= RECUR_BODY) - { - int32_t nvars; - mark_fx_treeable(sc, body); - - for (nvars = 0, p = args; (is_pair(p)) && (!is_symbol_and_keyword(car(p))); nvars++, p = cdr(p)); - if ((is_null(p)) && - (nvars > 0)) - { - fx_annotate_args(sc, body, cleared_args); /* almost useless -- we need a recursive traversal here but that collides with check_if et al */ - fx_tree(sc, body, /* this usually costs more than it saves! */ - (is_pair(car(args))) ? caar(args) : car(args), - (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL, - (nvars > 2) ? ((is_pair(caddr(args))) ? caaddr(args) : caddr(args)) : NULL, - nvars > 3); - } - if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && - (is_null(cdr(body)))) - { /* (if #t|#f...) happens only rarely */ - if (sc->got_tc) - { - if (check_tc(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */ - /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ - } - if ((sc->got_rec) && - (!is_tc_op(optimize_op(car(body)))) && - (check_recur(sc, func, nvars, args, car(body)))) - set_safe_closure_body(body); - }} - if (is_symbol(func)) - { - sc->temp1 = sc->unused; - free_cell(sc, lst); - } - sc->got_tc = false; - sc->not_tc = false; - sc->got_rec = false; - } -} - -static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool opt) -{ - /* code is a lambda form: (lambda (a b) (+ a b)) */ - /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */ - s7_pointer code, body; - int32_t arity = 0; - - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, form))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda: body is cyclic: ~S", 26), form)); - - code = cdr(form); - if (!is_pair(code)) /* (lambda) or (lambda . 1) */ - syntax_error_nr(sc, "lambda: no arguments? ~A", 24, form); - - body = cdr(code); - if (!is_pair(body)) /* (lambda #f) */ - syntax_error_nr(sc, "lambda: no body? ~A", 19, form); - - /* in many cases, this is a no-op -- we already checked at define */ - check_lambda_args(sc, car(code), &arity, sc->code); - /* clear_symbol_list(sc); */ /* not used in check_lambda_args and clobbers optimize_expression find_uncomplicated_symbol check */ - - /* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...) - * one problem the hop=0 fixes is that safe closures assume the old let exists, so we need to check for define below - * I wonder about apply define... - */ - /* OP_LET1 should work here also, (let ((f (lambda...)))), but subsequent calls assume a saved let if safe - * to mimic define, we need to parallel op_define_with_setter + make_funclet, I think - */ - if ((opt) || - (main_stack_op(sc) == OP_DEFINE1) || - (((sc->stack_end - sc->stack_start) > 4) && - (((opcode_t)(sc->stack_end[-5])) == OP_DEFINE1) && /* surely if define is ok, so is define dilambda? 16-Apr-16 */ - (sc->op_stack_now > sc->op_stack) && - ((*(sc->op_stack_now - 1)) == (s7_pointer)global_value(sc->dilambda_symbol)))) - optimize_lambda(sc, true, sc->unused, car(code), body); - else - if (optimize(sc, body, 0, - /* ((sc->op_stack_now > sc->op_stack) && (is_c_function((*(sc->op_stack_now - 1)))) && (is_scope_safe((*(sc->op_stack_now - 1))))) ? 1 : 0, */ - /* this works except when someone resets outlet(curlet) after defining a local function! */ - collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) - clear_all_optimizations(sc, body); - pair_set_syntax_op(form, OP_LAMBDA_UNCHECKED); - if (arity < -1) arity++; /* confusing! at least 0 = (), but (lambda arg...) has same "arity" here as (lambda (a . b)...)? */ - set_opt3_any(code, (s7_pointer)((intptr_t)arity)); - return(arity); -} - -static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code) -{ - int32_t arity = check_lambda(sc, code, false); - code = cdr(code); - set_opt3_any(code, (s7_pointer)((intptr_t)arity)); - return(make_closure(sc, car(code), cdr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); -} - -static inline s7_pointer op_lambda_unchecked(s7_scheme *sc, s7_pointer code) -{ - int32_t arity = (int32_t)((intptr_t)opt3_any(cdr(code))); - return(make_closure_gc_checked(sc, cadr(code), cddr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); -} - -static void check_lambda_star(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, sc->code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda*: body is cyclic: ~S", 27), sc->code)); - - if ((!is_pair(code)) || - (!is_pair(cdr(code)))) /* (lambda*) or (lambda* #f) */ - syntax_error_nr(sc, "lambda*: no arguments or no body? ~A", 36, sc->code); - - set_car(code, check_lambda_star_args(sc, car(code), NULL, sc->code)); - if ((sc->safety > NO_SAFETY) || - (main_stack_op(sc) != OP_DEFINE1)) - { - if (optimize(sc, cdr(code), 0, collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) - clear_all_optimizations(sc, cdr(code)); - } - else optimize_lambda(sc, false, sc->unused, car(code), cdr(code)); - - pair_set_syntax_op(sc->code, OP_LAMBDA_STAR_UNCHECKED); - sc->code = code; -} - - -/* -------------------------------- case -------------------------------- */ -static inline bool is_undefined_feed_to(s7_scheme *sc, s7_pointer sym) -{ - return((sym == sc->feed_to_symbol) && - ((symbol_ctr(sc->feed_to_symbol) == 0) || (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))); -} - -static bool is_all_fxable(s7_scheme *sc, s7_pointer x) -{ - for (s7_pointer p = x; is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(false); - return(true); -} - -static s7_pointer check_case(s7_scheme *sc) -{ - /* we're not checking repeated or ridiculous (non-eqv?) keys here because they aren't errors */ - bool keys_simple = true, has_feed_to = false, keys_single = true, bodies_simple = true, has_else = false, use_fx = true; - int32_t key_type = T_FREE; - s7_pointer x, carc, code = cdr(sc->code), form = sc->code; - - if (!is_pair(code)) /* (case) or (case . 1) */ - syntax_error_nr(sc, "case has no selector: ~S", 25, form); - if (!is_pair(cdr(code))) /* (case 1) or (case 1 . 1) */ - syntax_error_nr(sc, "case has no clauses?: ~S", 25, form); - if (!is_pair(cadr(code))) /* (case 1 1) */ - syntax_error_nr(sc, "case clause is not a pair? ~S", 29, form); - set_opt3_any(code, sc->unspecified); - - for (x = cdr(code); is_pair(x); x = cdr(x)) - { - s7_pointer y, car_x; - if (!is_pair(car(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", 30), - x, object_to_truncated_string(sc, form, 80))); - car_x = car(x); - - if (!is_list(cdr(car_x))) /* (case 1 ((1))) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", 40), - car_x, object_to_truncated_string(sc, form, 80))); - if ((bodies_simple) && - ((is_null(cdr(car_x))) || (!is_null(cddr(car_x))))) - bodies_simple = false; - - use_fx = ((use_fx) && (is_pair(cdr(car_x))) && (is_all_fxable(sc, cdr(car_x)))); - y = car(car_x); - if (!is_pair(y)) - { - if ((y != sc->else_symbol) && /* (case 1 (2 1)) */ - ((!is_symbol(y)) || - (s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "case clause key-list ~S in ~S is not a proper list or 'else', in ~A", 67), - y, car_x, object_to_truncated_string(sc, form, 80))); - has_else = true; - if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */ - syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, x); - if (!is_null(cdr(car_x))) /* else (else) so return selector */ - { - if (is_pair(cddr(car_x))) - { - set_opt3_any(code, cdr(car_x)); - bodies_simple = false; - } - else - { - set_opt3_any(code, ((bodies_simple) && (keys_single)) ? cadr(car_x) : cdr(car_x)); - set_opt1_clause(x, cadr(car_x)); - }}} - else - { - if (!is_simple(car(y))) keys_simple = false; - if (!is_null(cdr(y))) keys_single = false; - if (key_type == T_FREE) - key_type = type(car(y)); - else - if (key_type != type(car(y))) - key_type = NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key(car(y)); - - for (y = cdr(y); is_pair(y); y = cdr(y)) - { - if (!is_simple(car(y))) - keys_simple = false; - if (key_type != type(car(y))) - key_type = NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key(car(y)); - } - if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case key list ~S is improper, in ~A", 35), - car_x, object_to_truncated_string(sc, form, 80))); - } - y = car_x; - if (!s7_is_proper_list(sc, cdr(y))) /* (case 2 ((1 2) 1 . 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: stray dot? ~S in ~A", 25), - y, object_to_truncated_string(sc, form, 80))); - if ((is_pair(cdr(y))) && (is_undefined_feed_to(sc, cadr(y)))) - { - has_feed_to = true; - if (!is_pair(cddr(y))) /* (case 1 (else =>)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35), - y, object_to_truncated_string(sc, form, 80))); - if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: '=>' has too many targets: ~S in ~A", 41), - y, object_to_truncated_string(sc, form, 80))); - }} - if (is_not_null(x)) /* (case x ((1 2)) . 1) */ - syntax_error_nr(sc, "case: stray dot? ~S", 19, form); - - if ((keys_single) && - (bodies_simple)) - { - for (x = cdr(code); is_not_null(x); x = cdr(x)) - { - set_opt2_any(x, caar(x)); - if (is_pair(opt2_any(x))) - { - set_opt2_any(x, car(opt2_any(x))); - if (is_pair(cdar(x))) - set_opt1_clause(x, cadar(x)); - }}} - else - for (x = cdr(code); is_not_null(x); x = cdr(x)) - { - set_opt2_any(x, caar(x)); - if ((is_pair(opt2_any(x))) && - (is_pair(cdar(x)))) - set_opt1_clause(x, cadar(x)); - } - if (key_type == T_INTEGER) - set_has_integer_keys(form); - - /* X_Y_Z: X (selector): S=symbol, A=fxable, P=any, Y: E(keys simple) G(any keys) I(integer keys) , Z: S: no =>, bodies simple, keys single G: all else, -- ?? */ - pair_set_syntax_op(form, OP_CASE_P_G_G); /* fallback on this */ - if ((has_feed_to) || - (!bodies_simple) || /* x_x_g g=general keys or bodies */ - (!keys_single)) - { - if (!keys_simple) /* x_g_g */ - { - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_CASE_A_G_G); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_G_G); - } - else /* x_e_g */ - { - if (!has_else) set_opt3_any(code, sc->unused); /* affects all that goto CASE_E_G */ - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, (key_type == T_SYMBOL) ? OP_CASE_A_S_G : OP_CASE_A_E_G); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_E_G); - }} - else /* x_x_s */ - if (!keys_simple) /* x_g|i_s */ - { - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_A_I_S : OP_CASE_A_G_S); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_P_I_S : OP_CASE_P_G_S); - } - else /* x_e_s */ - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_CASE_A_E_S); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_E_S); - - if ((use_fx) && (has_else) && (!has_feed_to)) - { - opcode_t op = optimize_op(form); - if ((op == OP_CASE_A_E_S) || (op == OP_CASE_A_G_S) || (op == OP_CASE_A_S_G) || ((!WITH_GMP) && (op == OP_CASE_A_I_S))) - { - pair_set_syntax_op(form, - (op == OP_CASE_A_I_S) ? OP_CASE_A_I_S_A : - ((op == OP_CASE_A_E_S) ? OP_CASE_A_E_S_A : - ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A : OP_CASE_A_G_S_A))); - for (x = cdr(code); is_pair(x); x = cdr(x)) - { - s7_pointer clause = cdar(x); - fx_annotate_args(sc, clause, sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, clause); - if (is_null(cdr(x))) set_opt3_any(code, clause); - }}} - carc = cadr(form); - if (!is_pair(carc)) - { - sc->value = (is_symbol(carc)) ? lookup_checked(sc, carc) : carc; - return(NULL); - } - push_stack_no_args_direct(sc, OP_CASE_G_G); - sc->code = carc; - return(carc); -} - -#if (!WITH_GMP) -static bool op_case_i_s(s7_scheme *sc) -{ - s7_pointer selector = sc->value; - s7_pointer else_clause = opt3_any(cdr(sc->code)); - if (else_clause != sc->unspecified) - { - if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) - if (integer(opt2_any(x)) == val) - { - sc->code = opt1_clause(x); - return(false); - }} - sc->code = else_clause; - return(false); - } - if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (integer(opt2_any(x)) == val) - { - sc->code = opt1_clause(x); - return(false); - }} - sc->value = sc->unspecified; - return(true); -} - -static inline s7_pointer fx_case_a_i_s_a(s7_scheme *sc, s7_pointer code) /* inline saves about 30 in tleft */ -{ - s7_pointer selector = fx_call(sc, cdr(code)); - if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) - if (integer(opt2_any(x)) == val) - return(fx_call(sc, cdar(x))); - } - return(fx_call(sc, opt3_any(cdr(code)))); -} -#endif - -static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok) -{ - s7_pointer x; - if (ok) - { - for (x = cddr(sc->code); is_pair(x); x = cdr(x)) - { - s7_pointer y = opt2_any(x); - if (!is_pair(y)) /* i.e. else? */ - goto ELSE_CASE_1; - do { - if (car(y) == selector) - goto ELSE_CASE_1; - y = cdr(y); - } while (is_pair(y)); - } - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - - sc->code = opt3_any(cdr(sc->code)); - if (sc->code == sc->unused) /* set in check_case if no else clause */ - sc->value = sc->unspecified; - else - if (is_pair(sc->code)) - goto ELSE_CASE_2; - pop_stack(sc); - return(true); - - ELSE_CASE_1: - /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */ - sc->code = T_Lst(cdar(x)); - if (is_null(sc->code)) /* sc->value is already the selector */ - { - pop_stack(sc); - return(true); - } - - ELSE_CASE_2: - if (is_null(cdr(sc->code))) - { - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); -} - -static inline s7_pointer fx_call_all(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p; - for (p = code; is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); -} - -static s7_pointer fx_case_a_s_g_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer selector = fx_call(sc, cdr(code)); - if (is_case_key(selector)) - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - { - s7_pointer y = opt2_any(x); - if (!is_pair(y)) /* i.e. else? */ - return(fx_call_all(sc, cdar(x))); /* else clause */ - do { - if (car(y) == selector) - return(fx_call_all(sc, cdar(x))); - y = cdr(y); - } while (is_pair(y)); - } - return(fx_call_all(sc, opt3_any(cdr(code)))); /* selector is not a case-key */ -} - -#define if_pair_set_up_begin(Sc) if (is_pair(cdr(Sc->code))) {check_stack_size(Sc); push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code));} Sc->code = car(Sc->code); -#define if_pair_set_up_begin_unchecked(Sc) if (is_pair(cdr(Sc->code))) push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code)); Sc->code = car(Sc->code); -/* using the one_form bit here was slower */ - -static bool op_case_g_g(s7_scheme *sc) -{ - s7_pointer x; - if (has_integer_keys(sc->code)) - { - s7_int selector; - sc->code = cddr(sc->code); - if (is_t_integer(sc->value)) - selector = integer(sc->value); - else - { -#if WITH_GMP - if ((is_t_big_integer(sc->value)) && (mpz_fits_slong_p(big_integer(sc->value)))) - selector = mpz_get_si(big_integer(sc->value)); - else -#endif - { - for (x = sc->code; is_pair(x); x = cdr(x)) - if (!is_pair(caar(x))) - goto ELSE_CASE; - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - }} - for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - for (; is_pair(y); y = cdr(y)) - if (integer(car(y)) == selector) - goto ELSE_CASE; - } - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - sc->code = cddr(sc->code); - if (is_simple(sc->value)) - { - for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - do { - if (car(y) == sc->value) - goto ELSE_CASE; - y = cdr(y); - } while (is_pair(y)); - } - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - for (; is_pair(y); y = cdr(y)) - if (s7_is_eqv(sc, car(y), sc->value)) - goto ELSE_CASE; - } - sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */ - pop_stack(sc); - return(true); - - ELSE_CASE: - /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */ - sc->code = T_Lst(cdar(x)); - if (is_null(sc->code)) /* sc->value is already the selector */ - { - pop_stack(sc); - return(true); - } - if (is_null(cdr(sc->code))) - { - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - if_pair_set_up_begin_unchecked(sc); - sc->cur_op = optimize_op(sc->code); - return(true); -} - -static void op_case_e_s(s7_scheme *sc) -{ - s7_pointer selector = sc->value; - if (is_simple(selector)) - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (opt2_any(x) == selector) - { - sc->code = opt1_clause(x); - return; - } - sc->code = opt3_any(cdr(sc->code)); -} - -static s7_pointer fx_case_a_e_s_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer selector = fx_call(sc, cdr(code)); - if (is_simple(selector)) - for (s7_pointer x = cddr(code); is_pair(x); x = cdr(x)) - if (opt2_any(x) == selector) - return(fx_call(sc, cdar(x))); - return(fx_call(sc, opt3_any(cdr(code)))); -} - -static void op_case_g_s(s7_scheme *sc) -{ - s7_pointer selector = sc->value; - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (s7_is_eqv(sc, opt2_any(x), selector)) - { - sc->code = opt1_clause(x); - return; - } - sc->code = opt3_any(cdr(sc->code)); -} - -static inline s7_pointer fx_case_a_g_s_a(s7_scheme *sc, s7_pointer code) /* split into int/any cases in g_g, via has_integer_keys(sc->code) */ -{ - s7_pointer selector = fx_call(sc, cdr(code)); - for (s7_pointer x = cddr(code); is_pair(x); x = cdr(x)) - if (s7_is_eqv(sc, opt2_any(x), selector)) - return(fx_call(sc, cdar(x))); - return(fx_call(sc, opt3_any(cdr(code)))); -} - - -/* -------------------------------- let -------------------------------- */ -static void check_let_a_body(s7_scheme *sc, s7_pointer form) -{ - s7_pointer code = cdr(form); - if (is_fxable(sc, cadr(code))) - { - fx_annotate_arg(sc, cdr(code), set_plist_1(sc, caaar(code))); /* was sc->curlet) ? */ - fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); - pair_set_syntax_op(form, OP_LET_A_A_OLD); - } - else - if (is_pair(cadr(code))) - { - pair_set_syntax_op(form, OP_LET_A_P_OLD); - if (is_fx_treeable(cdaar(code))) fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); - } -} - -static void check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer start) -{ - s7_pointer binding = car(start), code = cdr(form); - if (is_pair(cadr(binding))) - { - /* this is not a named let */ - pair_set_syntax_op(form, ((is_pair(cdr(code))) && (is_null(cddr(code)))) ? OP_LET_ONE_P_OLD : OP_LET_ONE_OLD); - set_opt2_sym(cdr(code), car(binding)); /* these don't collide -- cdr(code) and code */ - set_opt2_pair(code, cadr(binding)); - if (is_optimized(cadr(binding))) - { - if ((optimize_op(cadr(binding)) == HOP_SAFE_C_SS) && - (fn_proc(cadr(binding)) == g_assq)) - { - set_opt2_sym(code, cadadr(binding)); - pair_set_syntax_op(form, OP_LET_opaSSq_OLD); - set_opt3_sym(cdr(code), caddadr(binding)); - set_opt1_sym(code, car(binding)); - } - else - if (is_fxable(sc, cadr(binding))) - { - set_opt2_pair(code, binding); - pair_set_syntax_op(form, OP_LET_A_OLD); - fx_annotate_arg(sc, cdr(binding), sc->curlet); - if (is_null(cddr(code))) - check_let_a_body(sc, form); - else - { - s7_pointer p; - for (p = cdr(code); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if (is_null(p)) - { - pair_set_syntax_op(form, OP_LET_A_NA_OLD); - fx_annotate_args(sc, cdr(code), set_plist_1(sc, car(binding))); - fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - return; - } - if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - }}}} - else - { - set_opt2_pair(code, binding); - pair_set_syntax_op(form, OP_LET_A_OLD); - fx_annotate_arg(sc, cdr(binding), sc->curlet); - if (is_null(cddr(code))) - check_let_a_body(sc, form); - else - { - fx_annotate_args(sc, cdr(code), set_plist_1(sc, caaar(code))); /* no effect if not syntactic -- how to fix? */ - if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - }} - if ((optimize_op(form) == OP_LET_A_OLD) && - (is_pair(cddr(code))) && (is_null(cdddr(code)))) - pair_set_syntax_op(form, OP_LET_A_OLD_2); -} - -static s7_pointer check_named_let(s7_scheme *sc, int32_t vars) -{ - s7_pointer code = cdr(sc->code); - set_opt2_int(code, vars); - if (vars == 0) - { - pair_set_syntax_op(sc->code, OP_NAMED_LET_NO_VARS); - set_opt1_pair(sc->code, cddr(code)); - optimize_lambda(sc, true, car(code), sc->nil, cddr(code)); - } - else - { - bool fx_ok = true; - pair_set_syntax_op(sc->code, OP_NAMED_LET); - /* this is (let name ...) so the initial values need to be removed from the closure arg list */ - - sc->args = T_Pair(safe_list_if_possible(sc, vars)); - for (s7_pointer ex = cadr(code), exp = sc->args; is_pair(ex); ex = cdr(ex), exp = cdr(exp)) - { - s7_pointer val = cdar(ex); - s7_function fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe); - if (fx) set_fx_direct(val, fx); else fx_ok = false; - car(exp) = caar(ex); - } - if (fx_ok) - { - set_opt1_pair(code, caadr(code)); - if (vars == 2) set_opt3_pair(code, cadadr(code)); - pair_set_syntax_op(sc->code, (vars == 1) ? OP_NAMED_LET_A : ((vars == 2) ? OP_NAMED_LET_AA : OP_NAMED_LET_NA)); - } - optimize_lambda(sc, true, car(code), sc->args, cddr(code)); /* car(code) is the name */ - clear_list_in_use(sc->args); - sc->args = sc->nil; - } - return(code); -} - -static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ -{ - s7_pointer x, start, code = cdr(sc->code), form = sc->code; - bool named_let; - int32_t vars; - - if (!is_pair(code)) /* (let . 1) */ - { - if (is_null(code)) /* (let) */ - syntax_error_nr(sc, "let has no variables or body: ~A", 32, form); - syntax_error_nr(sc, "let form is an improper list? ~A", 32, form); - } - - if (!is_pair(cdr(code))) /* (let () ) or (let () . 1) */ - syntax_error_nr(sc, "let has no body: ~A", 19, form); - - if ((!is_list(car(code))) && /* (let 1 ...) */ - (!is_normal_symbol(car(code)))) - syntax_error_nr(sc, "let variable list is messed up or missing: ~A", 45, form); - - named_let = (is_symbol(car(code))); - if (named_let) - { - if (!is_list(cadr(code))) /* (let hi #t) */ - syntax_error_nr(sc, "let variable list is messed up: ~A", 34, form); - if (!is_pair(cddr(code))) /* (let hi () . =>) or (let hi () ) */ - { - if (is_null(cddr(code))) - syntax_error_nr(sc, "named let has no body: ~A", 25 , form); - syntax_error_nr(sc, "named let stray dot? ~A", 23, form); - } - if (is_constant_symbol(sc, car(code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, form)); - set_local(car(code)); - start = cadr(code); - } - else start = car(code); - - clear_symbol_list(sc); - for (vars = 0, x = start; is_pair(x); vars++, x = cdr(x)) - { - s7_pointer y, carx = car(x); - - if ((!is_pair(carx)) || (is_null(cdr(carx)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, but no value?: ~A in ~A", 49), - x, object_to_truncated_string(sc, form, 80))); - - if (!(is_pair(cdr(carx)))) /* (let ((x . 1))...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, is not a proper list in ~A", 56), - x, object_to_truncated_string(sc, form, 80))); - - if (is_not_null(cddr(carx))) /* (let ((x 1 2 3)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, has more than one value in ~A", 59), - x, object_to_truncated_string(sc, form, 80))); - y = car(carx); - if (!(is_symbol(y))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "bad variable ~S in let (it is not a symbol) in ~A", 49), - carx, object_to_truncated_string(sc, form, 80))); - - if (is_constant_symbol(sc, y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, x)); - - /* check for name collisions -- not sure this is required by Scheme */ - if (symbol_is_in_list(sc, y)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: ~S in ~S", 37), y, form)); - add_symbol_to_list(sc, y); - set_local(y); - } - /* (let ('1) quote) -> 1 */ - - if (is_not_null(x)) /* (let* ((a 1) . b) a) */ - syntax_error_nr(sc, "let variable list improper?: ~A", 31, form); - - if (!s7_is_proper_list(sc, cdr(code))) /* (let ((a 1)) a . 1) */ - syntax_error_nr(sc, "stray dot in let body: ~S", 25, cdr(code)); - - if (named_let) - return(check_named_let(sc, vars)); - - if (vars == 0) /* !in_heap does not happen much here */ - pair_set_syntax_op(form, OP_LET_NO_VARS); - else - { - pair_set_syntax_op(form, OP_LET_UNCHECKED); - if (vars == 1) - check_let_one_var(sc, form, start); - else - { - /* this used to check that vars < gc_trigger_size, but I can't see why */ - opcode_t opt = OP_UNOPT; - for (s7_pointer p = start; is_pair(p); p = cdr(p)) - { - x = car(p); - if (is_fxable(sc, cadr(x))) - { - set_fx_direct(cdr(x), fx_choose(sc, cdr(x), sc->curlet, let_symbol_is_safe)); - if (opt == OP_UNOPT) - opt = OP_LET_NA_OLD; - } - else opt = OP_LET_UNCHECKED; - } - pair_set_syntax_op(form, opt); - if ((opt == OP_LET_NA_OLD) && - (is_null(cddr(code)))) /* 1 form in body */ - { - if (vars == 2) - { - pair_set_syntax_op(form, OP_LET_2A_OLD); - set_opt1_pair(code, caar(code)); - set_opt2_pair(code, cadar(code)); - } - else - if (vars == 3) - { - pair_set_syntax_op(form, OP_LET_3A_OLD); - set_opt1_pair(code, cadar(code)); - set_opt2_pair(code, caddar(code)); - }}}} - - /* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as args - * symbol_list is intact?? - */ - if (optimize_op(form) >= OP_LET_NA_OLD) - { - if ((!in_heap(form)) && - (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) /* recur_body is apparently never hit */ - set_opt3_let(code, make_semipermanent_let(sc, car(code))); - else - { - set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->nil); - }} - - /* fx_tree inits */ - if ((is_pair(code)) && - /* (is_let(sc->curlet)) && */ /* not rootlet=() but treeable is only in functions */ - (is_fx_treeable(code)) && /* was is_funclet(sc->curlet) 27-Sep-21, but that seems too restrictive */ - (tis_slot(let_slots(sc->curlet)))) - { - s7_pointer s1 = let_slots(sc->curlet), s2 = next_slot(s1), s3 = NULL; - bool more_vars = false; - if (tis_slot(s2)) - { - if (tis_slot(next_slot(s2))) - { - s3 = next_slot(s2); - more_vars = tis_slot(next_slot(s3)); - s3 = slot_symbol(s3); - } - s2 = slot_symbol(s2); - } - s1 = slot_symbol(s1); - for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) /* var list */ - { - s7_pointer init = cdar(p); - fx_tree(sc, init, s1, s2, s3, more_vars); - }} - return(code); -} - -static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in decl order */ -{ - s7_pointer body = cddr(sc->code), x; - s7_int n = opt2_int(sc->code); - for (x = cadr(sc->code), sc->w = sc->nil; is_pair(x); x = cdr(x)) - { - sc->w = cons(sc, caar(x), sc->w); - x = cdr(x); - if (!is_pair(x)) break; - sc->w = cons_unchecked(sc, caar(x), sc->w); - } - sc->w = proper_list_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */ - sc->curlet = make_let(sc, sc->curlet); - sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n); - add_slot(sc, sc->curlet, car(sc->code), sc->x); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ - - for (x = sc->w; is_not_null(args); x = cdr(x)) /* reuse the value cells as the new let slots */ - { - s7_pointer sym = car(x), new_args = cdr(args); - reuse_as_slot(sc, args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */ - slot_set_next(args, let_slots(sc->curlet)); - let_set_slots(sc->curlet, args); - symbol_set_local_slot(sym, let_id(sc->curlet), args); - args = new_args; - } - closure_set_let(sc->x, sc->curlet); - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - sc->x = sc->unused; - sc->code = T_Pair(body); - sc->w = sc->unused; - return(true); -} - -static bool op_let1(s7_scheme *sc) -{ - s7_pointer x, y, e; - uint64_t id; - /* building a list, then reusing it below as the let/slots seems stupid, but if we make the let first, and - * add slots, there are other problems. The let/slot ids (and symbol_set_local_slot) need to wait - * until the args are evaluated, if an arg invokes call/cc, the let on the stack needs to be copied - * including let_dox_code if it is used to save sc->code (there are 3 things that need to be protected), - * (we win currently because copy_stack copies the list), and make-circular-iterator if called twice (s7test) - * hangs -- I can't see why! Otherwise, the let/slots approach is slightly faster (less than 1% however). - */ - while (true) - { - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) - { - x = cdar(sc->code); - if (has_fx(x)) - { -#if S7_DEBUGGING - s7_pointer old_args = sc->args; -#endif - sc->value = fx_call(sc, x); -#if S7_DEBUGGING - if (sc->args != old_args) - { - fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(old_args), display(sc->args)); - gdb_break(); - } -#endif - } - else - { - check_stack_size(sc); - push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); - sc->code = car(x); - return(false); - } - sc->code = cdr(sc->code); - } - else break; - } - x = proper_list_reverse_in_place(sc, sc->args); - sc->code = car(x); /* restore the original form */ - y = cdr(x); /* use sc->args as the new let */ - sc->temp8 = y; - set_curlet(sc, reuse_as_let(sc, x, sc->curlet)); - - if (is_symbol(car(sc->code))) - return(op_named_let_1(sc, y)); /* inner let here */ - - e = sc->curlet; - id = let_id(e); - if (is_pair(y)) - { - s7_pointer sym, args = cdr(y), sp; - x = car(sc->code); - sym = caar(x); - reuse_as_slot(sc, y, sym, unchecked_car(y)); - symbol_set_local_slot(sym, id, y); - let_set_slots(e, y); - sp = y; - y = args; - - for (x = cdr(x); is_not_null(y); x = cdr(x)) - { - sym = caar(x); - args = cdr(args); - reuse_as_slot(sc, y, sym, unchecked_car(y)); - symbol_set_local_slot(sym, id, y); - slot_set_next(sp, y); - sp = y; - y = args; - } - slot_set_next(sp, slot_end(sc)); - } - sc->code = T_Pair(cdr(sc->code)); - sc->temp8 = sc->unused; - return(true); -} - -static bool op_let(s7_scheme *sc) -{ - /* sc->code is everything after the let: (let ((a 1)) a) so sc->code is (((a 1)) a) */ - /* car can be either a list or a symbol ("named let") */ - bool named_let; - - sc->code = check_let(sc); - sc->value = sc->code; - named_let = is_symbol(car(sc->code)); - sc->code = (named_let) ? cadr(sc->code) : car(sc->code); - if (is_null(sc->code)) /* (let [name] () ...): no bindings, so skip that step */ - { - sc->code = sc->value; - sc->curlet = make_let(sc, sc->curlet); - if (named_let) /* see also below -- there are 3 cases */ - { - s7_pointer body = cddr(sc->code); - set_opt2_int(cdr(sc->code), 0); - sc->x = make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0); - /* args = () in new closure, see NAMED_LET_NO_VARS above */ - /* if this is a safe closure, we can build its let in advance and name it (a thunk in this case) */ - set_funclet(closure_let(sc->x)); - funclet_set_function(closure_let(sc->x), car(sc->code)); - add_slot_checked(sc, sc->curlet, car(sc->code), sc->x); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ - sc->code = T_Pair(body); - sc->x = sc->unused; - } - else sc->code = T_Pair(cdr(sc->code)); - return(true); - } - sc->args = sc->nil; - return(op_let1(sc)); -} - -static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */ -{ - s7_pointer code = cadr(sc->code); - s7_pointer x = cdar(code); - sc->args = list_1(sc, cdr(sc->code)); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack(sc, OP_LET1, sc->args, cdr(code)); - sc->code = car(x); - return(false); /* goto EVAL */ - } - sc->code = cdr(code); - return(op_let1(sc)); -} - -static bool op_named_let(s7_scheme *sc) -{ - sc->args = sc->nil; - sc->value = cdr(sc->code); - sc->code = cadr(sc->value); - return(op_let1(sc)); -} - -static void op_named_let_no_vars(s7_scheme *sc) -{ - s7_pointer arg = cadr(sc->code); - sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */ - sc->curlet = inline_make_let(sc, sc->curlet); - sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */ - add_slot_checked(sc, sc->curlet, arg, sc->args); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ -} - -static void op_named_let_a(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - sc->code = cddr(args); - sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */ - sc->curlet = make_let(sc, sc->curlet); - sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */ - sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */ - add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args); /* inner let */ - closure_set_let(sc->x, sc->curlet); - sc->x = sc->unused; - sc->w = sc->unused; -} - -static void op_named_let_aa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - sc->code = cddr(args); - sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */ - sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */ - sc->curlet = make_let(sc, sc->curlet); - sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */ - sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */ - add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ - sc->curlet = inline_make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args, cadr(sc->w), sc->value); /* inner let */ - closure_set_let(sc->x, sc->curlet); - sc->x = sc->unused; - sc->w = sc->unused; -} - -static bool op_named_let_na(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - sc->args = sc->nil; - for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p)) - { - sc->args = cons(sc, sc->value = fx_call(sc, cdar(p)), sc->args); - p = cdr(p); - if (!is_pair(p)) break; - sc->args = cons_unchecked(sc, sc->value = fx_call(sc, cdar(p)), sc->args); - } - sc->args = proper_list_reverse_in_place(sc, sc->args); - return(op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */ -} - -static void op_let_no_vars(s7_scheme *sc) -{ - sc->curlet = inline_make_let(sc, sc->curlet); - sc->code = T_Pair(cddr(sc->code)); /* ignore the () */ -} - -static void op_let_one_new(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_LET_ONE_NEW_1, cdr(sc->code)); - sc->code = opt2_pair(sc->code); -} - -static void op_let_one_p_new(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_LET_ONE_P_NEW_1, cdr(sc->code)); - sc->code = T_Pair(opt2_pair(sc->code)); -} - -static void op_let_one_old(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1); - sc->code = opt2_pair(sc->code); -} - -static void op_let_one_old_1(s7_scheme *sc) -{ - s7_pointer let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cdr(sc->code); -} - -static void op_let_one_p_old(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1); - sc->code = T_Pair(opt2_pair(sc->code)); -} - -static void op_let_one_p_old_1(s7_scheme *sc) -{ - s7_pointer let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cadr(sc->code); -} - -static Inline void inline_op_let_a_new(s7_scheme *sc) /* three calls in eval, all get hits */ -{ - sc->code = cdr(sc->code); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, car(opt2_pair(sc->code)), fx_call(sc, cdr(opt2_pair(sc->code)))); -} - -static Inline void inline_op_let_a_old(s7_scheme *sc) /* tset(2) fb(0) cb(4) left(2) */ -{ - s7_pointer let; - sc->code = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); -} - -static inline void op_let_a_old(s7_scheme *sc) {return(inline_op_let_a_old(sc));} - -static void op_let_a_a_new(s7_scheme *sc) -{ - s7_pointer binding; - sc->code = cdr(sc->code); - binding = opt2_pair(sc->code); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))); - sc->value = fx_call(sc, cdr(sc->code)); - free_cell(sc, sc->curlet); /* don't free let_slots here unless checked first (can be null after fx_call above?) */ - /* upon return, we continue, so sc->curlet should be ok */ -} - -static void op_let_a_a_old(s7_scheme *sc) /* these are not called as fx*, and restoring sc->curlet has noticeable cost (e.g. 8 in thash) */ -{ - s7_pointer let; - sc->code = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->value = fx_call(sc, cdr(sc->code)); -} - -static void op_let_a_na_new(s7_scheme *sc) -{ - s7_pointer binding, p; - sc->code = cdr(sc->code); - binding = opt2_pair(sc->code); - sc->curlet = make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))); - for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p); - sc->value = fx_call(sc, p); - free_cell(sc, sc->curlet); /* see above */ -} - -/* this and others like it could easily be fx funcs, but check_let is called too late, so it's never seen as fxable */ -static void op_let_a_na_old(s7_scheme *sc) -{ - s7_pointer let, p; - sc->code = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p); - sc->value = fx_call(sc, p); -} - -static inline void op_let_opassq(s7_scheme *sc) -{ - s7_pointer in_val, lst; - sc->code = cdr(sc->code); - in_val = lookup(sc, opt2_sym(sc->code)); /* cadadr(caar(sc->code)); */ - lst = lookup(sc, opt3_sym(cdr(sc->code))); - if (is_pair(lst)) - sc->value = s7_assq(sc, in_val, lst); - else sc->value = (is_null(lst)) ? sc->F : g_assq(sc, set_plist_2(sc, in_val, lst)); -} - -static inline void op_let_opassq_old(s7_scheme *sc) -{ - s7_pointer let; - op_let_opassq(sc); - let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = T_Pair(cdr(sc->code)); -} - -static inline void op_let_opassq_new(s7_scheme *sc) -{ - op_let_opassq(sc); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); - sc->code = T_Pair(cdr(sc->code)); -} - -static Inline void inline_op_let_na_new(s7_scheme *sc) /* called once in eval, case gsl lg mock */ -{ - s7_pointer let, sp = NULL; - new_cell(sc, let, T_LET | T_SAFE_PROCEDURE); - let_set_id(let, sc->let_number + 1); - let_set_slots(let, slot_end(sc)); - let_set_outlet(let, sc->curlet); - sc->args = let; - for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer arg = cdar(p); - sc->value = fx_call(sc, arg); - if (!sp) - { - add_slot(sc, let, caar(p), sc->value); - sp = let_slots(let); - } - else sp = inline_add_slot_at_end(sc, let_id(let), sp, caar(p), sc->value); - } - sc->let_number++; - set_curlet(sc, let); - sc->code = T_Pair(cddr(sc->code)); -} - -static void op_let_na_old(s7_scheme *sc) -{ - s7_pointer let = opt3_let(cdr(sc->code)); - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - sc->args = let; - let_set_id(let, id); - let_set_outlet(let, sc->curlet); - for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p), slot = next_slot(slot)) - { - /* GC protected because it's a semipermanent let? or perhaps use sc->args? */ - slot_set_value(slot, fx_call(sc, cdar(p))); - symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot); - } - set_curlet(sc, let); - sc->code = T_Pair(cddr(sc->code)); -} - -static void op_let_2a_new(s7_scheme *sc) /* 2 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer a1 = opt1_pair(code); /* caar(code) */ - s7_pointer a2 = opt2_pair(code); /* cadar(code) */ - sc->curlet = inline_make_let_with_two_slots(sc, sc->curlet, car(a1), fx_call(sc, cdr(a1)), car(a2), fx_call(sc, cdr(a2))); - sc->code = cadr(code); -} - -static inline void op_let_2a_old(s7_scheme *sc) /* 2 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer let = update_let_with_two_slots(sc, opt3_let(code), fx_call(sc, cdr(opt1_pair(code))), fx_call(sc, cdr(opt2_pair(code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cadr(code); -} - -static void op_let_3a_new(s7_scheme *sc) /* 3 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer a1 = caar(code); - s7_pointer a2 = opt1_pair(code); /* cadar */ - s7_pointer a3 = opt2_pair(code); /* caddar */ - gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); /* fx_call might be fx_car_t (etc) so it needs to precede the new let */ - set_stack_protected2(sc, fx_call(sc, cdr(a2))); - sc->curlet = inline_make_let_with_two_slots(sc, sc->curlet, car(a2), stack_protected2(sc), car(a3), fx_call(sc, cdr(a3))); - add_slot(sc, sc->curlet, car(a1), stack_protected1(sc)); - unstack(sc); - sc->code = cadr(code); -} - -static void op_let_3a_old(s7_scheme *sc) /* 3 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer let = update_let_with_three_slots(sc, opt3_let(code), fx_call(sc, cdr(caar(code))), fx_call(sc, cdr(opt1_pair(code))), fx_call(sc, cdr(opt2_pair(code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cadr(code); -} - - -/* -------------------------------- let* -------------------------------- */ -static bool check_let_star(s7_scheme *sc) -{ - s7_pointer vars, form = sc->code, code = cdr(sc->code); - bool named_let, fxable = true, shadowing = false; - - if (!is_pair(code)) /* (let* . 1) */ - syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); - if (!is_pair(cdr(code))) /* (let* ()) */ - syntax_error_nr(sc, "let* has no body: ~A", 20, form); - - named_let = (is_symbol(car(code))); - - if (named_let) - { - if (!is_list(cadr(code))) /* (let* hi #t) */ - syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); - if (!is_pair(cddr(code))) /* (let* hi () . =>) or (let* hi () ) */ - { - if (is_null(cddr(code))) - syntax_error_nr(sc, "named let* has no body: ~A", 26, form); - syntax_error_nr(sc, "named let* stray dot? ~A", 24, form); - } - if (is_constant_symbol(sc, car(code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, form)); - set_local(car(code)); - } - else - if (!is_list(car(code))) /* (let* x ... ) */ - syntax_error_nr(sc, "let* variable declaration value is missing: ~A", 46, form); - - clear_symbol_list(sc); - for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var, var_and_val = car(vars); - if (!is_pair(var_and_val)) /* (let* (3) ... */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable list, ~A, is messed up in ~A", 42), - var_and_val, object_to_truncated_string(sc, form, 80))); - - if (!(is_pair(cdr(var_and_val)))) /* (let* ((x . 1))...) */ - { - if (is_null(cdr(var_and_val))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration, but no value?: ~A in ~A", 50), - var_and_val, object_to_truncated_string(sc, form, 80))); - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration is not a proper list: ~A in ~A", 56), - var_and_val, object_to_truncated_string(sc, form, 80))); - } - if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration has more than one value?: ~A in ~A", 60), - var_and_val, object_to_truncated_string(sc, form, 80))); - - var = car(var_and_val); - if (!(is_symbol(var))) /* (let* ((3 1)) 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "bad variable, ~S, in let* (it is not a symbol): ~A", 50), - var, object_to_truncated_string(sc, form, 80))); - - if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, var_and_val)); - - if ((named_let) && (symbol_is_in_arg_list(var, cdr(vars)))) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "named let* parameter, ~A, is used twice in the parameter list in ~A", 67), - var, object_to_truncated_string(sc, form, 80))); - /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */ - - if (symbol_is_in_list(sc, var)) shadowing = true; - add_symbol_to_list(sc, var); - set_local(var); - } - if (!is_null(vars)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49), - vars, object_to_truncated_string(sc, form, 80))); - - if (!s7_is_proper_list(sc, cdr(code))) - syntax_error_nr(sc, "stray dot in let* body: ~S", 26, cdr(code)); - - if (shadowing) - fxable = false; - else - for (vars = (named_let) ? cadr(code) : car(code); is_pair(vars); vars = cdr(vars)) - if (is_fxable(sc, cadar(vars))) - set_fx_direct(cdar(vars), fx_choose(sc, cdar(vars), sc->curlet, let_star_symbol_is_safe)); - else fxable = false; - - if (named_let) - { - if (is_null(cadr(code))) - { - pair_set_syntax_op(form, OP_NAMED_LET_NO_VARS); - set_opt1_pair(form, cdddr(form)); - } - else - { - pair_set_syntax_op(form, OP_NAMED_LET_STAR); - set_opt2_con(code, cadr(caadr(code))); - } - sc->value = cdr(code); - if (is_null(car(sc->value))) /* (let* name () ... */ - { - s7_pointer let_sym = car(code); - sc->curlet = make_let(sc, sc->curlet); - sc->code = T_Pair(cdr(sc->value)); - add_slot_checked(sc, sc->curlet, let_sym, make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE_STAR, 0)); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ - return(false); - } - sc->curlet = make_let(sc, sc->curlet); - push_stack(sc, OP_LET_STAR1, code, cadr(code)); - sc->code = cadr(caadr(code)); /* first var val */ - return(true); - } - if (is_null(car(code))) - { - pair_set_syntax_op(form, OP_LET_NO_VARS); /* (let* () ...) */ - - sc->curlet = make_let(sc, sc->curlet); - sc->code = T_Pair(cdr(code)); - return(false); - } - else - if (is_null(cdar(code))) - { - check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */ - if (optimize_op(form) >= OP_LET_NA_OLD) - { - if ((!in_heap(form)) && - (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) - set_opt3_let(code, make_semipermanent_let(sc, car(code))); - else - { - set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->nil); - }}} - else /* multiple variables */ - { - if (fxable) - { - pair_set_syntax_op(form, OP_LET_STAR_NA); - if ((is_null(cddr(code))) && - (is_fxable(sc, cadr(code)))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_STAR_NA_A); - }} - else pair_set_syntax_op(form, OP_LET_STAR2); - set_opt2_con(code, cadaar(code)); - } - push_stack(sc, ((intptr_t)((shadowing) ? OP_LET_STAR_SHADOWED : OP_LET_STAR1)), code, car(code)); - /* args is the let body, saved for later, code is the list of vars+initial-values */ - sc->code = cadr(caar(code)); - /* caar(code) = first var/val pair, we've checked that all these guys are legit, so cadr of that is the value */ - return(true); -} - -static bool op_let_star_shadowed(s7_scheme *sc) -{ - while (true) - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) - { - s7_pointer x = cdar(sc->code); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack_direct(sc, OP_LET_STAR_SHADOWED); - sc->code = car(x); - return(true); - }} - else break; - } - sc->code = cdr(sc->args); /* original sc->code set in push_stack above */ - return(false); -} - -static inline bool op_let_star1(s7_scheme *sc) -{ - uint64_t let_counter = S7_INT64_MAX; - s7_pointer sp = NULL; - while (true) - { - if (let_counter == sc->capture_let_counter) - { - if (sp == NULL) - { - add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(sc->code), sc->value); - } - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - } - sc->code = cdr(sc->code); - if (is_pair(sc->code)) - { - s7_pointer x = cdar(sc->code); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack_direct(sc, OP_LET_STAR1); - sc->code = car(x); - return(true); - }} - else break; - } - sc->code = sc->args; /* original sc->code set in push_stack above */ - if (is_symbol(car(sc->code))) - { - s7_pointer name = car(sc->code), body = cddr(sc->code), args = cadr(sc->code); - /* now we need to declare the new function (in the outer let) -- must delay this because init might reference same-name outer func */ - /* but the let name might be shadowed by a variable: (let* x ((x 1))...) so the name's symbol_id can be incorrect */ - if (symbol_id(name) > let_id(let_outlet(sc->curlet))) - { - s7_int cur_id = symbol_id(name); - s7_pointer cur_slot = local_slot(name); - symbol_set_id_unchecked(name, let_id(let_outlet(sc->curlet))); - add_slot_checked(sc, let_outlet(sc->curlet), name, - make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); - symbol_set_id_unchecked(name, cur_id); - set_local_slot(name, cur_slot); - } - else add_slot_checked(sc, let_outlet(sc->curlet), name, - make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); - - sc->code = body; - } - else sc->code = T_Pair(cdr(sc->code)); - return(false); -} - -static void op_let_star_na(s7_scheme *sc) -{ - /* fx safe does not mean we can dispense with the inner lets (curlet is safe for example) */ - s7_pointer sp = NULL; - uint64_t let_counter = S7_INT64_MAX; - sc->code = cdr(sc->code); - for (s7_pointer p = car(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer val = fx_call(sc, cdar(p)); /* eval in outer let */ - if (let_counter == sc->capture_let_counter) - { - if (!sp) - { - add_slot_checked(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); - } - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - }} - sc->code = T_Pair(cdr(sc->code)); -} - -static void op_let_star_na_a(s7_scheme *sc) -{ - s7_pointer sp = NULL; - uint64_t let_counter = S7_INT64_MAX; - sc->code = cdr(sc->code); - for (s7_pointer p = car(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer val = fx_call(sc, cdar(p)); - if (let_counter == sc->capture_let_counter) - { - if (!sp) - { - add_slot_checked(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); - } - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - }} - sc->value = fx_call(sc, cdr(sc->code)); -} - -static void op_named_let_star(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); /* code: (name vars ...) */ - sc->curlet = make_let(sc, sc->curlet); - push_stack(sc, OP_LET_STAR1, code, cadr(code)); - sc->code = opt2_con(code); -} - -static void op_let_star2(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - push_stack(sc, OP_LET_STAR1, code, car(code)); - sc->code = opt2_con(code); -} - - -/* -------------------------------- letrec, letrec* -------------------------------- */ -static void check_letrec(s7_scheme *sc, bool letrec) -{ - s7_pointer x, code = cdr(sc->code); - s7_pointer caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol; - - if ((!is_pair(code)) || /* (letrec . 1) */ - (!is_list(car(code)))) /* (letrec 1 ...) */ - syntax_error_with_caller_nr(sc, "~A: variable list is messed up: ~A", 34, caller, sc->code); - - if (!is_pair(cdr(code))) /* (letrec ()) */ - syntax_error_with_caller_nr(sc, "~A has no body: ~A", 18, caller, sc->code); - - clear_symbol_list(sc); - for (x = car(code); is_not_null(x); x = cdr(x)) - { - s7_pointer y, carx; - if (!is_pair(x)) /* (letrec ((a 1) . 2) ...) */ - syntax_error_with_caller_nr(sc, "~A: improper list of variables? ~A", 34, caller, sc->code); - - carx = car(x); - if (!is_pair(carx)) /* (letrec (1 2) #t) */ - syntax_error_with_caller_nr(sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, carx); - if (!(is_symbol(car(carx)))) - syntax_error_with_caller_nr(sc, "~A: bad variable ~S (it is not a symbol)", 40, caller, carx); - - y = car(carx); - if (is_constant_symbol(sc, y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->letrec_symbol, x)); - - if (!is_pair(cdr(carx))) /* (letrec ((x . 1))...) */ - { - if (is_null(cdr(carx))) /* (letrec ((x)) x) -- perhaps this is legal? */ - syntax_error_with_caller_nr(sc, "~A: variable declaration has no value?: ~A", 42, caller, carx); - syntax_error_with_caller_nr(sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, carx); - } - if (is_not_null(cddr(carx))) /* (letrec ((x 1 2 3)) ...) */ - syntax_error_with_caller_nr(sc, "~A: variable declaration has more than one value?: ~A", 53, caller, carx); - - /* check for name collisions -- this is needed in letrec* else which of the two legit values does our "rec" refer to, so to speak */ - if (symbol_is_in_list(sc, y)) - syntax_error_with_caller_nr(sc, "~A: duplicate identifier: ~A", 28, caller, y); - add_symbol_to_list(sc, y); - set_local(y); - } - - if (!s7_is_proper_list(sc, cdr(code))) - syntax_error_with_caller_nr(sc, "stray dot in ~A body: ~S", 24, caller, cdr(code)); - - for (x = car(code); is_pair(x); x = cdr(x)) - if (is_fxable(sc, cadar(x))) - set_fx_direct(cdar(x), fx_choose(sc, cdar(x), sc->curlet, let_symbol_is_safe_or_listed)); - - pair_set_syntax_op(sc->code, (letrec) ? OP_LETREC_UNCHECKED : OP_LETREC_STAR_UNCHECKED); -} - -static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let); - -static void letrec_setup_closures(s7_scheme *sc) -{ - for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (is_closure(slot_value(slot))) - { - s7_pointer func = slot_value(slot); - if ((!is_safe_closure(func)) || - (!is_optimized(car(closure_body(func))))) - optimize_lambda(sc, true, slot_symbol(slot), closure_args(func), closure_body(func)); - if (is_safe_closure_body(closure_body(func))) - { - set_safe_closure(func); - if (is_very_safe_closure_body(closure_body(func))) - set_very_safe_closure(func); - } - make_funclet(sc, func, slot_symbol(slot), closure_let(func)); - } -} - -static void op_letrec2(s7_scheme *sc) -{ - for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (is_checked_slot(slot)) - slot_set_value(slot, slot_pending_value(slot)); - letrec_setup_closures(sc); -} - -static bool op_letrec_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - /* get all local vars and set to # - * get parallel list of values - * eval each member of values list with let still full of #'s - * assign each value to its variable - * eval body - * which means that (letrec ((x x)) x) is not an error! - * but this assumes the environment is not changed by evaluating the exprs? - * (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling let, not the current let - * (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2) - * I think I need to check here that slot_pending_value is set (using the is_checked bit below): - * (letrec ((i (begin (define xyz 37) 0))) (curlet)): (inlet 'i 0 'xyz 37) -- is this correct? - */ - sc->curlet = make_let(sc, sc->curlet); - if (is_pair(car(code))) - { - s7_pointer slot; - for (s7_pointer x = car(code); is_not_null(x); x = cdr(x)) - { - slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); - slot_set_pending_value(slot, sc->undefined); - slot_set_expression(slot, cdar(x)); - set_checked_slot(slot); - } - for (slot = let_slots(sc->curlet); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC1, slot, code); - sc->code = car(slot_expression(slot)); - return(true); - } - op_letrec2(sc); - } - sc->code = T_Pair(cdr(code)); - return(false); -} - -static bool op_letrec1(s7_scheme *sc) -{ - s7_pointer slot; - slot_set_pending_value(sc->args, sc->value); - for (slot = next_slot(sc->args); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC1, slot, sc->code); - sc->code = car(slot_expression(slot)); - return(true); - } - op_letrec2(sc); - sc->code = T_Pair(cdr(sc->code)); - return(false); -} - - -static bool op_letrec_star_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - /* get all local vars and set to # - * eval each member of values list and assign immediately, as in let* - * eval body - */ - sc->curlet = make_let(sc, sc->curlet); - if (is_pair(car(code))) - { - s7_pointer slot; - for (s7_pointer x = car(code); is_not_null(x); x = cdr(x)) - { - slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); - slot_set_expression(slot, cdar(x)); - } - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - - for (slot = let_slots(sc->curlet); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC_STAR1, slot, code); - sc->code = car(slot_expression(slot)); - return(true); - }} - sc->code = T_Pair(cdr(code)); - return(false); -} - -static bool op_letrec_star1(s7_scheme *sc) -{ - s7_pointer slot = sc->args; - slot_set_value(slot, sc->value); - - for (slot = next_slot(slot); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC_STAR1, slot, sc->code); - sc->code = car(slot_expression(slot)); - return(true); - } - letrec_setup_closures(sc); - sc->code = T_Pair(cdr(sc->code)); - return(false); -} - - -/* -------------------------------- let-temporarily -------------------------------- */ -static void check_let_temporarily(s7_scheme *sc) -{ - s7_pointer x, form = sc->code, code = cdr(sc->code); - bool all_fx, all_s7; - - if ((!is_pair(code)) || /* (let-temporarily . 1) */ - (!is_list(car(code)))) /* (let-temporarily 1 ...) */ - syntax_error_nr(sc, "let-temporarily: variable list is messed up: ~A", 47, form); - /* cdr(code) = body can be nil */ - - all_fx = is_pair(car(code)); - all_s7 = all_fx; - - for (x = car(code); is_not_null(x); x = cdr(x)) - { - s7_pointer carx, caarx; - if (!is_pair(x)) /* (let-temporarily ((a 1) . 2) ...) */ - syntax_error_nr(sc, "let-temporarily: improper list of variables? ~A", 47, form); - - carx = car(x); - if (!is_pair(carx)) /* (let-temporarily (1 2) #t) */ - syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a pair (name value))", 67, carx); - - caarx = car(carx); - if (is_symbol(caarx)) - { - if (is_constant_symbol(sc, caarx)) /* (let-temporarily ((pi 3)) ...) */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, x)); - } - else - if (!is_pair(caarx)) /* (let-temporarily ((1 2)) ...) */ - syntax_error_nr(sc, "let-temporarily: bad variable ~S (the name should be a symbol or a pair)", 73, carx); - - if (!is_pair(cdr(carx))) /* (let-temporarily ((x . 1))...) */ - syntax_error_nr(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, carx); - - if (is_not_null(cddr(carx))) /* (let-temporarily ((x 1 2 3)) ...) */ - syntax_error_nr(sc, "let-temporarily: variable declaration has more than one value?: ~A", 66, carx); - - if ((all_fx) && - ((!is_symbol(caarx)) || (!is_fxable(sc, cadr(carx))))) /* if all_fx, each var is (symbol fxable-expr) */ - all_fx = false; - if ((all_s7) && - ((!is_pair(caarx)) || (car(caarx) != sc->s7_starlet_symbol) || - (!is_quoted_symbol(cadr(caarx))) || (is_keyword(cadr(cadr(caarx)))) || - (!is_fxable(sc, cadr(carx))))) - all_s7 = false; - } - if (!s7_is_proper_list(sc, cdr(code))) - syntax_error_nr(sc, "stray dot in let-temporarily body: ~S", 37, cdr(code)); - - if ((all_fx) || (all_s7)) - { - pair_set_syntax_op(form, (all_fx) ? ((is_null(cdar(code))) ? OP_LET_TEMP_A : OP_LET_TEMP_NA) : OP_LET_TEMP_S7); - for (x = car(code); is_pair(x); x = cdr(x)) - fx_annotate_arg(sc, cdar(x), sc->curlet); - - if ((optimize_op(form) == OP_LET_TEMP_A) && (is_pair(cdr(code))) && (is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_TEMP_A_A); - } - else - if (all_s7) /* not OP_LET_TEMP_NA */ - { - s7_pointer var = caar(code); - if ((is_fxable(sc, cadr(var))) && /* code: ((((*s7* 'openlets) fxable-expr)) ...) */ - (is_null(cdar(code)))) - { - if ((is_quoted_symbol(cadar(var))) && - (s7_starlet_symbol(cadr(cadar(var))) == SL_OPENLETS)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, "openlets"))) */ - { - pair_set_syntax_op(form, OP_LET_TEMP_S7_DIRECT); - set_opt1_pair(form, cdr(var)); - }}} - - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) {fx_curlet_tree(sc, code); fx_curlet_tree_in(sc, code);} - } - else - { - pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED); - if ((is_pair(car(code))) && (is_null(cdar(code))) && (is_pair(caar(code)))) - { - s7_pointer var = caar(code); - s7_pointer val = cadr(var); - var = car(var); - if ((is_pair(var)) && (car(var) == sc->setter_symbol) && (is_pair(cdr(var))) && (is_pair(cddr(var))) && (val == sc->F)) - { - /* (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ...) reactive.scm */ - optimize_expression(sc, cadr(var), 0, sc->curlet, false); - optimize_expression(sc, caddr(var), 0, sc->curlet, false); - if ((is_fxable(sc, cadr(var))) && (is_fxable(sc, caddr(var)))) - { - fx_annotate_args(sc, cdr(var), sc->curlet); - pair_set_syntax_op(form, OP_LET_TEMP_SETTER); - }}}} -} - -static void op_let_temp_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); /* step past let-temporarily */ - sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil); - push_stack_direct(sc, OP_GC_PROTECT); - /* sc->args: varlist, settees, old_values, new_values */ -} - -static void op_let_temp_init1_1(s7_scheme *sc) -{ - if ((is_symbol(sc->value)) && (is_symbol_from_symbol(sc->value))) /* (let-temporarily (((symbol ...))) ..) */ - { - clear_symbol_from_symbol(sc->value); - if (is_immutable(sc->value)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, sc->value)); - sc->value = s7_symbol_value(sc, sc->value); - } - set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args))); -} - -static bool op_let_temp_init1(s7_scheme *sc) -{ - while (is_pair(car(sc->args))) - { - /* eval car, add result to old-vals list, if any vars undefined, error */ - s7_pointer binding = caar(sc->args); - s7_pointer settee = car(binding); - s7_pointer new_value = cadr(binding); - cadr(sc->args) = cons(sc, settee, cadr(sc->args)); - binding = cdddr(sc->args); - set_car(binding, cons_unchecked(sc, new_value, car(binding))); - car(sc->args) = cdar(sc->args); - if (is_symbol(settee)) /* get initial values */ - set_caddr(sc->args, cons_unchecked(sc, lookup_checked(sc, settee), caddr(sc->args))); - else - { - if (is_pair(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_INIT1); - sc->code = settee; - return(true); - } - set_caddr(sc->args, cons_unchecked(sc, new_value, caddr(sc->args))); - }} - car(sc->args) = cadr(sc->args); - return(false); -} - -typedef enum {goto_start, goto_begin, fall_through, goto_do_end_clauses, goto_safe_do_end_clauses, - goto_eval, goto_apply_lambda, goto_do_end, goto_top_no_pop, goto_apply, - goto_eval_args, goto_eval_args_top, goto_do_unchecked, goto_pop_read_list, - goto_read_tok, goto_feed_to, goto_set_unchecked, goto_unopt} goto_t; - -static goto_t op_let_temp_init2(s7_scheme *sc) -{ - /* now eval set car new-val, cadr=settees, cadddr=new_values */ - while (is_pair(car(sc->args))) - { - s7_pointer settee = caar(sc->args), slot, p = cdddr(sc->args); - s7_pointer new_value = caar(p); - set_car(p, cdar(p)); - car(sc->args) = cdar(sc->args); - if ((!is_symbol(settee)) || (is_pair(new_value))) - { - if (is_symbol(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ - push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee); - sc->code = new_value; - return(goto_eval); - } - sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value); - push_stack_direct(sc, OP_LET_TEMP_INIT2); - return(goto_set_unchecked); - } - slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - if (is_symbol(new_value)) new_value = lookup_checked(sc, new_value); - slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, new_value) : new_value); - } - car(sc->args) = cadr(sc->args); - /* pop_stack(sc); */ /* this clobbers sc->args! 7-May-22 */ - unstack(sc); /* pop_stack_no_args(sc) in effect */ - sc->code = cdr(sc->stack_end[0]); - if (is_pair(sc->code)) - { - push_stack_direct(sc, OP_LET_TEMP_DONE); - return(goto_begin); - } - sc->value = sc->nil; /* so (let-temporarily ( () like begin I guess */ - return(fall_through); -} - -static bool op_let_temp_done1(s7_scheme *sc) -{ - while (is_pair(car(sc->args))) - { - s7_pointer settee = caar(sc->args), p = cddr(sc->args); - sc->value = caar(p); - set_car(p, cdar(p)); - car(sc->args) = cdar(sc->args); - - if ((is_pair(settee)) && (car(settee) == sc->s7_starlet_symbol) && /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */ - ((is_symbol_and_keyword(cadr(settee))) || - ((is_pair(cadr(settee))) && (caadr(settee) == sc->quote_symbol) && (is_symbol(cadadr(settee)))))) - { - s7_pointer sym = cadr(settee); - if (is_pair(sym)) sym = cadr(sym); - s7_starlet_set_1(sc, T_Sym(sym), sc->value); - } - else - { - s7_pointer slot; - if (!is_symbol(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_DONE1); /* save args and (pending) body value==sc->code */ - if ((is_pair(sc->value)) || (is_symbol(sc->value))) - sc->code = set_plist_3(sc, sc->set_symbol, settee, set_plist_2(sc, sc->quote_symbol, sc->value)); - else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); - return(false); /* goto set_unchecked */ - } - slot = lookup_slot_from(settee, sc->curlet); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ - slot_set_value(slot, call_setter(sc, slot, sc->value)); - else slot_set_value(slot, sc->value); - }} - pop_stack(sc); /* not unstack */ - sc->value = sc->code; - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(true); /* goto start */ -} - -static bool *s7_starlet_immutable_field = NULL; - -static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* 'field) fx-able-value) */ -{ - s7_pointer p, code = cdr(sc->code); /* don't use sc->code here -- it can be changed */ - s7_pointer *end = sc->stack_end; - for (p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer old_value, field = cadadr(caar(p)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */ - if (s7_starlet_immutable_field[s7_starlet_symbol(field)]) - error_nr(sc, sc->immutable_error_symbol, - set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field)); - old_value = s7_starlet(sc, s7_starlet_symbol(field)); - push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field); - } - for (p = car(code); is_pair(p); p = cdr(p), end += 4) - s7_starlet_set_1(sc, T_Sym(end[0]), fx_call(sc, cdar(p))); - sc->code = cdr(code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static void op_let_temp_s7_unwind(s7_scheme *sc) -{ - s7_starlet_set_1(sc, T_Sym(sc->code), sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static bool op_let_temp_s7_direct(s7_scheme *sc) -{ - s7_pointer new_val; - push_stack_no_code(sc, OP_LET_TEMP_S7_DIRECT_UNWIND, (sc->has_openlets) ? sc->T : sc->F); - new_val = fx_call(sc, opt1_pair(sc->code)); - sc->has_openlets = (new_val != sc->F); - sc->code = cddr(sc->code); /* cddr is body of let-temp */ - return(is_pair(sc->code)); -} - -static void op_let_temp_s7_direct_unwind(s7_scheme *sc) -{ - sc->has_openlets = (sc->args != sc->F); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let) -{ - /* called in call/cc, call-with-exit and, catch (unwind to catch) */ - check_stack_size(sc); - push_stack_direct(sc, OP_GC_PROTECT); - sc->args = T_Ext(args); - set_curlet(sc, let); - op_let_temp_done1(sc); /* an experiment 6-Nov-21, was eval(sc, OP_LET_TEMP_DONE) */ -} - -static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) -{ - if (slot_has_setter(slot)) /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */ - { - s7_pointer old_value = sc->value; - slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */ - sc->value = old_value; - } - else slot_set_value(slot, new_value); -} - -static void op_let_temp_unwind(s7_scheme *sc) -{ - let_temp_unwind(sc, sc->code, sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol fx-able-value) */ -{ - s7_pointer p, slot; - s7_pointer *end = sc->stack_end; - sc->code = cdr(sc->code); - - for (p = car(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - s7_pointer settee = car(var); - slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); - } - for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4) - { - s7_pointer var = car(p); - s7_pointer new_val = fx_call(sc, cdr(var)); - slot = end[0]; - if (slot_has_setter(slot)) - slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ - else slot_set_value(slot, new_val); - } - sc->code = cdr(sc->code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static bool op_let_temp_a(s7_scheme *sc) /* one entry */ -{ - s7_pointer var, settee, new_val, slot; - sc->code = cdr(sc->code); - var = caar(sc->code); - settee = car(var); - slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); - new_val = fx_call(sc, cdr(var)); - if (slot_has_setter(slot)) - slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ - else slot_set_value(slot, new_val); - sc->code = cdr(sc->code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static s7_pointer fx_let_temp_a_a(s7_scheme *sc, s7_pointer code) /* one entry, body is fx'd */ -{ - s7_pointer result; - op_let_temp_a(sc); - result = fx_call(sc, sc->code); - pop_stack(sc); - let_temp_unwind(sc, sc->code, sc->args); - return(result); -} - -static bool op_let_temp_setter(s7_scheme *sc) -{ - s7_pointer var, slot, sym, e = sc->curlet; - sc->code = cdr(sc->code); - var = caaar(sc->code); - sym = fx_call(sc, cdr(var)); - set_curlet(sc, fx_call(sc, cddr(var))); - slot = lookup_slot_from(sym, sc->curlet); - set_curlet(sc, e); - push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot); - slot_set_setter(slot, sc->F); - sc->code = cdr(sc->code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static void op_let_temp_setter_unwind(s7_scheme *sc) -{ - slot_set_setter(sc->code, sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - - -/* -------------------------------- quote -------------------------------- */ -static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code) -{ - if (!is_pair(cdr(code))) /* (quote . -1) */ - { - if (is_null(cdr(code))) - syntax_error_nr(sc, "quote: not enough arguments: ~A", 31, code); - syntax_error_nr(sc, "quote: stray dot?: ~A", 21, code); - } - if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */ - syntax_error_nr(sc, "quote: too many arguments ~A", 28, code); - pair_set_syntax_op(code, OP_QUOTE_UNCHECKED); - return(cadr(code)); -} - - -/* -------------------------------- and -------------------------------- */ -static bool check_and(s7_scheme *sc, s7_pointer expr) -{ - /* this, check_or and check_if might not be called -- optimize_syntax can short-circuit it to return fx* choices */ - s7_pointer p, code = cdr(expr); - int32_t any_nils = 0, len; - - if (is_null(code)) - { - sc->value = sc->T; - return(true); - } - for (len = 0, p = code; is_pair(p); p = cdr(p), len++) - { - s7_function callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); /* fx_proc can be nil! */ - if (!callee) any_nils++; - set_fx(p, callee); - } - if (is_not_null(p)) /* (and . 1) (and #t . 1) */ - syntax_error_nr(sc, "and: stray dot?: ~A", 19, expr); - - if ((fx_proc(code)) && - (is_proper_list_1(sc, cdr(code)))) - { - if ((fx_proc(code) == fx_is_pair_s) || (fx_proc(code) == fx_is_pair_t)) - { - pair_set_syntax_op(expr, OP_AND_PAIR_P); - set_opt3_sym(expr, cadar(code)); - set_opt2_con(expr, cadr(code)); - } - else pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_AP : OP_AND_2A); - } - else - { - pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_P : OP_AND_N); - if ((any_nils == 1) && (len > 2)) - { - if (!has_fx(code)) - pair_set_syntax_op(expr, OP_AND_SAFE_P1); - else - if (!has_fx(cdr(code))) - pair_set_syntax_op(expr, OP_AND_SAFE_P2); - else - if ((!has_fx(cddr(code))) && (len == 3)) - pair_set_syntax_op(expr, OP_AND_SAFE_P3); - }} - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_current_code(sc, sc->code); - return(false); -} - -static bool op_and_pair_p(s7_scheme *sc) -{ - if (!is_pair(lookup(sc, opt3_sym(sc->code)))) /* cadadr(sc->code) */ - { - sc->value = sc->F; - return(true); - } - sc->code = opt2_con(sc->code); /* caddr(sc->code); */ - return(false); -} - -static bool op_and_ap(s7_scheme *sc) -{ - /* we know fx_proc is set on sc->code, and there are only two branches */ - if (is_false(sc, fx_call(sc, cdr(sc->code)))) - { - sc->value = sc->F; - return(true); - } - sc->code = caddr(sc->code); - return(false); -} - -static void op_and_safe_p1(s7_scheme *sc) /* sc->code: (and (func...) (fx...)...) */ -{ - sc->code = cdr(sc->code); /* new value will be pushed below */ - push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST); - sc->code = car(sc->code); -} - -static bool op_and_safe_p2(s7_scheme *sc) -{ - sc->value = fx_call(sc, cdr(sc->code)); - if (is_false(sc, sc->value)) return(true); - sc->code = cddr(sc->code); - push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST); - sc->code = car(sc->code); - return(false); -} - -static bool op_and_safe_p3(s7_scheme *sc) -{ - sc->value = fx_call(sc, cdr(sc->code)); - if (is_false(sc, sc->value)) return(true); - sc->code = cddr(sc->code); - sc->value = fx_call(sc, sc->code); - if (is_false(sc, sc->value)) return(true); - sc->code = cadr(sc->code); - return(false); -} - - -/* -------------------------------- or -------------------------------- */ -static bool check_or(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer p, code = cdr(expr); - bool any_nils = false; - if (is_null(code)) - { - sc->value = sc->F; - return(true); - } - for (p = code; is_pair(p); p = cdr(p)) - { - s7_function callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); - if (!callee) any_nils = true; - set_fx(p, callee); - } - if (is_not_null(p)) - syntax_error_nr(sc, "or: stray dot?: ~A", 18, expr); - - if ((fx_proc(code)) && - (is_proper_list_1(sc, cdr(code)))) /* list_1 of cdr so there are 2 exprs */ - pair_set_syntax_op(expr, (any_nils) ? OP_OR_AP : OP_OR_2A); - else pair_set_syntax_op(expr, (any_nils) ? OP_OR_P : OP_OR_N); - - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_current_code(sc, sc->code); - return(false); -} - -static bool op_or_ap(s7_scheme *sc) -{ - /* we know fx_proc is set on sc->code, and there are only two branches */ - sc->value = fx_call(sc, cdr(sc->code)); - if (is_true(sc, sc->value)) - return(true); - sc->code = caddr(sc->code); - return(false); -} - - -/* -------------------------------- if -------------------------------- */ -static void fb_if_annotate(s7_scheme *sc, s7_pointer code, s7_pointer form) -{ - if (optimize_op(form) == OP_IF_A_P) - { - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_A_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - fb_annotate(sc, form, code, OP_IF_B_A); - } - else fb_annotate(sc, form, code, OP_IF_B_P); - } - if (optimize_op(form) == OP_IF_A_R) - fb_annotate(sc, form, code, OP_IF_B_R); - if (optimize_op(form) == OP_IF_A_N_N) - fb_annotate(sc, form, cdar(code), OP_IF_B_N_N); - if (optimize_op(form) == OP_IF_A_P_P) - { - if (is_fxable(sc, cadr(code))) - { - set_opt1_pair(form, cdr(code)); - if (is_fxable(sc, caddr(code))) - { - pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */ - set_opt2_pair(form, cddr(code)); - } - else - { - pair_set_syntax_op(form, OP_IF_A_A_P); - fb_annotate(sc, form, code, OP_IF_B_A_P); - } - fx_annotate_args(sc, cdr(code), sc->curlet); - } - else - if (is_fxable(sc, caddr(code))) - { - pair_set_syntax_op(form, OP_IF_A_P_A); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_opt2_pair(form, cddr(code)); - fb_annotate(sc, form, code, OP_IF_B_P_A); - } - else fb_annotate(sc, form, code, OP_IF_B_P_P); - } -} - -#define choose_if_optc(Opc, One, Reversed, Not) \ - ((One) ? ((Reversed) ? OP_ ## Opc ## _R : \ - ((Not) ? OP_ ## Opc ## _N : OP_ ## Opc ## _P)) : \ - ((Not) ? OP_ ## Opc ## _N_N : OP_ ## Opc ## _P_P)) - -static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool reversed) /* cdr(form) == sc->code */ -{ - s7_pointer code = cdr(form); - s7_pointer test = car(code); - bool not_case = false; - - if ((!reversed) && - (is_pair(test)) && - (car(test) == sc->not_symbol)) - { - if (!is_proper_list_1(sc, cdr(test))) return; /* (not) or (not a b) */ - not_case = true; - test = cadr(test); - } - - set_opt1_any(form, cadr(code)); - if (!one_branch) set_opt2_any(form, caddr(code)); - - if (is_pair(test)) - { - if (is_optimized(test)) - { - if (is_h_safe_c_nc(test)) /* replace these with fx_and* */ - { - pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); - if (not_case) - { - set_fx(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); - if (!reversed) set_opt3_pair(form, cdadr(form)); - } - else set_fx(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - fb_if_annotate(sc, code, form); - return; - } - if ((is_h_safe_c_s(test)) && - (is_symbol(car(test)))) - { - uint8_t typ = symbol_type(car(test)); - if (typ > 0) - { - pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_S, one_branch, reversed, not_case)); - set_opt3_byte(code, typ); - if (optimize_op(form) == OP_IF_IS_TYPE_S_P_P) - { - if (is_fxable(sc, caddr(code))) - { - set_opt2_pair(form, cddr(code)); - if (is_fxable(sc, cadr(code))) - { - set_opt1_pair(form, cdr(code)); - fx_annotate_args(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A); - } - else - { - set_opt1_any(form, cadr(code)); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A); - fx_annotate_arg(sc, cddr(code), sc->curlet); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - } - else - if (is_fxable(sc, cadr(code))) - { - set_opt2_any(form, caddr(code)); - set_opt1_pair(form, cdr(code)); - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_P); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - }}} - else - { - pair_set_syntax_op(form, choose_if_optc(IF_opSq, one_branch, reversed, not_case)); - if (not_case) set_opt1_pair(code, cadar(code)); /* code is cdr(if...): ((not (f sym)) ...) */ - } - clear_has_fx(code); - set_opt2_sym(code, cadr(test)); - return; - } - if (is_fxable(sc, test)) - { - if ((optimize_op(test) == OP_OR_2A) || (optimize_op(test) == OP_AND_2A)) - { - if (optimize_op(test) == OP_OR_2A) - pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); - else pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_pair(code, cdr(test)); - set_opt3_pair(code, cddr(test)); - return; - } - if (optimize_op(test) == OP_AND_3A) - { - pair_set_syntax_op(form, choose_if_optc(IF_AND3, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_pair(code, cdr(test)); - set_opt3_pair(code, cddr(test)); - set_opt1_pair(code, cdddr(test)); - return; - } - - pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); - if (not_case) - { - set_fx_direct(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); - if (!reversed) set_opt3_pair(form, cdadr(form)); - } - else set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - fb_if_annotate(sc, code, form); - } - else - { - pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_any(code, (not_case) ? cadar(code) : car(code)); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) - fx_curlet_tree(sc, code); - } - else - { - pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_any(code, (not_case) ? cadar(code) : car(code)); - if (is_symbol_and_syntactic(car(test))) - { - pair_set_syntax_op(test, symbol_syntax_op_checked(test)); - if ((symbol_syntax_op(car(test)) == OP_AND) || - (symbol_syntax_op(car(test)) == OP_OR)) - { - opcode_t new_op; - if (symbol_syntax_op(car(test)) == OP_AND) - check_and(sc, test); - else check_or(sc, test); - new_op = symbol_syntax_op_checked(test); - if ((new_op == OP_AND_P) || (new_op == OP_AND_AP) || (new_op == OP_AND_PAIR_P) || - (new_op == OP_AND_N) || (new_op == OP_AND_SAFE_P1) || (new_op == OP_AND_SAFE_P2) || (new_op == OP_AND_SAFE_P3)) - { - pair_set_syntax_op(form, choose_if_optc(IF_ANDP, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); - } - else - if ((new_op == OP_OR_P) || (new_op == OP_OR_AP)) - { - pair_set_syntax_op(form, choose_if_optc(IF_ORP, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); - }}}}} - else /* test is symbol or constant, but constant here is nutty */ - if (is_safe_symbol(test)) - { - pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case)); - if (not_case) set_opt1_sym(code, cadar(code)); /* code is cdr(if...): ((not sym) ...) */ - if (optimize_op(form) == OP_IF_S_P_P) - { - if (is_fxable(sc, caddr(code))) - { - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_opt2_pair(form, cddr(code)); /* opt1_any set above to cadr(code) */ - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_S_A_A); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - } - else - { - pair_set_syntax_op(form, OP_IF_S_P_A); - fx_annotate_arg(sc, cddr(code), sc->curlet); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - } - else - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_S_A_P); - fx_annotate_arg(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_opt1_pair(form, cdr(code)); - set_opt2_any(form, caddr(code)); - }}} -} - -/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond */ - -static s7_pointer check_if(s7_scheme *sc, s7_pointer form) -{ - s7_pointer cdr_code, code = cdr(form); - if (!is_pair(code)) /* (if) or (if . 1) */ - syntax_error_nr(sc, "(if): if needs at least 2 expressions: ~A", 41, form); - - cdr_code = cdr(code); - if (!is_pair(cdr_code)) /* (if 1) */ - { - if (is_null(cdr(code))) - syntax_error_nr(sc, "~S: if needs another clause", 27, form); - syntax_error_nr(sc, "~S: stray dot?", 14, form); /* (if 1 . 2) */ - } - - if (is_pair(cdr(cdr_code))) - { - if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ - syntax_error_nr(sc, "too many clauses for if: ~A", 27, form); - } - else - if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ - syntax_error_nr(sc, "if: ~A has improper list?", 25, form); - - pair_set_syntax_op(form, OP_IF_UNCHECKED); - set_if_opts(sc, form, is_null(cdr(cdr_code)), false); - set_current_code(sc, sc->code); - return(code); -} - -static void op_if(s7_scheme *sc) -{ - sc->code = check_if(sc, sc->code); - push_stack_no_args(sc, OP_IF1, cdr(sc->code)); - sc->code = car(sc->code); -} - -static void op_if_unchecked(s7_scheme *sc) -{ - push_stack_no_args(sc, OP_IF1, cddr(sc->code)); - sc->code = cadr(sc->code); -} - -static bool op_if1(s7_scheme *sc) -{ - sc->code = (is_true(sc, sc->value)) ? car(sc->code) : unchecked_car(cdr(sc->code)); - /* even pre-optimization, (if #f #f) ==> # because unique_car(sc->nil) = sc->unspecified */ - if (is_pair(sc->code)) - return(true); - sc->value = (is_symbol(sc->code)) ? lookup_checked(sc, sc->code) : sc->code; - return(false); -} - - -/* -------------------------------- when -------------------------------- */ -static void check_when(s7_scheme *sc) -{ - s7_pointer form = sc->code, code = cdr(sc->code); - - if (!is_pair(code)) /* (when) or (when . 1) */ - syntax_error_nr(sc, "when has no expression or body: ~A", 35, form); - if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */ - syntax_error_nr(sc, "when has no body?: ~A", 22, form); - if (!s7_is_proper_list(sc, cddr(code))) - syntax_error_nr(sc, "when: stray dot? ~A", 19, form); - - pair_set_syntax_op(form, OP_WHEN_P); - if (is_null(cddr(code))) - set_if_opts(sc, form, true, false); /* use if where possible */ - else - { - s7_pointer test = car(code); - if (is_safe_symbol(test)) - { - pair_set_syntax_op(form, OP_WHEN_S); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - } - else - /* fxable body doesn't happen very often -- a dozen or so hits in the standard tests */ - if (is_fxable(sc, test)) - { - pair_set_syntax_op(form, OP_WHEN_A); - if (is_pair(car(code))) set_opt2_pair(form, cdar(code)); - set_opt3_pair(form, cdr(code)); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); /* "A" in when_a */ - - if (fx_proc(code) == fx_and_2a) - pair_set_syntax_op(form, OP_WHEN_AND_2A); - else - if (fx_proc(code) == fx_and_3a) - pair_set_syntax_op(form, OP_WHEN_AND_3A); - } - else - if ((is_pair(test)) && (car(test) == sc->and_symbol)) - { - opcode_t new_op; - pair_set_syntax_op(test, symbol_syntax_op_checked(test)); - check_and(sc, test); - new_op = symbol_syntax_op_checked(test); - if (new_op == OP_AND_AP) - pair_set_syntax_op(form, OP_WHEN_AND_AP); - }} - push_stack_no_args(sc, OP_WHEN_PP, cdr(code)); - set_current_code(sc, sc->code); - sc->code = car(code); -} - -static bool op_when_s(s7_scheme *sc) -{ - if (is_true(sc, lookup(sc, cadr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ - sc->code = opt2_con(sc->code); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_a(s7_scheme *sc) -{ - if (is_true(sc, fx_call(sc, cdr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ - sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_and_2a(s7_scheme *sc) -{ - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code)))))) - { - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ - sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_and_3a(s7_scheme *sc) -{ - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && - (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code))))) && - (is_true(sc, fx_call(sc, cddr(opt2_pair(sc->code)))))) - { - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ - sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static void op_when_p(s7_scheme *sc) -{ - push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code)); - sc->code = cadr(sc->code); -} - -static bool op_when_and_ap(s7_scheme *sc) -{ - s7_pointer andp = cdadr(sc->code); - if (is_true(sc, fx_call(sc, andp))) - { - push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code)); - sc->code = cadr(andp); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_pp(s7_scheme *sc) -{ - if (is_true(sc, sc->value)) - { - if_pair_set_up_begin_unchecked(sc); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - - -/* -------------------------------- unless -------------------------------- */ -static void check_unless(s7_scheme *sc) -{ - s7_pointer form = sc->code, code = cdr(sc->code); - - if (!is_pair(code)) /* (unless) or (unless . 1) */ - syntax_error_nr(sc, "unless has no expression or body: ~A", 37, form); - if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */ - syntax_error_nr(sc, "unless has no body?: ~A", 24, form); - if (!s7_is_proper_list(sc, cddr(code))) - syntax_error_nr(sc, "unless: stray dot? ~A", 21, form); - - pair_set_syntax_op(form, OP_UNLESS_P); - if (is_null(cddr(code))) - set_if_opts(sc, form, true, true); - else - if (is_safe_symbol(car(code))) - { - pair_set_syntax_op(form, OP_UNLESS_S); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - } - else - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_UNLESS_A); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - } - push_stack_no_args(sc, OP_UNLESS_PP, cdr(code)); - set_current_code(sc, sc->code); - sc->code = car(code); -} - -static bool op_unless_s(s7_scheme *sc) -{ - if (is_false(sc, lookup(sc, cadr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ - sc->code = opt2_con(sc->code); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_unless_a(s7_scheme *sc) -{ - if (is_false(sc, fx_call(sc, cdr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ - sc->code = opt2_con(sc->code); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static void op_unless_p(s7_scheme *sc) -{ - push_stack_no_args(sc, OP_UNLESS_PP, cddr(sc->code)); - sc->code = cadr(sc->code); -} - -static bool op_unless_pp(s7_scheme *sc) -{ - if (is_false(sc, sc->value)) - { - if_pair_set_up_begin_unchecked(sc); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - - -/* -------------------------------- begin -------------------------------- */ -static bool op_begin(s7_scheme *sc, s7_pointer code) -{ - s7_pointer form = cdr(code); - if (!s7_is_proper_list(sc, form)) /* proper list includes () */ - syntax_error_nr(sc, "unexpected dot? ~A", 18, code); - if (is_null(form)) /* (begin) -> () */ - { - sc->value = sc->nil; - return(true); - } - pair_set_syntax_op(sc->code, ((is_pair(cdr(form))) && (is_null(cddr(form)))) ? OP_BEGIN_2_UNCHECKED : OP_BEGIN_UNCHECKED); /* begin_1 doesn't happen much */ - return(false); -} - - -/* -------------------------------- define -------------------------------- */ -static s7_pointer print_truncate(s7_scheme *sc, s7_pointer code) -{ - if (tree_len(sc, code) > sc->print_length) - return(object_to_truncated_string(sc, code, sc->print_length * 10)); - return(code); -} - -static void check_define(s7_scheme *sc) -{ - s7_pointer func, caller, code = cdr(sc->code); - bool starred = (sc->cur_op == OP_DEFINE_STAR); - if (starred) - { - caller = sc->define_star_symbol; - sc->cur_op = OP_DEFINE_STAR_UNCHECKED; - } - else caller = (sc->cur_op == OP_DEFINE) ? sc->define_symbol : sc->define_constant_symbol; - - if (!is_pair(code)) - syntax_error_with_caller_nr(sc, "~A: nothing to define? ~A", 25, caller, sc->code); /* (define) */ - - if (!is_pair(cdr(code))) - { - if (is_null(cdr(code))) - syntax_error_with_caller_nr(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */ - syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); /* (define var . 1) */ - } - if (!is_pair(car(code))) - { - if (is_not_null(cddr(code))) /* (define var 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: more than one value? ~A", 27), caller, print_truncate(sc, sc->code))); - if (starred) - syntax_error_nr(sc, "define* is restricted to functions: ~S", 38, sc->code); - - func = car(code); - if (!is_symbol(func)) /* (define 3 a) */ - syntax_error_with_caller2_nr(sc, "~A: can't define ~W (~A); it should be a symbol", 47, caller, func, object_type_name(sc, func)); - if (is_keyword(func)) /* (define :hi 1) */ - syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, caller, func); - if (is_syntactic_symbol(func)) /* (define and a) */ - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_80(sc->code)); - set_local(func); - } - if ((is_pair(cadr(code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */ - ((caadr(code) == sc->lambda_symbol) || - (caadr(code) == sc->lambda_star_symbol)) && - (symbol_id(caadr(code)) == 0)) - { - /* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */ - if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */ - syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); - if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */ - syntax_error_with_caller_nr(sc, "~A: no body: ~A", 15, caller, sc->code); - if (caadr(code) == sc->lambda_star_symbol) - check_lambda_star_args(sc, cadadr(code), cddr(cadr(code)), cadr(code)); - else check_lambda_args(sc, cadadr(code), NULL, cadr(code)); - optimize_lambda(sc, caadr(code) == sc->lambda_symbol, func, cadadr(code), cddr(cadr(code))); - }} - else - { - func = caar(code); - if (!is_symbol(func)) /* (define (3 a) a) */ - syntax_error_with_caller2_nr(sc, "~A: can't define ~S, ~A (should be a symbol)", 44, caller, func, object_type_name(sc, func)); - if (is_syntactic_symbol(func)) /* (define (and a) a) */ - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_80(sc->code)); - set_local(func); - } - if (starred) - set_cdar(code, check_lambda_star_args(sc, cdar(code), cdr(code), sc->code)); - else check_lambda_args(sc, cdar(code), NULL, sc->code); - optimize_lambda(sc, !starred, func, cdar(code), cdr(code)); - } - - if (sc->cur_op == OP_DEFINE) - { - if ((is_pair(car(code))) && - (!is_possibly_constant(func))) - pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED); - else pair_set_syntax_op(sc->code, OP_DEFINE_UNCHECKED); - } - else pair_set_syntax_op(sc->code, (starred) ? OP_DEFINE_STAR_UNCHECKED : OP_DEFINE_CONSTANT_UNCHECKED); -} - -static bool op_define_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code), locp; - - if ((is_pair(car(code))) && (has_location(car(code)))) - locp = car(code); - else locp = ((is_pair(cadr(code))) && (has_location(cadr(code)))) ? cadr(code) : sc->nil; - - if ((sc->cur_op == OP_DEFINE_STAR_UNCHECKED) && /* sc->cur_op changed above if define* */ - (is_pair(cdar(code)))) - { - sc->value = make_closure(sc, cdar(code), cdr(code), T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); - /* closure_body might not be cdr(code) after make_closure (add_trace) */ - if ((is_pair(locp)) && (has_location(locp))) - { - pair_set_location(closure_body(sc->value), pair_location(locp)); - set_has_location(closure_body(sc->value)); - } - sc->code = caar(code); - return(false); - } - - if (!is_pair(car(code))) - { - s7_pointer x = car(code); - sc->code = cadr(code); - if (is_pair(sc->code)) - { - push_stack_no_args(sc, OP_DEFINE1, x); - sc->cur_op = optimize_op(sc->code); - return(true); - } - sc->value = (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code; - sc->code = x; - } - else - { - s7_pointer args = cdar(code); - /* a closure. If we called this same code earlier (a local define), the only thing - * that is new here is the environment -- we can't blithely save the closure object - * in opt2 somewhere, and pick it up the next time around (since call/cc might take - * us back to the previous case). We also can't re-use opt2(sc->code) because opt2 - * is not cleared in the gc. - */ - s7_pointer x = make_closure(sc, args, cdr(code), T_CLOSURE | ((!s7_is_proper_list(sc, args)) ? T_COPY_ARGS : 0), (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET); - if ((is_pair(locp)) && (has_location(locp))) - { - pair_set_location(closure_body(x), pair_location(locp)); - set_has_location(closure_body(x)); - } - sc->value = T_Ext(x); - sc->code = caar(code); - } - return(false); -} - -static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let) -{ - s7_pointer new_let, arg; - new_cell_no_check(sc, new_let, T_LET | T_FUNCLET); - let_set_id(new_let, ++sc->let_number); - let_set_outlet(new_let, outer_let); - closure_set_let(new_func, new_let); - funclet_set_function(new_let, func_name); /* *function* returns at least funclet_function */ - let_set_slots(new_let, slot_end(sc)); - - arg = closure_args(new_func); - if (is_null(arg)) - { - let_set_slots(new_let, slot_end(sc)); - return(new_let); - } - - if (is_safe_closure(new_func)) - { - s7_pointer last_slot = NULL; - if (is_closure(new_func)) - { - if (is_pair(arg)) - { - last_slot = make_slot(sc, car(arg), sc->nil); - slot_set_next(last_slot, slot_end(sc)); - let_set_slots(new_let, last_slot); - symbol_set_local_slot(car(arg), let_id(new_let), last_slot); - for (arg = cdr(arg); is_pair(arg); arg = cdr(arg)) - last_slot = inline_add_slot_at_end(sc, let_id(new_let), last_slot, car(arg), sc->nil); - } - if (is_symbol(arg)) - { - if (last_slot) - last_slot = add_slot_at_end(sc, let_id(new_let), last_slot, arg, sc->nil); - else - { - last_slot = make_slot(sc, arg, sc->nil); - slot_set_next(last_slot, slot_end(sc)); - let_set_slots(new_let, last_slot); - symbol_set_local_slot(arg, let_id(new_let), last_slot); - } - set_is_rest_slot(last_slot); - }} - else /* closure_star */ - { - s7_pointer slot, first_default = sc->nil; - let_set_slots(new_let, slot_end(sc)); - for (; is_pair(arg); arg = cdr(arg)) - { - s7_pointer par = car(arg); - if (is_pair(par)) - { - s7_pointer val = cadr(par); - slot = add_slot_checked(sc, new_let, car(par), sc->nil); - slot_set_expression(slot, val); - if ((is_symbol(val)) || (is_pair(val))) - { - if (is_null(first_default)) - first_default = slot; - set_slot_defaults(slot); - }} - else - if (is_keyword(par)) - { - if (par == sc->rest_keyword) - { - arg = cdr(arg); - slot = add_slot_checked(sc, new_let, car(arg), sc->nil); - slot_set_expression(slot, sc->nil); - }} - else - { - slot = add_slot_checked(sc, new_let, par, sc->nil); - slot_set_expression(slot, sc->F); - }} - if (is_symbol(arg)) - { - slot = add_slot_checked(sc, new_let, arg, sc->nil); /* set up rest arg */ - set_is_rest_slot(slot); - slot_set_expression(slot, sc->nil); - } - if (tis_slot(let_slots(new_let))) - { - let_set_slots(new_let, reverse_slots(sc, let_slots(new_let))); - slot_set_pending_value(let_slots(new_let), first_default); - }} - set_immutable_let(new_let); - } - else let_set_slots(new_let, slot_end(sc)); /* if unsafe closure, arg-holding-let will be created on each call */ - return(new_let); -} - -static bool op_define_constant(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (define-constant) */ - syntax_error_nr(sc, "define-constant: not enough arguments: ~S", 41, sc->code); - - if (is_symbol_and_keyword(car(code))) /* (define-constant :rest :allow-other-keys) */ - { - if (car(code) == cadr(code)) /* (define-constant pi pi) returns pi */ - { - sc->value = car(code); - return(true); - } - syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, sc->define_constant_symbol, car(code)); - } - if ((is_symbol(car(code))) && /* (define-constant abs abs): "abs will not be touched" */ - (car(code) == cadr(code)) && - (symbol_id(car(code)) == 0) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */ - (is_null(cddr(code)))) - { - s7_pointer sym = car(code); - set_immutable_slot(global_slot(sym)); /* id == 0 so its global */ - set_possibly_constant(sym); - sc->value = lookup_checked(sc, car(code)); - return(true); - } - push_stack_no_args(sc, OP_DEFINE_CONSTANT1, car(code)); - return(false); -} - -static void op_define_constant1(s7_scheme *sc) -{ - if (is_pair(sc->code)) - sc->code = car(sc->code); /* (define-constant (ex3 a)...) */ - if (is_symbol(sc->code)) - { - s7_pointer slot = lookup_slot_from(sc->code, sc->curlet); - set_possibly_constant(sc->code); - set_immutable_slot(slot); - if (is_any_closure(slot_value(slot))) - set_immutable(slot_value(slot)); /* for the optimizer mainly */ - } -} - -static inline void define_funchecked(s7_scheme *sc) -{ - s7_pointer new_func, code = cdr(sc->code); - sc->value = caar(code); /* func name */ - - new_cell(sc, new_func, T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ? T_COPY_ARGS : 0)); - closure_set_args(new_func, cdar(code)); - closure_set_body(new_func, cdr(code)); - if (is_pair(cddr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func); - closure_set_setter(new_func, sc->F); - closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET); - sc->capture_let_counter++; - - if (is_safe_closure_body(cdr(code))) - { - set_safe_closure(new_func); - if (is_very_safe_closure_body(cdr(code))) - set_very_safe_closure(new_func); - make_funclet(sc, new_func, sc->value, sc->curlet); - } - else closure_set_let(new_func, sc->curlet); /* unsafe closures created by other functions do not support *function* */ - - if (let_id(sc->curlet) < symbol_id(sc->value)) - sc->let_number++; /* dummy let, force symbol lookup */ - add_slot_unchecked(sc, sc->curlet, sc->value, new_func, sc->let_number); - sc->value = new_func; -} - -static s7_pointer cur_op_to_caller(s7_scheme *sc, opcode_t op) -{ - switch (op) - { - case OP_DEFINE_MACRO: return(sc->define_macro_symbol); - case OP_DEFINE_MACRO_STAR: return(sc->define_macro_star_symbol); - case OP_DEFINE_BACRO: return(sc->define_bacro_symbol); - case OP_DEFINE_BACRO_STAR: return(sc->define_bacro_star_symbol); - case OP_DEFINE_EXPANSION: return(sc->define_expansion_symbol); - case OP_DEFINE_EXPANSION_STAR: return(sc->define_expansion_star_symbol); - case OP_MACRO: return(sc->macro_symbol); - case OP_MACRO_STAR: return(sc->macro_star_symbol); - case OP_BACRO: return(sc->bacro_symbol); - case OP_BACRO_STAR: return(sc->bacro_star_symbol); - } - return(sc->define_macro_symbol); -} - -static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form) -{ - s7_pointer mac_name, args, caller = cur_op_to_caller(sc, op); - - if (!is_pair(sc->code)) /* (define-macro . 1) */ - syntax_error_with_caller_nr(sc, "~A name missing (stray dot?): ~A", 32, caller, sc->code); - if (!is_pair(car(sc->code))) /* (define-macro a ...) */ - wrong_type_error_nr(sc, caller, 1, car(sc->code), wrap_string(sc, "a list: (name ...)", 18)); - - mac_name = caar(sc->code); - if (!is_symbol(mac_name)) - syntax_error_with_caller_nr(sc, "~A: ~S is not a symbol?", 23, caller, mac_name); - if (is_syntactic_symbol(mac_name)) - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_80(sc->code)); - set_local(mac_name); - } - if (is_constant_symbol(sc, mac_name)) - syntax_error_with_caller_nr(sc, "~A: ~S is constant", 18, caller, mac_name); - - if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */ - syntax_error_with_caller_nr(sc, "~A ~A, but no body?", 19, caller, mac_name); - - if (s7_list_length(sc, cdr(sc->code)) < 0) /* (define-macro (hi) 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, sc->code)); - - args = cdar(sc->code); - if ((!is_list(args)) && - (!is_symbol(args))) - error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */ - set_elist_3(sc, wrap_string(sc, "macro ~A argument list is ~S?", 29), mac_name, args)); - - if ((op == OP_DEFINE_MACRO) || (op == OP_DEFINE_BACRO) || (op == OP_DEFINE_EXPANSION)) - { - for (; is_pair(args); args = cdr(args)) - if (!is_symbol(car(args))) - error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */ - set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); - check_lambda_args(sc, cdar(sc->code), NULL, form); - } - else set_cdar(sc->code, check_lambda_star_args(sc, args, NULL, form)); - return(sc->code); -} - -static s7_pointer check_macro(s7_scheme *sc, opcode_t op, s7_pointer form) -{ - s7_pointer args, caller = cur_op_to_caller(sc, op); - - if (!is_pair(sc->code)) /* sc->code = cdr(form) */ /* (macro) or (macro . 1) */ - syntax_error_with_caller_nr(sc, "~S: ~S has no parameters or body?", 33, caller, form); - if (!is_pair(cdr(sc->code))) /* (macro (a)) */ - syntax_error_with_caller_nr(sc, "~S: ~S has no body?", 19, caller, form); - - args = car(sc->code); - if ((!is_list(args)) && - (!is_symbol(args))) - error_nr(sc, sc->syntax_error_symbol, /* (macro #(0) ...) */ - set_elist_2(sc, wrap_string(sc, "macro parameter list is ~S?", 27), args)); - - if ((op == OP_MACRO) || (op == OP_BACRO)) - { - for (; is_pair(args); args = cdr(args)) - if (!is_symbol(car(args))) - error_nr(sc, sc->syntax_error_symbol, /* (macro (1) ...) */ - set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); - check_lambda_args(sc, car(sc->code), NULL, form); - } - else set_car(sc->code, check_lambda_star_args(sc, args, NULL, form)); - - if (s7_list_length(sc, cdr(sc->code)) < 0) /* (macro () 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, form)); - - return(sc->code); -} - -static void op_macro(s7_scheme *sc) /* (macro (x) `(+ ,x 1)) */ -{ - s7_pointer form = sc->code; - sc->code = cdr(sc->code); - if ((!is_pair(sc->code)) || (!mac_is_ok(sc->code))) /* (macro)? or (macro . #\a)? */ - { - check_macro(sc, sc->cur_op, form); - set_mac_is_ok(sc->code); - } - sc->value = make_macro(sc, sc->cur_op, false); -} - -static void op_define_macro(s7_scheme *sc) -{ - s7_pointer form = sc->code; - sc->code = cdr(sc->code); - check_define_macro(sc, sc->cur_op, form); - if ((is_immutable(sc->curlet)) && - (is_let(sc->curlet))) /* not () */ - syntax_error_nr(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need syntax_error_any_with_caller? */ - sc->value = make_macro(sc, sc->cur_op, true); -} - -static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code); -static void apply_macro_star_1(s7_scheme *sc); - -static opcode_t fixup_macro_d(s7_scheme *sc, opcode_t op, s7_pointer mac) -{ - if (closure_arity_unknown(mac)) - closure_set_arity(mac, s7_list_length(sc, closure_args(mac))); - return(op); -} - -static inline bool op_macro_d(s7_scheme *sc, uint8_t typ) -{ - sc->value = lookup(sc, car(sc->code)); - if (type(sc->value) != typ) /* for-each (etc) called a macro before, now it's something else -- a very rare case */ - return(unknown_any(sc, sc->value, sc->code)); - - /* it's probably safer to always copy the list here, but that costs 4-5% in tmac, whereas this costs 3% -- maybe not worth the code? */ - if (closure_arity(sc->value) <= 0) - sc->args = copy_proper_list(sc, cdr(sc->code)); - else sc->args = cdr(sc->code); - - sc->code = sc->value; /* the macro */ - check_stack_size(sc); /* (define-macro (f) (f)) (f) */ - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); - return(false); /* fall into apply_lambda */ -} - -static bool op_macro_star_d(s7_scheme *sc) -{ - if (op_macro_d(sc, T_MACRO_STAR)) return(true); - apply_macro_star_1(sc); - return(false); -} - -static void transfer_macro_info(s7_scheme *sc, s7_pointer mac) -{ - s7_pointer body = closure_body(mac); - if (has_pair_macro(mac)) - { - set_maclet(sc->curlet); - funclet_set_function(sc->curlet, pair_macro(body)); - } - if (has_location(body)) - { - let_set_file(sc->curlet, pair_file_number(body)); - let_set_line(sc->curlet, pair_line_number(body)); - set_has_let_file(sc->curlet); - } -} - -static goto_t op_expansion(s7_scheme *sc) -{ - int64_t loc = current_stack_top(sc) - 1; - s7_pointer caller = (is_pair(stack_args(sc->stack, loc))) ? car(stack_args(sc->stack, loc)) : sc->F; /* this can be garbage */ - if ((loc >= 3) && - (stack_op(sc->stack, loc) != OP_READ_QUOTE) && /* '(expansion ...) */ - (stack_op(sc->stack, loc) != OP_READ_VECTOR) && /* #(expansion ...) */ - (caller != sc->quote_symbol) && /* (quote (expansion ...)) */ - (caller != sc->macroexpand_symbol) && /* (macroexpand (expansion ...)) */ - (caller != sc->define_expansion_symbol) && /* (define-expansion ...) being reloaded/redefined */ - (caller != sc->define_expansion_star_symbol)) /* (define-expansion* ...) being reloaded/redefined */ - { - s7_pointer symbol = car(sc->value), slot; - /* we're playing fast and loose with sc->curlet in the reader, so here we need a disaster check */ - if (!is_let(sc->curlet)) sc->curlet = sc->nil; - - if ((symbol_id(symbol) == 0) || - (sc->curlet == sc->nil)) - slot = global_slot(symbol); - else slot = lookup_slot_from(symbol, sc->curlet); - - sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; - if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code))) - clear_expansion(symbol); - else - { - /* call the reader macro */ - sc->args = cdr(sc->value); - push_stack_no_code(sc, OP_EXPANSION, sc->nil); - sc->curlet = make_let(sc, closure_let(sc->code)); - transfer_macro_info(sc, sc->code); - if (!is_macro_star(sc->code)) - return(goto_apply_lambda); - apply_macro_star_1(sc); - return(goto_begin); - /* bacros don't seem to make sense here -- they are tied to the run-time environment, - * procedures would need to evaluate their arguments in rootlet - */ - }} - return(fall_through); -} - -static void macroexpand_c_macro(s7_scheme *sc) /* callgrind shows this when it's actually calling apply_c_function (code is identical) */ -{ - s7_int len = proper_list_length(sc->args); - if (len < c_macro_min_args(sc->code)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - if (c_macro_max_args(sc->code) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); - sc->value = c_macro_call(sc->code)(sc, sc->args); -} - -static goto_t macroexpand(s7_scheme *sc) -{ - switch (type(sc->code)) - { - case T_MACRO: - sc->curlet = make_let(sc, closure_let(sc->code)); - return(goto_apply_lambda); - case T_BACRO: - sc->curlet = make_let(sc, sc->curlet); - return(goto_apply_lambda); - case T_MACRO_STAR: - sc->curlet = make_let(sc, closure_let(sc->code)); - apply_macro_star_1(sc); - return(goto_begin); - case T_BACRO_STAR: - sc->curlet = make_let(sc, sc->curlet); - apply_macro_star_1(sc); - return(goto_begin); - case T_C_MACRO: - macroexpand_c_macro(sc); - return(goto_start); - default: - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->args); - } - return(fall_through); /* for the compiler */ -} - -static goto_t op_macroexpand(s7_scheme *sc) -{ - s7_pointer form = sc->code; - sc->code = cdr(sc->code); - /* mimic APPLY, but don't push OP_EVAL_MACRO or OP_EXPANSION - * (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3)) - */ - if ((!is_pair(sc->code)) || - (!is_pair(car(sc->code)))) - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, form); - - if (!is_null(cdr(sc->code))) - syntax_error_nr(sc, "macroexpand: too many arguments: ~A", 35, form); - - if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */ - { - push_stack_no_args_direct(sc, OP_MACROEXPAND_1); - sc->code = caar(sc->code); - return(goto_eval); - } - - sc->args = cdar(sc->code); - if (!is_list(sc->args)) /* (macroexpand (mac . 7)) */ - syntax_error_nr(sc, "can't macroexpand ~S: the macro's argument list is not a list", 61, car(sc->code)); - - if (!is_symbol(caar(sc->code))) - { - if (!is_any_macro(caar(sc->code))) - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->code); - sc->code = caar(sc->code); - return(macroexpand(sc)); - } - sc->code = lookup_checked(sc, caar(sc->code)); - return(macroexpand(sc)); -} - -static goto_t op_macroexpand_1(s7_scheme *sc) -{ - sc->args = cdar(sc->code); - sc->code = sc->value; - return(macroexpand(sc)); -} - -static void op_eval_macro(s7_scheme *sc) /* after (scheme-side) macroexpansion, evaluate the resulting expression */ -{ - /* (define-macro (hi a) `(+ ,a 1)), (hi 2), here with value: (+ 2 1) */ - if (is_multiple_value(sc->value)) - { - /* a normal macro's result is evaluated (below) and its value replaces the macro invocation, - * so if a macro returns multiple values, evaluate each one, then replace the macro - * invocation with (apply values evaluated-results-in-a-list). We need to save the - * new list of results, and where we are in the macro's output list, so code=macro output, - * args=new list. If it returns (values), should we use #? I think that - * happens now without generating a multiple_value object: - * (define-macro (hi) (values)) (hi) -> # - * (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19 - * (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3 - */ - push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value)); - sc->code = car(sc->value); - } - else sc->code = sc->value; -} - -static bool op_eval_macro_mv(s7_scheme *sc) -{ - if (is_null(sc->code)) /* end of values list */ - { - sc->value = splice_in_values(sc, multiple_value(proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args)))); - return(true); - } - push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args), cdr(sc->code)); - sc->code = car(sc->code); - return(false); -} - -static void op_finish_expansion(s7_scheme *sc) -{ - /* after the expander has finished, if a list was returned, we need to add some annotations. - * if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*). - */ - if (sc->value == sc->no_value) - sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT; - else - if (is_pair(sc->value)) - sc->value = copy_body(sc, sc->value); -} - - -/* -------------------------------- with-let -------------------------------- */ -static void check_with_let(s7_scheme *sc) -{ - s7_pointer form = cdr(sc->code); - - if (!is_pair(form)) /* (with-let . "hi") */ - syntax_error_nr(sc, "with-let takes an environment argument: ~A", 42, sc->code); - if (!is_pair(cdr(form))) /* (with-let e) -> an error? */ - syntax_error_nr(sc, "with-let body is messed up: ~A", 30, sc->code); - if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */ - syntax_error_nr(sc, "stray dot in with-let body: ~S", 30, sc->code); - - pair_set_syntax_op(sc->code, ((is_normal_symbol(car(form))) && - (is_normal_symbol(cadr(form))) && /* (with-let lt a) is not the same as (with-let lt :a) */ - (is_null(cddr(form)))) ? OP_WITH_LET_S : OP_WITH_LET_UNCHECKED); - set_current_code(sc, sc->code); -} - -static bool op_with_let_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - sc->value = car(sc->code); - if (!is_pair(sc->value)) - { - if (is_symbol(sc->value)) - sc->value = lookup_checked(sc, sc->value); - sc->code = cdr(sc->code); - return(false); - } - push_stack_no_args(sc, OP_WITH_LET1, cdr(sc->code)); - sc->code = sc->value; /* eval let arg */ - return(true); -} - -static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer code = cdr(arg); - s7_pointer e = lookup_checked(sc, car(code)); - if ((!is_let(e)) && (e != sc->rootlet)) - { - e = find_let(sc, e); - if (!is_let(e)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), car(code))); - } - e = let_ref(sc, e, cadr(code)); /* (with-let e s) -> (let-ref e s) */ - if (e == sc->undefined) - unbound_variable_error_nr(sc, cadr(code)); - return(e); -} - -static void activate_with_let(s7_scheme *sc, s7_pointer e) -{ - if (!is_let(e)) /* (with-let . "hi") */ - { - s7_pointer new_e = find_let(sc, e); - if (!is_let(new_e)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), e)); - e = new_e; - } - if (e == sc->rootlet) - sc->curlet = sc->nil; /* (with-let (rootlet) ...) */ - else - { - set_with_let_let(e); - let_set_id(e, ++sc->let_number); - set_curlet(sc, e); - update_symbol_ids(sc, e); - } -} - - -/* -------------------------------- cond -------------------------------- */ -static void check_cond(s7_scheme *sc) -{ - bool has_feed_to = false, result_fx = true, result_single = true; - s7_pointer x, code = cdr(sc->code), form = sc->code; - - if (!is_pair(code)) /* (cond) or (cond . 1) */ - syntax_error_nr(sc, "cond, but no body: ~A", 21, form); - - for (x = code; is_pair(x); x = cdr(x)) - if (!is_pair(car(x))) /* (cond 1) or (cond (#t 1) 3) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "every clause in cond must be a pair: ~S in ~A", 45), - car(x), object_to_truncated_string(sc, form, 80))); - else - { - s7_pointer y = car(x); - if (!s7_is_proper_list(sc, cdr(y))) /* (cond (xxx . 1)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19), - y, object_to_truncated_string(sc, form, 80))); - if (is_pair(cdr(y))) - { - if (is_pair(cddr(y))) result_single = false; - if (is_undefined_feed_to(sc, cadr(y))) - { - has_feed_to = true; - if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "cond: '=>' target missing? ~S in ~A", 36), - x, object_to_truncated_string(sc, form, 80))); - if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "cond: '=>' has too many targets: ~S in ~A", 41), - x, object_to_truncated_string(sc, form, 80))); - }} - else result_single = false; - } - if (is_not_null(x)) /* (cond ((1 2)) . 1) */ - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond: stray dot? ~S", 19), form)); - - for (x = code; is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x); - /* clear_has_fx(p); */ /* a kludge -- if has_fx here (and not re-fx'd below), someone messed up earlier -- but was fx_treeable set? */ - if (is_fxable(sc, car(p))) - fx_annotate_arg(sc, p, sc->curlet); - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!has_fx(p)) - { - s7_function f = fx_choose(sc, p, sc->curlet, let_symbol_is_safe); - if (f) set_fx_direct(p, f); else result_fx = false; - }} - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - - if (has_feed_to) - { - pair_set_syntax_op(form, OP_COND_UNCHECKED); - if (is_null(cdr(code))) - { - s7_pointer expr = car(code), f; - f = caddr(expr); - if ((is_proper_list_3(sc, f)) && - (car(f) == sc->lambda_symbol)) - { - s7_pointer arg = cadr(f); - if ((is_pair(arg)) && - (is_null(cdr(arg))) && - (is_symbol(car(arg)))) /* (define (hi) (cond (#t => (lambda (s) s)))) */ - { - set_opt2_lambda(code, caddar(code)); /* (lambda ...) above */ - pair_set_syntax_op(form, OP_COND_FEED); - }}}} - else - { - s7_pointer p; - bool xopt = true; - int32_t i; - - pair_set_syntax_op(form, OP_COND_SIMPLE); - for (i = 0, p = code; xopt && (is_pair(p)); i++, p = cdr(p)) - xopt = ((has_fx(car(p))) && (is_pair(cdar(p)))); - if (xopt) - { - pair_set_syntax_op(form, (result_fx) ? OP_COND_NA_NA : ((result_single) ? OP_COND_NA_NP_O : OP_COND_NA_NP)); - if (result_single) - { - if (i == 2) - { - p = caadr(code); - if ((p == sc->else_symbol) || (p == sc->T)) - pair_set_syntax_op(form, OP_COND_NA_2E); - } - else - if (i == 3) - { - p = caaddr(code); - if ((p == sc->else_symbol) || (p == sc->T)) - pair_set_syntax_op(form, OP_COND_NA_3E); - }}} - else - if (result_single) - pair_set_syntax_op(form, OP_COND_SIMPLE_O); - } - set_opt3_any(code, caar(code)); -} - -static bool op_cond_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - { - sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */ - return(false); - } - push_stack_no_args_direct(sc, OP_COND1); /* true -> push cond1, goto eval */ - sc->code = opt3_any(sc->code); /* caar */ - return(true); -} - -static bool op_cond_simple(s7_scheme *sc) /* no => */ -{ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - { - sc->value = fx_call(sc, car(sc->code)); - return(false); - } - push_stack_no_args_direct(sc, OP_COND1_SIMPLE); - sc->code = opt3_any(sc->code); /* caar */ - return(true); -} - -static bool op_cond_simple_o(s7_scheme *sc) /* no =>, no null or multiform consequent */ -{ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - { - sc->value = fx_call(sc, car(sc->code)); - return(false); - } - push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); - sc->code = opt3_any(sc->code); /* caar */ - return(true); -} - -static bool op_cond1(s7_scheme *sc) -{ - while (true) - { - if (is_true(sc, sc->value)) /* test is true, so evaluate result */ - { - sc->code = cdar(sc->code); - if (is_pair(sc->code)) - { - if (is_null(cdr(sc->code))) - { - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - pop_stack(sc); - return(true); /* goto top_no_pop */ - } - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - /* check_cond catches stray dots */ - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - sc->code = cdr(sc->code); - if (is_pair(cdr(sc->code))) - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - } - else push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - /* sc->code is () */ - if (is_multiple_value(sc->value)) /* (+ 1 (cond ((values 2 3)))) */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); - /* no result clause, so return test, (cond (#t)) -> #t, (cond ((+ 1 2))) -> 3 */ - pop_stack(sc); - return(true); - } - sc->code = cdr(sc->code); /* go to next clause */ - if (is_null(sc->code)) - { - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args_direct(sc, OP_COND1); - sc->code = caar(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - }} - return(true); /* make the compiler happy */ -} - -static bool op_cond1_simple(s7_scheme *sc) -{ - while (true) - { - if (is_true(sc, sc->value)) - { - sc->code = T_Lst(cdar(sc->code)); - if (is_null(sc->code)) - { - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - pop_stack(sc); - return(true); - } - if (!has_fx(sc->code)) - return(false); - sc->value = fx_call(sc, sc->code); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) return(false); /* goto begin */ - pop_stack(sc); - return(true); /* goto top_no_pop */ - } - sc->code = cdr(sc->code); - if (is_null(sc->code)) - { - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args_direct(sc, OP_COND1_SIMPLE); - sc->code = caar(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - }} -} - -static bool op_cond1_simple_o(s7_scheme *sc) -{ - while (true) - { - if (is_true(sc, sc->value)) - { - sc->code = cdar(sc->code); - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(true); /* goto start */ - } - sc->code = car(sc->code); - return(false); - } - sc->code = cdr(sc->code); - if (is_null(sc->code)) - { - sc->value = sc->unspecified; - return(true); - } - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - check_stack_size(sc); /* 4-May-21 snd-test */ - push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); - sc->code = caar(sc->code); - return(false); - }} -} - -static bool op_cond_na_np(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results */ -{ - for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) - if (is_true(sc, fx_call(sc, car(p)))) - { - for (p = T_Lst(cdar(p)); is_pair(p); p = cdr(p)) - if (has_fx(T_Pair(p))) - sc->value = fx_call(sc, p); - else - { - if (is_pair(cdr(p))) - push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); - sc->code = car(p); - return(false); - } - return(true); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_cond_na_np_1(s7_scheme *sc) /* continuing to handle a multi-statement result from cond_na_np */ -{ - for (s7_pointer p = sc->code; is_pair(p); p = cdr(p)) - if (has_fx(T_Pair(p))) - sc->value = fx_call(sc, p); - else - { - if (is_pair(cdr(p))) - push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); - sc->code = car(p); - return(false); - } - return(true); -} - -static Inline bool inline_op_cond_na_np_o(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results, all result one expr */ -{ /* called once in eval, b case cb lg rclo str */ - for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) - if (is_true(sc, fx_call(sc, car(p)))) - { - p = cdar(p); - if (has_fx(T_Pair(p))) - { - sc->value = fx_call(sc, p); - return(true); - } - sc->code = car(p); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static inline bool fx_cond_value(s7_scheme *sc, s7_pointer p) -{ - if (has_fx(p)) - { - sc->value = fx_call(sc, p); - return(true); - } - sc->code = car(p); - return(false); -} - -static bool op_cond_na_2e(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); -} - -static bool op_cond_na_3e(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - if (is_true(sc, fx_call(sc, car(p)))) - return(fx_cond_value(sc, cdar(p))); - p = cdr(p); - return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); -} - -static bool op_cond_feed(s7_scheme *sc) -{ - /* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args_direct(sc, OP_COND_FEED_1); - sc->code = caar(sc->code); - return(true); - } - return(false); -} - -static void op_cond_feed_1(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) - sc->code = cons(sc, opt2_lambda(sc->code), multiple_value(sc->value)); - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caadr(opt2_lambda(sc->code)), sc->value); - sc->code = caddr(opt2_lambda(sc->code)); - } -} - -static bool feed_to(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) - { - sc->args = multiple_value(sc->value); - clear_multiple_value(sc->args); - if (is_symbol(cadr(sc->code))) - { - sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ - return(true); - }} - else - { - if (is_symbol(cadr(sc->code))) - { - sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ - sc->args = (needs_copied_args(sc->code)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); - return(true); - } - sc->args = list_1(sc, sc->value); /* not plist here */ - } - push_stack_direct(sc, OP_FEED_TO_1); - sc->code = cadr(sc->code); /* need to evaluate the target function */ - return(false); -} - - -/* -------------------------------- set! -------------------------------- */ -static void check_set(s7_scheme *sc) -{ - s7_pointer form = sc->code, code = cdr(sc->code); - if (!is_pair(code)) - { - if (is_null(code)) /* (set!) */ - syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); - syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */ - } - if (!is_pair(cdr(code))) - { - if (is_null(cdr(code))) /* (set! var) */ - syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); - syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */ - } - if (is_not_null(cddr(code))) /* (set! var 1 2) */ - syntax_error_nr(sc, "~A: too many arguments to set!", 30, form); - - /* cadr (the value) has not yet been evaluated */ - if (is_pair(car(code))) - { - if ((is_pair(caar(code))) && - (!is_list(cdar(code)))) /* (set! ('(1 2) . 0) 1) */ - syntax_error_nr(sc, "improper list of arguments to set!: ~A", 38, form); - if (!s7_is_proper_list(sc, car(code))) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ - syntax_error_nr(sc, "set! target is an improper list: (set! ~A ...)", 46, car(code)); - } - else - if (!is_symbol(car(code))) /* (set! 12345 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "set! can't change ~S, ~S", 24), car(code), form)); - else - if (is_constant_symbol(sc, car(code))) /* (set! pi 3) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, (is_keyword(car(code))) ? "set!: can't change keyword's value: ~S in ~S" : - "set!: can't alter constant's value: ~S in ~S", 44), - car(code), form)); - if (is_pair(car(code))) - { - /* here we have (set! (...) ...) */ - s7_pointer inner = car(code), value = cadr(code); - pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ - if (is_symbol(car(inner))) - { - if (is_null(cdr(inner))) /* (set! (symbol) ...) */ - { - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSq_A); /* (set! (symbol) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) = value */ - }} - else - if (is_null(cddr(inner))) /* we check cddr(code) above */ /* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */ - { - s7_pointer index = cadr(inner); - if (is_fxable(sc, index)) - { - if ((car(inner) == sc->let_ref_symbol) && (!is_pair(cddr(inner)))) /* perhaps also check for hash-table-ref */ - /* (let () (define (func) (catch #t (lambda () (set! (let-ref (list 1)) 1)) (lambda args 'error))) (func) (func)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, wrap_string(sc, "set!: not enough arguments for let-ref: ~S", 42), sc->code)); - fx_annotate_arg(sc, cdar(code), sc->curlet); /* cdr(inner) -> index */ - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSAq_A); /* (set! (symbol fxable) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ - - if (car(inner) == sc->s7_starlet_symbol) /* (set! (*s7* 'field) value) */ - { - s7_pointer sym = (is_symbol(index)) ? - ((is_keyword(index)) ? keyword_symbol(index) : index) : - ((is_quoted_symbol(index)) ? cadr(index) : index); - if ((is_symbol(sym)) && (s7_starlet_symbol(sym) != SL_NO_FIELD)) - { - set_safe_optimize_op(form, OP_IMPLICIT_S7_STARLET_SET); - set_opt3_sym(form, sym); - }}} - else pair_set_syntax_op(form, OP_SET_opSAq_P); /* (set! (symbol fxable) any) */ - }} - else - if ((is_null(cdddr(inner))) && - (car(inner) != sc->with_let_symbol)) /* (set! (with-let lt a) 32) needs to be handled by op_set_with_let_1 */ - { - s7_pointer index1 = cadr(inner), index2 = caddr(inner); - if ((is_fxable(sc, index1)) && (is_fxable(sc, index2))) - { - fx_annotate_args(sc, cdar(code), sc->curlet); /* cdr(inner) -> index1 and 2 */ - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSAAq_A); /* (set! (symbol fxable fxable) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ - } - else pair_set_syntax_op(form, OP_SET_opSAAq_P); /* (set! (symbol fxable fxable) any) */ - }}} - return; - } - pair_set_syntax_op(form, OP_SET_NORMAL); - if (is_symbol(car(code))) - { - s7_pointer settee = car(code), value = cadr(code); - s7_pointer slot = lookup_slot_from(settee, sc->curlet); - if ((is_slot(slot)) && - (!slot_has_setter(slot)) && - (!is_syntactic_symbol(settee))) - { - if (is_normal_symbol(value)) - { - s7_pointer slot1 = lookup_slot_from(value, sc->curlet); - if ((is_slot(slot1)) && (!slot_has_setter(slot1))) - { - pair_set_syntax_op(form, OP_SET_S_S); - set_opt2_sym(code, value); - }} - else - if ((!is_pair(value)) || - ((car(value) == sc->quote_symbol) && (is_pair(cdr(value))))) /* (quote . 1) ? */ - { - pair_set_syntax_op(form, OP_SET_S_C); - set_opt2_con(code, (is_pair(value)) ? cadr(value) : value); - } - else - { - pair_set_syntax_op(form, OP_SET_S_P); - if (is_optimized(value)) - { - if (optimize_op(value) == HOP_SAFE_C_SS) - { - if (settee == cadr(value)) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ - set_opt2_pair(code, cddr(value)); - } - else - { - pair_set_syntax_op(form, OP_SET_S_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - }} - else - { - if (is_fxable(sc, value)) /* value = cadr(code) */ - { - pair_set_syntax_op(form, OP_SET_S_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - } - if ((is_safe_c_op(optimize_op(value))) && - (is_pair(cdr(value))) && - (settee == cadr(value)) && - (!is_null(cddr(value)))) - { - if (is_null(cdddr(value))) - { - if (is_fxable(sc, caddr(value))) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ - set_opt2_pair(code, cddr(value)); - }} - else - if ((is_null(cddddr(value))) && - (is_fxable(sc, caddr(value))) && - (is_fxable(sc, cadddr(value)))) - { - pair_set_syntax_op(form, OP_INCREMENT_SAA); - fx_annotate_args(sc, cddr(value), sc->curlet); - /* fx_annotate_arg(sc, cdddr(value), sc->curlet); */ - set_opt2_pair(code, cddr(value)); - }}}} - if ((is_h_optimized(value)) && - (is_safe_c_op(optimize_op(value))) && /* else might not be opt1_cfunc? (opt1_lambda probably) */ - (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ - (is_not_null(cdr(value)))) /* (set! x (y)) */ - { - if (is_not_null(cddr(value))) - { - if ((caddr(value) == int_one) && - (cadr(value) == settee)) - { - if (opt1_cfunc(value) == sc->add_x1) - pair_set_syntax_op(form, OP_INCREMENT_BY_1); - else - if (opt1_cfunc(value) == sc->subtract_x1) - pair_set_syntax_op(form, OP_DECREMENT_BY_1); - } - else - if ((cadr(value) == int_one) && - (caddr(value) == settee) && - (opt1_cfunc(value) == sc->add_1x)) - pair_set_syntax_op(form, OP_INCREMENT_BY_1); - else - if ((settee == caddr(value)) && - (is_safe_symbol(cadr(value))) && - (caadr(code) == sc->cons_symbol)) - { - pair_set_syntax_op(form, OP_SET_CONS); - set_opt2_sym(code, cadr(value)); - }}}}}} -} - -static void op_set_s_c(s7_scheme *sc) -{ - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - if (is_immutable(slot)) - error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); - slot_set_value(slot, sc->value = opt2_con(cdr(sc->code))); -} - -static inline void op_set_s_s(s7_scheme *sc) -{ - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - if (is_immutable(slot)) - error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); - slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code)))); -} - -static Inline void op_set_s_a(s7_scheme *sc) -{ - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - if (is_immutable(slot)) - error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); - slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); -} - -static void op_set_s_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args(sc, OP_SET_SAFE, cadr(sc->code)); /* only path to op_set_safe, but we're not safe! cadr(sc->code) might be immutable */ - sc->code = caddr(sc->code); -} - -static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot */ -{ - s7_pointer slot = lookup_slot_from(sc->code, sc->curlet); - if (is_slot(slot)) - { - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code)); - slot_set_value(slot, sc->value); - } - else - if (has_let_set_fallback(sc->curlet)) - sc->value = call_let_set_fallback(sc, sc->curlet, sc->code, sc->value); - else unbound_variable_error_nr(sc, sc->code); -} - -static void op_set_from_let_temp(s7_scheme *sc) -{ - s7_pointer settee = sc->code; - s7_pointer slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, sc->value) : sc->value); -} - -static inline void op_set_cons(s7_scheme *sc) -{ - s7_pointer slot = lookup_slot_from(cadr(sc->code), sc->curlet); - slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */ -} - -static void op_increment_saa(s7_scheme *sc) -{ - s7_pointer slot, arg, val; - sc->code = cdr(sc->code); - slot = lookup_slot_from(car(sc->code), sc->curlet); - arg = opt2_pair(sc->code); /* cddr(value) */ - val = fx_call(sc, cdr(arg)); - set_car(sc->t3_2, fx_call(sc, arg)); - set_car(sc->t3_3, val); - set_car(sc->t3_1, slot_value(slot)); - slot_set_value(slot, sc->value = fn_proc(cadr(sc->code))(sc, sc->t3_1)); -} - -static void op_increment_sa(s7_scheme *sc) -{ - s7_pointer slot, arg; - sc->code = cdr(sc->code); - slot = lookup_slot_from(car(sc->code), sc->curlet); - arg = opt2_pair(sc->code); - set_car(sc->t2_2, fx_call(sc, arg)); - set_car(sc->t2_1, slot_value(slot)); - slot_set_value(slot, sc->value = fn_proc(cadr(sc->code))(sc, sc->t2_1)); -} - -static noreturn void no_setter_error_nr(s7_scheme *sc, s7_pointer obj) -{ - /* sc->code here is form without set!: ((abs 1) 2) from (set! (abs 1) 2) - * but in implicit case, (let ((L (list 0))) (set! (L 0 0) 2)), code is ((0 0) 2) - * at entry to s7_error: ((0 0 2)?? but we print something from define-hook-function if in the repl - * add indices and new-value args, is unevaluated code always available? - */ - int32_t typ = type(obj); - if (!is_pair(car(sc->code))) sc->code = cdr(sc->code); - - if (type(caar(sc->code)) >= T_C_FUNCTION_STAR) - error_nr(sc, sc->no_setter_symbol, - set_elist_6(sc, wrap_string(sc, "~W (~A) does not have a setter: (set! (~W~{~^ ~S~}) ~S)", 55), - caar(sc->code), sc->type_names[typ], caar(sc->code), cdar(sc->code), cadr(sc->code))); - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44), - caar(sc->code), sc->type_names[typ], - (is_pair(car(sc->code))) ? copy_proper_list(sc, car(sc->code)) : car(sc->code), - (is_pair(cadr(sc->code))) ? copy_proper_list(sc, cadr(sc->code)) : cadr(sc->code))); - /* copy is necessary due to the way quoted lists|symbols are handled in op_set_with_let_1|2 and copy_tree */ -} - -static bool pair3_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer arg, s7_pointer value) -{ - if (!c_function_is_aritable(setf, 2)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_6(sc, wrap_string(sc, "set!: two arguments? (~A ~S ~S), ~A is (setter ~A)", 50), setf, arg, value, setf, obj)); - if (!is_safe_procedure(setf)) /* if unsafe, we can't call c_function_call(setf) directly (need drop into eval+apply) */ - { - sc->code = setf; - sc->args = list_2(sc, arg, value); - return(true); - } - sc->value = c_function_call(setf)(sc, with_list_t2(arg, value)); - return(false); -} - -static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer value) -{ - switch (type(obj)) - { - case T_C_OBJECT: - sc->value = (*(c_object_set(sc, obj)))(sc, with_list_t3(obj, arg, value)); - break; - - case T_FLOAT_VECTOR: - sc->value = g_fv_set_3(sc, with_list_t3(obj, arg, value)); - break; - case T_INT_VECTOR: - sc->value = g_iv_set_3(sc, with_list_t3(obj, arg, value)); - break; - case T_BYTE_VECTOR: - sc->value = g_bv_set_3(sc, with_list_t3(obj, arg, value)); - break; - case T_VECTOR: -#if WITH_GMP - sc->value = g_vector_set_3(sc, with_list_t3(obj, arg, value)); -#else - if (vector_rank(obj) > 1) - sc->value = g_vector_set(sc, with_list_t3(obj, arg, value)); - else - { - s7_int index; - if (!is_t_integer(arg)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); - index = integer(arg); - if (index < 0) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must not be negative: ~S", 43), sc->code)); - if (index >= vector_length(obj)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be less than vector length: ~S", 54), sc->code)); - if (is_immutable(obj)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, obj)); - if (is_typed_vector(obj)) - value = typed_vector_setter(sc, obj, index, value); - else vector_element(obj, index) = value; - sc->value = T_Ext(value); - } -#endif - break; - - case T_STRING: -#if WITH_GMP - sc->value = g_string_set(sc, with_list_t3(obj, arg, value)); -#else - { - s7_int index; - if (!is_t_integer(arg)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), sc->code)); - index = integer(arg); - if (index < 0) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must not be negative: ~S", 30), sc->code)); - if (index >= string_length(obj)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must be less than sequence length: ~S", 43), sc->code)); - if (is_immutable(obj)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, obj)); - if (!is_character(value)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "string-set!: value must be a character: ~S", 42), sc->code)); - string_value(obj)[index] = (char)s7_character(value); - sc->value = value; - } -#endif - break; - - case T_PAIR: - sc->value = g_list_set(sc, with_list_t3(obj, arg, value)); - break; - - case T_HASH_TABLE: - if (is_immutable(obj)) /* not checked in s7_hash_table_set */ - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, obj)); - sc->value = s7_hash_table_set(sc, obj, arg, value); - break; - - case T_LET: - sc->value = let_set(sc, obj, arg, value); /* this checks immutable */ - break; - - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: - case T_C_FUNCTION_STAR: /* obj here is a c_function, but its setter could be a closure and vice versa below */ - if (is_c_function(c_function_setter(obj))) - return(pair3_cfunc(sc, obj, c_function_setter(obj), arg, value)); - sc->code = c_function_setter(obj); /* closure/macro */ - sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); - return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ - - case T_C_MACRO: /* (set! (setter quasiquote) (lambda args args)) (define (f) (set! (quasiquote 1) (setter 'i))) (f) (f) */ - if (is_c_function(c_macro_setter(obj))) - return(pair3_cfunc(sc, obj, c_macro_setter(obj), arg, value)); - sc->code = c_macro_setter(obj); - sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); - return(true); /* goto APPLY; */ - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_c_function(closure_setter(obj))) - return(pair3_cfunc(sc, obj, closure_setter(obj), arg, value)); - sc->code = closure_setter(obj); - sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); - return(true); /* goto APPLY; */ - - default: - no_setter_error_nr(sc, obj); /* possibly a continuation/goto? */ - } - return(false); -} - -static bool op_set_opsq_a(s7_scheme *sc) /* (set! (symbol) fxable) */ -{ - s7_pointer setf, value, code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - - if ((is_sequence(obj)) && (!is_c_object(obj))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "set!: not enough arguments for ~S: ~S", 37), caar(code), sc->code)); - - setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = cdr(code); - return(true); - } - value = fx_call(sc, cdr(code)); - if (is_c_function(setf)) - { - if (c_function_min_args(setf) > 1) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "set!: not enough arguments: (~A ~S)", 35), setf, value)); - sc->value = c_function_call(setf)(sc, with_list_t1(value)); - return(false); - } - sc->code = setf; - sc->args = list_1(sc, value); - return(true); -} - -static bool op_set_opsaq_a(s7_scheme *sc) /* (set! (symbol fxable) fxable) */ -{ - s7_pointer index, value, code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - bool result; - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - value = fx_call(sc, cdr(code)); - gc_protect_via_stack(sc, value); - if (dont_eval_args(obj)) /* this check is ridiculously expensive! 60 in tstar, similar lg, but it's faster than is_any_macro */ - index = cadar(code); /* if obj is a c_macro, surely we don't want to evaluate cdar(code)? */ - else index = fx_call(sc, cdar(code)); - set_stack_protected2(sc, index); - result = set_pair3(sc, obj, index, value); - unstack(sc); - return(result); -} - -static inline bool op_set_opsaq_p(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - /* ([set!] (car a) (cadr a)) */ - /* here the pair can't generate multiple values, or if it does, it's an error (caught below) - * splice_in_values will notice the OP_SET_opSAq_P_1 and complain. - * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23" - * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0)) - */ - s7_pointer obj = lookup_checked(sc, caar(code)); - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - push_stack(sc, OP_SET_opSAq_P_1, obj, code); - sc->code = cadr(code); - return(false); -} - -static inline bool op_set_opsaq_p_1(s7_scheme *sc) -{ - s7_pointer value = sc->value; - s7_pointer index; - if (dont_eval_args(sc->args)) /* see above */ - index = cadar(sc->code); - else index = fx_call(sc, cdar(sc->code)); - return(set_pair3(sc, sc->args, index, value)); /* not lookup, (set! (_!asdf!_ 3) 'a) -> unbound_variable */ -} - -static bool pair4_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer index1, s7_pointer index2, s7_pointer value) -{ - if (!c_function_is_aritable(setf, 3)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_7(sc, wrap_string(sc, "set!: three arguments? (~A ~S ~S ~S), ~A is (setter ~A)", 55), setf, index1, index2, value, setf, obj)); - if (!is_safe_procedure(setf)) - { - sc->code = setf; - sc->args = list_3(sc, index1, index2, value); - return(true); - } - sc->value = c_function_call(setf)(sc, with_list_t3(index1, index2, value)); - return(false); -} - -static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_pointer index2, s7_pointer value) -{ - switch (type(obj)) - { - case T_C_OBJECT: - sc->value = (*(c_object_ref(sc, obj)))(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - - case T_FLOAT_VECTOR: - sc->value = g_float_vector_set(sc, with_list_t4(obj, index1, index2, value)); /* would set_plist_4 be faster? or fv_unchecked_set_4? */ - break; - case T_INT_VECTOR: - sc->value = g_int_vector_set(sc, with_list_t4(obj, index1, index2, value)); - break; - case T_BYTE_VECTOR: - sc->value = g_byte_vector_set(sc, with_list_t4(obj, index1, index2, value)); - break; - case T_VECTOR: - if (vector_rank(obj) == 2) - sc->value = g_vector_set_4(sc, with_list_t4(obj, index1, index2, value)); - else - { - sc->value = g_vector_ref(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - } - break; - - case T_PAIR: - sc->value = g_list_ref(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - - case T_HASH_TABLE: - sc->value = s7_hash_table_ref(sc, obj, index1); - return(set_pair3(sc, sc->value, index2, value)); - - case T_LET: - sc->value = let_ref(sc, obj, index1); - return(set_pair3(sc, sc->value, index2, value)); - - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: - case T_C_FUNCTION_STAR: /* obj here is a c_function, but its setter could be a closure and vice versa below */ - if (is_c_function(c_function_setter(obj))) - return(pair4_cfunc(sc, obj, c_function_setter(obj), index1, index2, value)); - sc->code = c_function_setter(obj); /* closure|macro */ - sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); - return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_c_function(closure_setter(obj))) - return(pair4_cfunc(sc, obj, closure_setter(obj), index1, index2, value)); - sc->code = closure_setter(obj); - sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); - return(true); /* goto APPLY; */ - - default: - no_setter_error_nr(sc, obj); /* possibly a continuation/goto or string */ - } - return(false); /* goto start */ -} - -static bool op_set_opsaaq_a(s7_scheme *sc) /* (set! (symbol fxable fxable) fxable) */ -{ - s7_pointer index1, value, code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - bool result; - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - value = fx_call(sc, cdr(code)); - gc_protect_via_stack(sc, value); - index1 = fx_call(sc, cdar(code)); - set_stack_protected2(sc, index1); - result = set_pair4(sc, obj, index1, fx_call(sc, cddar(code)), value); - unstack(sc); - return(result); -} - -static bool op_set_opsaaq_p(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - push_stack(sc, OP_SET_opSAAq_P_1, obj, code); - sc->code = cadr(code); - return(false); -} - -static bool op_set_opsaaq_p_1(s7_scheme *sc) -{ - s7_pointer value = sc->value; - bool result; - s7_pointer index1 = fx_call(sc, cdar(sc->code)); - gc_protect_via_stack(sc, index1); - result = set_pair4(sc, sc->args, index1, fx_call(sc, cddar(sc->code)), value); - unstack(sc); - return(result); -} - -static bool op_set1(s7_scheme *sc) -{ - s7_pointer lx = lookup_slot_from(sc->code, sc->curlet); /* if unbound variable hook here, we need the binding, not the current value */ - if (is_slot(lx)) - { - if (is_immutable(lx)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, slot_symbol(lx))); - if (slot_has_setter(lx)) - { - s7_pointer func = slot_setter(lx); - if (is_c_function(func)) - sc->value = call_c_function_setter(sc, func, sc->code, sc->value); /* perhaps better: apply_c_function -- has argnum error checks */ - else - if (is_any_procedure(func)) - { - /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */ - /* 41297 (set! (v) val) where v=vector gets the setter, but calls vector-set! with no args */ - push_stack_no_args(sc, OP_SET_FROM_SETTER, lx); - if (has_let_arg(func)) - sc->args = list_3(sc, sc->code, sc->value, sc->curlet); - else sc->args = list_2(sc, sc->code, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */ - sc->code = func; - return(false); /* goto APPLY */ - }} - slot_set_value(lx, sc->value); - symbol_increment_ctr(sc->code); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */ - return(true); /* continue */ - } - if (!has_let_set_fallback(sc->curlet)) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */ - error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "~S is unbound in (set! ~S ~S)", 29), sc->code, sc->code, sc->value)); - sc->value = call_let_set_fallback(sc, sc->curlet, sc->code, sc->value); - return(true); -} - -static bool op_set_with_let_1(s7_scheme *sc) -{ - s7_pointer e, b, x = sc->value; - /* from the T_SYNTAX branch of op_set_pair: (set! (with-let e b) x) as in let-temporarily - * here sc->value is the new value for the settee = x, args has the (as yet unevaluated) let and settee-expression. - * 'b above can be a pair = generalized set in the 'e environment. - */ - if (!is_pair(sc->args)) /* (set! (with-let) ...) */ - syntax_error_nr(sc, "with-let needs a let and a symbol: (set! (with-let) ~$)", 55, sc->value); - if (!is_pair(cdr(sc->args))) /* (set! (with-let e) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "with-let in (set! (with-let ~S) ~$) has no symbol to set?", 57), car(sc->args), sc->value)); - - e = car(sc->args); - b = cadr(sc->args); - if (is_multiple_value(x)) /* (set! (with-let lt) (values 1 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "can't (set! (with-let ~S ~S) (values ~{~S~^ ~})): too many values", 65), e, b, x)); - - if (is_symbol(e)) - { - if (is_symbol(b)) - { - e = lookup_checked(sc, e); /* the let */ - if (!is_let(e)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, e, a_let_string); - sc->value = let_set_1(sc, e, b, x); - pop_stack(sc); - return(true); - } - sc->value = lookup_checked(sc, e); - sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_symbol, x) : x); - /* (let* ((x (vector 1 2)) (lt (curlet))) (set! (with-let lt (x 0)) 32) x) here: (set! (x 0) 32) */ - return(false); /* goto SET_WITH_LET */ - } - sc->code = e; /* 'e above, an expression we need to evaluate */ - sc->args = set_plist_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */ - push_stack_direct(sc, OP_SET_WITH_LET_2); - sc->cur_op = optimize_op(sc->code); - return(true); /* goto top_no_pop */ -} - -static bool op_set_with_let_2(s7_scheme *sc) -{ - s7_pointer b, x; - /* here sc->value = let = 'e, args = '(b x) where 'b might be a pair */ - if (!is_let(sc->value)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, sc->value, a_let_string); - b = car(sc->args); - if ((!is_symbol(b)) && (!is_pair(b))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't set ~S in ~$", 18), b, set_ulist_1(sc, global_value(sc->set_symbol), sc->args))); - x = cadr(sc->args); - if (is_symbol(b)) /* b is a symbol -- everything else is ready so call let-set! */ - { - sc->value = let_set_1(sc, sc->value, b, x); - return(true); /* continue */ - } - if ((is_symbol(x)) || (is_pair(x))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ - sc->code = list_3(sc, sc->set_symbol, b, - ((is_symbol(x)) || (is_pair(x))) ? list_2(sc, sc->quote_symbol, x) : x); - else sc->code = cons(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */ - return(false); /* fall into SET_WITH_LET */ -} - -static bool op_set_normal(s7_scheme *sc) -{ - s7_pointer x; - sc->code = cdr(sc->code); - x = cadr(sc->code); - if (is_pair(x)) - { - push_stack_no_args(sc, OP_SET1, car(sc->code)); - sc->code = x; - return(true); - } - sc->value = (is_symbol(x)) ? lookup_checked(sc, x) : T_Ext(x); - sc->code = car(sc->code); - return(false); -} - -static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? saves 22 in concordance */ -{ - s7_pointer val, y = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - val = slot_value(y); - if (is_t_integer(val)) - sc->value = make_integer(sc, integer(val) + 1); - else - switch (type(val)) - { - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) + denominator(val); - denominator(sc->value) = denominator(val); - break; - case T_REAL: - sc->value = make_real(sc, real(val) + 1.0); - break; - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) + 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - default: - sc->value = add_p_pp(sc, val, int_one); - break; - } - slot_set_value(y, sc->value); -} - -static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ -{ - s7_pointer val, y = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - val = slot_value(y); - if (is_t_integer(val)) - sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */ - else - switch (type(val)) - { - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) - denominator(val); - denominator(sc->value) = denominator(val); - break; - case T_REAL: - sc->value = make_real(sc, real(val) - 1.0); - break; - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) - 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - default: - sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); - break; - } - slot_set_value(y, sc->value); -} - - -/* ---------------- implicit ref/set ---------------- */ -static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form); - -static Inline bool inline_op_implicit_vector_ref_a(s7_scheme *sc) /* called once in eval */ -{ - s7_pointer x; - s7_pointer v = lookup_checked(sc, car(sc->code)); - if (!is_any_vector(v)) - { - sc->last_function = v; - return(false); - } - x = fx_call(sc, cdr(sc->code)); - if ((s7_is_integer(x)) && - (vector_rank(v) == 1)) - { - s7_int index = s7_integer_clamped_if_gmp(sc, x); - if ((index < vector_length(v)) && (index >= 0)) - { - sc->value = (is_float_vector(v)) ? make_real(sc, float_vector(v, index)) : vector_getter(v)(sc, v, index); - return(true); - }} - sc->value = vector_ref_1(sc, v, set_plist_1(sc, x)); - return(true); -} - -static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* if Inline 70 in concordance */ -{ - s7_pointer x, y, code; - s7_pointer v = lookup_checked(sc, car(sc->code)); - if ((!is_any_vector(v)) || (vector_rank(v) != 2)) - { - sc->last_function = v; - return(false); - } - code = cdr(sc->code); - x = fx_call(sc, code); - gc_protect_via_stack(sc, x); - y = fx_call(sc, cdr(code)); - set_stack_protected2(sc, y); - if ((s7_is_integer(x)) && (s7_is_integer(y)) && - (vector_rank(v) == 2)) - { - s7_int ix = s7_integer_clamped_if_gmp(sc, x); - s7_int iy = s7_integer_clamped_if_gmp(sc, y); - if ((ix >= 0) && (iy >= 0) && - (ix < vector_dimension(v, 0)) && (iy < vector_dimension(v, 1))) - { - s7_int index = (ix * vector_offset(v, 0)) + iy; - sc->value = vector_getter(v)(sc, v, index); /* check for normal vector saves in some cases, costs in others */ - unstack(sc); - return(true); - }} - sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y)); - unstack(sc); - return(true); -} - -static inline bool op_implicit_vector_set_3(s7_scheme *sc) -{ - s7_pointer i1, code = cdr(sc->code); - s7_pointer v = lookup(sc, caar(code)); - if (!is_any_vector(v)) - { - /* this could be improved -- set_pair3 perhaps: pair3 set opt3? but this calls g_vector_set_3 */ - pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); - return(true); - } - i1 = fx_call(sc, cdar(code)); /* gc protect? */ - set_car(sc->t3_3, fx_call(sc, cdr(code))); - set_car(sc->t3_1, v); - set_car(sc->t3_2, i1); - sc->value = g_vector_set_3(sc, sc->t3_1); /* calls vector_setter handling any vector type whereas vector_set_p_ppp wants a normal vector */ - /* sc->value = vector_set_p_ppp(sc, v, i1, fx_call(sc, cdr(code))); */ - return(false); -} - -static bool op_implicit_vector_set_4(s7_scheme *sc) -{ - s7_pointer i1, i2, code = cdr(sc->code); - s7_pointer v = lookup(sc, caar(code)); - if (!is_any_vector(v)) - { - pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); - return(true); - } - i1 = fx_call(sc, cdar(code)); - i2 = fx_call(sc, opt3_pair(sc->code)); /* cddar(code) */ - set_car(sc->t3_3, fx_call(sc, cdr(code))); - set_car(sc->t4_1, v); - set_car(sc->t3_1, i1); - set_car(sc->t3_2, i2); - sc->value = g_vector_set_4(sc, sc->t4_1); - set_car(sc->t4_1, sc->F); - return(false); -} - -static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - /* vect is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */ - s7_pointer index; - s7_int argnum; - - if (!is_pair(inds)) - wrong_number_of_args_error_nr(sc, "no index for implicit vector-set!: ~S", form); - if (is_immutable(vect)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vect)); - - argnum = proper_list_length(inds); - if ((argnum > 1) && - (is_normal_vector(vect)) && - (argnum != vector_rank(vect))) - { - /* this block needs to be first to handle (eg): - * (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a 32)) - * sc->code here: ((v 0 'a) 32) - */ - if (vector_rank(vect) == 1) - { - s7_pointer ind = car(inds); - if (is_symbol(ind)) ind = lookup_checked(sc, ind); - if (is_t_integer(ind)) - { - s7_pointer obj; - s7_int index1 = integer(ind); - if ((index1 < 0) || (index1 >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(inds), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); - obj = vector_element(vect, index1); - if (!is_applicable(obj)) - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~S) is ~S which can't take arguments", 47), form, vect, car(inds), obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - }} - push_stack(sc, OP_SET2, cdr(inds), val); - sc->code = list_2(sc, vect, car(inds)); - return(goto_unopt); - } - - if ((argnum > 1) || (vector_rank(vect) > 1)) - { - if ((argnum == 2) && - (cdr(form) == sc->code) && /* form == cdr(sc->code) only on the outer call, thereafter form is the old form for better error messages */ - (is_fxable(sc, car(inds))) && - (is_fxable(sc, cadr(inds))) && - (is_fxable(sc, car(val)))) /* (set! (v fx fx) fx) */ - { - fx_annotate_args(sc, inds, sc->curlet); - fx_annotate_arg(sc, val, sc->curlet); - set_opt3_pair(form, cdr(inds)); - pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_4); - } - if ((argnum == vector_rank(vect)) && - (!is_pair(car(val)))) - { - s7_pointer p; - for (p = inds; is_pair(p); p = cdr(p)) - if (is_pair(car(p))) break; - if (is_null(p)) - { - s7_pointer pa; - s7_pointer args = safe_list_if_possible(sc, argnum + 2); - if (in_heap(args)) gc_protect_via_stack(sc, args); - car(args) = vect; - for (p = inds, pa = cdr(args); is_pair(p); p = cdr(p), pa = cdr(pa)) - { - index = car(p); - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - { - if (in_heap(args)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), form)); - } - car(pa) = index; - } - car(pa) = car(val); - if (is_symbol(car(pa))) - car(pa) = lookup_checked(sc, car(pa)); - sc->value = g_vector_set(sc, args); - if (in_heap(args)) unstack(sc); - else clear_list_in_use(args); - return(goto_start); - }} - push_op_stack(sc, sc->vector_set_function); /* vector_setter(vect) has wrong args */ - sc->code = (is_null(cdr(inds))) ? val : pair_append(sc, cdr(inds), val); /* i.e. rest(args) + val */ - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), sc->code); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - - /* one index, rank == 1 */ - index = car(inds); - if ((is_symbol(car(sc->code))) && /* not (set! (#(a 0 (3)) 1) 0) -- implicit_vector_set_3 assumes symbol vect ref */ - (cdr(form) == sc->code) && - (is_fxable(sc, index)) && - (is_fxable(sc, car(val)))) - { - fx_annotate_arg(sc, inds, sc->curlet); - fx_annotate_arg(sc, val, sc->curlet); - pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_3); - } - if (!is_pair(index)) - { - s7_int ind; - s7_pointer value; - - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = car(val); - if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - if (is_typed_vector(vect)) - typed_vector_setter(sc, vect, ind, value); - else vector_setter(vect)(sc, vect, ind, value); - sc->value = T_Ext(value); - return(goto_start); - } - push_op_stack(sc, sc->vector_set_function); - sc->args = list_2(sc, index, vect); - sc->code = val; - return(goto_eval_args); - } - /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */ - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), val); - push_op_stack(sc, sc->vector_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer index; - /* c_obj's set! method needs to provide error checks */ - - if ((!is_pair(inds)) || (!is_null(cdr(inds)))) - { - push_op_stack(sc, sc->c_object_set_function); - if (is_null(inds)) - { - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, c_obj), sc->nil); - sc->code = car(val); - } - else - { - sc->code = pair_append(sc, cdr(inds), val); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), sc->code); - sc->code = car(inds); - } - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - index = car(inds); - if (!is_pair(index)) - { - s7_pointer value = car(val); - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - sc->value = (*(c_object_set(sc, c_obj)))(sc, with_list_t3(c_obj, index, value)); - return(goto_start); - } - push_op_stack(sc, sc->c_object_set_function); - sc->args = list_2(sc, index, c_obj); - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), val); - push_op_stack(sc, sc->c_object_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static bool op_implicit_string_ref_a(s7_scheme *sc) -{ - s7_int index; - s7_pointer s = lookup_checked(sc, car(sc->code)); - s7_pointer x = fx_call(sc, cdr(sc->code)); - if (!is_string(s)) - { - sc->last_function = s; - return(false); - } - if (!s7_is_integer(x)) - { - sc->value = string_ref_1(sc, s, set_plist_1(sc, x)); - return(true); - } - index = s7_integer_clamped_if_gmp(sc, x); - if ((index < string_length(s)) && (index >= 0)) - { - sc->value = chars[((uint8_t *)string_value(s))[index]]; - return(true); - } - sc->value = string_ref_1(sc, s, x); - return(true); -} - -static goto_t set_implicit_string(s7_scheme *sc, s7_pointer str, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - /* here only one index makes sense and it is required, so (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a) are all errors (but see below!) */ - s7_pointer index; - - if (!is_pair(inds)) - wrong_number_of_args_error_nr(sc, "no index for string set!: ~S", form); - if (!is_null(cdr(inds))) - wrong_number_of_args_error_nr(sc, "too many indices for string set!: ~S", form); - - index = car(inds); - if (!is_pair(index)) - { - s7_int ind; - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), form)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= string_length(str))) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - if (is_immutable(str)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, str)); - - val = car(val); - if (!is_pair(val)) - { - if (is_symbol(val)) - val = lookup_checked(sc, val); - if (is_character(val)) - { - string_value(str)[ind] = character(val); - sc->value = val; - return(goto_start); - } - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "value must be a character: ~S", 29), form)); - } - /* maybe op_implicit_string_set_a as in vector someday, but this code isn't (currently) called much */ - push_op_stack(sc, sc->string_set_function); - sc->args = list_2(sc, index, str); - sc->code = cdr(sc->code); - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, str), val); /* args4 not 1 because we know cdr(sc->code) is a pair */ - push_op_stack(sc, sc->string_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer lst, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer index, index_val = NULL, value = car(val); - - if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught somewhere else */ - wrong_number_of_args_error_nr(sc, "no index for list-set!: ~S", form); - - index = car(inds); - if (!is_pair(index)) - index_val = (is_normal_symbol(index)) ? lookup_checked(sc, index) : index; - - if (!is_null(cdr(inds))) - { - /* split (set! (a b c...) v) into (set! ((a b) c ...) v), eval (a b), return (let ((L (list (list 1 2)))) (set! (L 0 0) 3) L) */ - if (index_val) - { - s7_pointer obj = list_ref_1(sc, lst, index_val); - if (!is_applicable(obj)) - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, lst, index_val, obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } - push_stack(sc, OP_SET2, cdr(inds), val); /* (let ((L (list (list 1 2 3)))) (set! (L (- (length L) 1) 2) 0) L) */ - sc->code = list_2(sc, caadr(form), car(inds)); - return(goto_unopt); - } - if (index_val) - { - if (!is_pair(value)) - { - set_car(sc->t2_1, index_val); - set_car(sc->t2_2, (is_symbol(value)) ? lookup_checked(sc, value) : value); - sc->value = g_list_set_1(sc, lst, sc->t2_1, 2); - return(goto_start); - } - push_op_stack(sc, sc->list_set_function); /* because cdr(inds) is nil, we're definitely calling list_set */ - sc->args = list_2(sc, index_val, lst); /* plist unsafe here */ - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, lst), val); /* plist unsafe here */ - push_op_stack(sc, sc->list_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer key, keyval = NULL; - - if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught elsewhere */ - wrong_number_of_args_error_nr(sc, "no key for hash-table-set!: ~S", form); - if (is_immutable(table)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, table)); - - key = car(inds); - if (is_pair(key)) - { - if (car(key) == sc->quote_symbol) - keyval = cadr(key); - } - else keyval = (is_normal_symbol(key)) ? lookup_checked(sc, key) : key; - - if (!is_null(cdr(inds))) - { - if (keyval) - { - s7_pointer obj = s7_hash_table_ref(sc, table, keyval); - if (obj == sc->F) /* (let ((h (hash-table 'b 1))) (set! (h 'a 'asdf) 32)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "in ~S, ~$ does not exist in ~S", 30), form, keyval, table)); - else - if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, table, keyval, obj)); - /* (let ((v (hash-table 'a (hash-table 'b 1)))) (set! (v 'a 'b 'b) 32) v) -> - * error: in (set! (v 'a 'b 'b) 32), ((hash-table 'b 1) 'b) is 1 which can't take arguments - * (let ((v (hash-table 'a (list 1 2)))) (set! (v 'a 1) 5)) -> code: (set! ((1 2) 1) 5) -> 5 (v: (hash-table 'a (1 5))) - */ - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } - push_stack(sc, OP_SET2, cdr(inds), val); /* (let ((L (hash-table 'b (hash-table 'a 1)))) (set! (L (symbol "b") (symbol "a")) 0) L) */ - sc->code = list_2(sc, caadr(form), key); /* plist unsafe */ - return(goto_unopt); - } - if (keyval) - { - s7_pointer value = car(val); - if (is_pair(value)) - { - if (car(value) == sc->quote_symbol) - { - sc->value = s7_hash_table_set(sc, table, keyval, cadr(value)); - return(goto_start); - }} - else - { - sc->value = s7_hash_table_set(sc, table, keyval, (is_normal_symbol(value)) ? lookup_checked(sc, value) : value); - return(goto_start); - } - push_op_stack(sc, sc->hash_table_set_function); /* because cdr(inds) is nil, we're definitely calling hash_table_set */ - sc->args = list_2(sc, keyval, table); /* plist unsafe here */ - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, table), val); /* plist unsafe here */ - push_op_stack(sc, sc->hash_table_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer sym, symval = NULL; - - if (!is_pair(inds)) /* as above, bad val caught elsewhere */ - wrong_number_of_args_error_nr(sc, "no symbol (variable name) for let-set!: ~S", form); - - sym = car(inds); - if (is_pair(sym)) - { - if (car(sym) == sc->quote_symbol) - symval = cadr(sym); - } - else symval = (is_normal_symbol(sym)) ? lookup_checked(sc, sym) : sym; - - if (!is_null(cdr(inds))) - { - if (symval) - { - s7_pointer obj = let_ref(sc, let, symval); - if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, let, symval, obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } - push_stack(sc, OP_SET2, cdr(inds), val); - sc->code = list_2(sc, let, car(inds)); - return(goto_unopt); - } - if (symval) - { - s7_pointer value = car(val); - if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - sc->value = let_set(sc, let, symval, value); - return(goto_start); - } - push_op_stack(sc, sc->let_set_function); - sc->args = list_2(sc, symval, let); - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, let), val); - push_op_stack(sc, sc->let_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_function(s7_scheme *sc, s7_pointer fnc) /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */ -{ - if (!is_t_procedure(c_function_setter(fnc))) - { - if (!is_any_macro(c_function_setter(fnc))) - no_setter_error_nr(sc, fnc); - sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : pair_append(sc, cdar(sc->code), cdr(sc->code)); - sc->code = c_function_setter(fnc); - /* here multiple-values can't happen because we don't eval the new-value argument */ - return(goto_apply); - } - /* here the setter can be anything, so we need to check the needs_copied_args bit. (set! ((dilambda / (let ((x 3)) (lambda (y) (+ x y))))) 3)! */ - - /* TODO: if (is_pair(cadr(sc->code))) we need to protect against values somehow - * (let-temporarily (((setter list) list)) (let () (define (f1) (values 3 4 5)) (set! (list 1 2) (f1)))) - * (let-temporarily (((setter list) list)) (set! (list 1 2) (values 3 4 5))) - * these are errors (too many args to set!) after optimization, but before they go through eval-args and return a list '(1 2 3 4 5)! - * maybe the fix is to accept values in both cases? (it's apparently impossible to catch this error currently) - * currently: - * (let-temporarily (((setter list) list)) (set! (list 1 2) (values 3 4 5))) ;'(1 2 3 4 5) - * (let-temporarily (((setter list) list)) (set! (list 1 2) 3 4 5)) ; error too many arguments to set! - * (let-temporarily (((setter list) list)) (let () (define (f) (set! (list 1 2) (values 3 4 5))) (f))) ;'(1 2 3 4 5) - * (let-temporarily (((setter list) list)) (let () (define (f) (set! (list 1 2) (values 3 4 5))) (f) (f))) ;error: too many values to set! (values 3 4 5) - */ - push_op_stack(sc, c_function_setter(fnc)); - if (is_pair(cdar(sc->code))) - { - sc->value = (is_null(cddar(sc->code))) ? cdr(sc->code) : pair_append(sc, cddar(sc->code), cdr(sc->code)); - push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value); - sc->code = cadar(sc->code); - } - else - { - push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil); - sc->code = cadr(sc->code); /* new value */ - } - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer fnc) -{ - s7_pointer setter = closure_setter(fnc); - if ((setter == sc->F) && (!closure_no_setter(fnc))) /* maybe closure_setter hasn't been set yet: see fset3 in s7test.scm */ - setter = setter_p_pp(sc, fnc, sc->curlet); - if (is_t_procedure(setter)) - { - /* (set! (o g) ...), here fnc = o, sc->code = ((o g) ...) */ - push_op_stack(sc, setter); - if (is_null(cdar(sc->code))) - { - push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code)); - sc->code = cadr(sc->code); - } - else - { - if (is_null(cddar(sc->code))) - push_stack(sc, OP_EVAL_ARGS1, sc->nil, cdr(sc->code)); - else - { - sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); - push_stack(sc, OP_EVAL_ARGS4, sc->nil, sc->value); - } - sc->code = cadar(sc->code); - }} - else - { - if (!is_any_macro(setter)) - no_setter_error_nr(sc, fnc); - sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : pair_append(sc, cdar(sc->code), cdr(sc->code)); - sc->code = setter; - return(goto_apply); - } - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer iter) -{ - s7_pointer setter = iterator_sequence(iter); - - if ((is_any_closure(setter)) || (is_any_macro(setter))) - setter = closure_setter(iterator_sequence(iter)); - else no_setter_error_nr(sc, iter); - - if (!is_null(cdar(sc->code))) /* (set! (iter ...) val) but iter is a thunk */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S (an iterator): too many arguments: ~S", 40), iter, sc->code)); - - if (is_procedure(setter)) - { - push_op_stack(sc, setter); - push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil); - sc->code = cadr(sc->code); /* the (as yet unevaluated) value, incoming code was ((obj) val) */ - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - sc->args = cdr(sc->code); - sc->code = setter; - return(goto_apply); -} - -static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer wlet) -{ - if (wlet != global_value(sc->with_let_symbol)) - no_setter_error_nr(sc, wlet); - - /* (set! (with-let a b) x), wlet = with-let, sc->code = ((with-let a b) x) - * a and x are in the current let, b is in a, we need to evaluate a and x, then - * call (with-let a-value (set! b x-value)) - */ - sc->args = cdar(sc->code); - sc->code = cadr(sc->code); - push_stack_direct(sc, OP_SET_WITH_LET_1); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - /* these depend on sc->code making sense given obj as the sequence being set */ - switch (type(obj)) - { - case T_STRING: return(set_implicit_string(sc, obj, inds, val, form)); - case T_PAIR: return(set_implicit_pair(sc, obj, inds, val, form)); - case T_HASH_TABLE: return(set_implicit_hash_table(sc, obj, inds, val, form)); - case T_LET: return(set_implicit_let(sc, obj, inds, val, form)); - case T_C_OBJECT: return(set_implicit_c_object(sc, obj, inds, val, form)); - case T_ITERATOR: return(set_implicit_iterator(sc, obj)); /* not sure this makes sense */ - case T_SYNTAX: return(set_implicit_syntax(sc, obj)); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - return(set_implicit_vector(sc, obj, inds, val, form)); - - case T_C_MACRO: case T_C_FUNCTION_STAR: - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: - return(set_implicit_function(sc, obj)); /* (set! (setter...) ...) also comes here */ - - case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - return(set_implicit_closure(sc, obj)); - - default: /* (set! (1 2) 3) */ - if (is_applicable(obj)) - no_setter_error_nr(sc, obj); /* this is reachable if obj is a goto or continuation: (set! (go 1) 2) in s7test.scm */ - error_nr(sc, sc->no_setter_symbol, - list_3(sc, wrap_string(sc, "in ~S, ~S has no setter", 23), - cons_unchecked(sc, sc->set_symbol, /* copy_tree(sc, form) also works but copies too much: we want to copy the ulists */ - cons(sc, copy_proper_list(sc, cadr(form)), cddr(form))), - obj)); - } - return(goto_top_no_pop); -} - -static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ...) */ -{ - s7_pointer caar_code, obj, form = sc->code; - sc->code = cdr(sc->code); - caar_code = caar(sc->code); - if (is_symbol(caar_code)) - { - obj = lookup_slot_from(caar_code, sc->curlet); - obj = (is_slot(obj)) ? slot_value(obj) : unbound_variable(sc, caar_code); - } - else - if (!is_pair(caar_code)) - obj = caar_code; - else - { - push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); - sc->code = caar_code; - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - /* code here is the setter and the value without the "set!": ((window-width) 800), (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */ - /* for gmp case, indices need to be decoded via s7_integer, not just integer */ - return(call_set_implicit(sc, obj, cdar(sc->code), cdr(sc->code), form)); -} - -static goto_t op_set2(s7_scheme *sc) -{ - if (is_pair(sc->value)) - { - /* (let ((L '((1 2 3)))) (set! ((L 0) 1) 32) L), (let ((L '(((1 2 3))))) (set! ((L 0) 0 1) 32) L) - * any deeper nesting was handled already by the first eval - * set! looks at its first argument, if it's a symbol, it sets the associated value, - * if it's a list, it looks at the car of that list to decide which setter to call, - * if it's a list of lists, it passes the embedded lists to eval, then looks at the - * car of the result. This means that we can do crazy things like: - * (let ((x '(1)) (y '(2))) (set! ((if #t x y) 0) 32) x) - * the other args need to be evaluated (but not the list as if it were code): - * (let ((L '((1 2 3))) (index 1)) (set! ((L 0) index) 32) L) - */ - if (!s7_is_proper_list(sc, sc->args)) /* (set! ('(1 2) 1 . 2) 1) */ - syntax_error_nr(sc, "set! target arguments are an improper list: ~A", 46, sc->args); - if (is_multiple_value(sc->value)) /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ - syntax_error_nr(sc, "set!: too many arguments: ~S", 28, - set_ulist_1(sc, sc->set_symbol, pair_append(sc, multiple_value(sc->value), pair_append(sc, sc->args, sc->code)))); - if (sc->args == sc->nil) - syntax_error_nr(sc, "list set!: not enough arguments: ~S", 35, sc->code); - push_op_stack(sc, sc->list_set_function); - if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), sc->code); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); - sc->code = car(sc->args); - return(goto_eval); - } - if ((is_any_vector(sc->value)) && - (vector_rank(sc->value) == proper_list_length(sc->args))) /* sc->code == new value? */ - { - /* (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1) 0) 32) L) - * bad case when args is nil: (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1)) 32) L) - */ - if (sc->args == sc->nil) - syntax_error_nr(sc, "vector set!: not enough arguments: ~S", 37, sc->code); - push_op_stack(sc, sc->vector_set_function); - if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), sc->code); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); - sc->code = car(sc->args); - return(goto_eval); - } - sc->code = cons_unchecked(sc, sc->set_symbol, cons(sc, set_ulist_1(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */ - /* TODO: make a version of set_implicit that doesn't need all these conses! expand set_implicit and clear out pointless stuff - * we have: obj=sc->value [not pair], inds=sc->args, newval=sc->code, but we need the form for errors, and newval needs to be in a list? - * probably need to break out other cases: let|hash|string|c-obj, but all these pair_appends are also stupid - */ - return(set_implicit(sc)); -} - - -/* -------------------------------- do -------------------------------- */ -static bool safe_stepper_expr(s7_pointer expr, s7_pointer var) -{ - /* for now, just look for stepper as last element of any list - * any embedded set is handled by do_is_safe, so we don't need to descend into the depths - */ - s7_pointer p; - if (cadr(expr) == var) return(false); - for (p = cdr(expr); is_pair(cdr(p)); p = cdr(p)); - if (is_pair(p)) - { - if ((is_optimized(p)) && - (op_has_hop(p)) && - (is_safe_c_op(optimize_op(p)))) - return(true); - if (car(p) == var) return(false); - } - else - if (p == var) return(false); - return(true); -} - -static bool tree_match(s7_pointer tree) -{ - if (is_symbol(tree)) - return(is_matched_symbol(tree)); - return((is_pair(tree)) && - ((tree_match(car(tree))) || (tree_match(cdr(tree))))); -} - -static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, bool *has_set) -{ - /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble - * we can free var_list if return(false) not after (!do_is_safe...), but it seems to make no difference, or be slightly slower - */ - /* sc->code is the complete do form (do ...) */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - { - s7_pointer expr = car(p); - if (is_pair(expr)) - { - s7_pointer x = car(expr); - - if ((!is_symbol(x)) && (!is_safe_c_function(x))) - return(false); - /* car(expr) ("x") is not a symbol: ((mus-data loc) chan) for example, but that's actually safe since it's - * just in effect vector-ref, there are several examples in dlocsig: ((group-speakers group) i) etc - */ - - if (is_symbol_and_syntactic(x)) - { - s7_pointer func = global_value(x), vars, cp; - opcode_t op = syntax_opcode(func); - switch (op) - { - case OP_MACROEXPAND: - return(false); - - case OP_QUOTE: - if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ - return(false); - break; - - case OP_LET: case OP_LET_STAR: - case OP_LETREC: case OP_LETREC_STAR: - if ((!is_pair(cdr(expr))) || - (!is_list(cadr(expr))) || - (!is_pair(cddr(expr)))) - return(false); - cp = var_list; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) return(false); - if ((!is_symbol(var)) || (is_keyword(var))) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - } - sc->x = sc->unused; - if (!do_is_safe(sc, cddr(expr), stepper, cp, has_set)) return(false); - break; - - case OP_DO: - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ - return(false); - cp = var_list; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if ((direct_memq(var, cp)) || (var == stepper)) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - if ((is_pair(cdar(vars))) && - (!do_is_safe(sc, cdar(vars), stepper, cp, has_set))) - { - sc->x = sc->unused; - return(false); - }} - sc->x = sc->unused; - if (!do_is_safe(sc, caddr(expr), stepper, cp, has_set)) return(false); - if ((is_pair(cdddr(expr))) && - (!do_is_safe(sc, cdddr(expr), stepper, cp, has_set))) - return(false); - break; - - case OP_SET: - { - s7_pointer settee; - if (!is_pair(cdr(expr))) /* (set!) */ - return(false); - settee = cadr(expr); - if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ - { - s7_pointer setv; - if ((!is_pair(settee)) || (!is_symbol(car(settee)))) - return(false); - setv = lookup_unexamined(sc, car(settee)); - if (!((setv) && - ((is_sequence(setv)) || - ((is_c_function(setv)) && - (is_safe_procedure(c_function_setter(setv))))))) - return(false); - if (has_set) (*has_set) = true; - } - else - { - if ((is_pair(caddr(sc->code))) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ - (is_pair(caaddr(sc->code)))) - { - bool res; - set_match_symbol(settee); - res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ - clear_match_symbol(settee); - if (res) return(false); - } - if ((has_set) && (!direct_memq(cadr(expr), var_list))) /* is some non-local variable being set? */ - (*has_set) = true; - } - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); - if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ - return(false); - } - break; - - case OP_LET_TEMPORARILY: - if ((!is_pair(cdr(expr))) || - (!is_pair(cadr(expr))) || - (!is_pair(cddr(expr)))) - return(false); - for (cp = cadr(expr); is_pair(cp); cp = cdr(cp)) - if ((!is_pair(car(cp))) || - (!is_pair(cdar(cp))) || - (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) - return(false); - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); - break; - - case OP_COND: - for (cp = cdr(expr); is_pair(cp); cp = cdr(cp)) - if (!do_is_safe(sc, car(cp), stepper, var_list, has_set)) - return(false); - break; - - case OP_CASE: - if ((!is_pair(cdr(expr))) || - (!do_is_safe(sc, cadr(expr), stepper, var_list, has_set))) - return(false); - for (cp = cddr(expr); is_pair(cp); cp = cdr(cp)) - if ((!is_pair(car(cp))) || /* (case x #(123)...) */ - (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) - return(false); - break; - - case OP_IF: case OP_WHEN: case OP_UNLESS: - case OP_AND: case OP_OR: case OP_BEGIN: - case OP_WITH_BAFFLE: - if (!do_is_safe(sc, cdr(expr), stepper, var_list, has_set)) - return(false); - break; - - case OP_WITH_LET: - return(true); /* ?? did I mean false here?? */ - - default: - return(false); - }} /* is_syntax(x=car(expr)) */ - else - { - /* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */ - if ((!is_optimized(expr)) || - (optimize_op(expr) == OP_UNKNOWN_NP) || - (!do_is_safe(sc, cdr(expr), stepper, var_list, has_set))) - return(false); - - if ((is_symbol(x)) && (is_setter(x))) /* "setter" includes stuff like cons and vector -- x is a symbol */ - { - /* (hash-table-set! ht i 0) -- caddr is being saved, so this is not safe - * similarly (vector-set! v 0 i) etc - */ - if (is_null(cdr(expr))) /* (vector) for example */ - return((x == sc->vector_symbol) || (x == sc->list_symbol) || (x == sc->string_symbol)); - - if ((has_set) && - (!direct_memq(cadr(expr), var_list)) && /* non-local is being changed */ - ((cadr(expr) == stepper) || /* stepper is being set? */ - (!is_pair(cddr(expr))) || - (!is_pair(cdddr(expr))) || - (is_pair(cddddr(expr))) || - ((x == sc->hash_table_set_symbol) && (caddr(expr) == stepper)) || - (cadddr(expr) == stepper) || /* used to check is_symbol here and above but that's unnecessary */ - ((is_pair(cadddr(expr))) && (s7_tree_memq(sc, stepper, cadddr(expr)))))) - (*has_set) = true; - - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) - return(false); - if (!safe_stepper_expr(expr, stepper)) - return(false); - }}}} - return(true); -} - -static bool preserves_type(s7_scheme *sc, uint32_t x) -{ - return((x == sc->add_class) || - (x == sc->subtract_class) || - (x == sc->multiply_class)); -} - -static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v) -{ - if ((is_proper_list_3(sc, v)) && - (is_fxable(sc, cadr(v)))) - { - s7_pointer step_expr = caddr(v); - if ((is_optimized(step_expr)) && - (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(v) == cadr(step_expr))) || - ((is_h_safe_c_nc(step_expr)) && /* replace with is_fxable? */ - (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ - (car(v) == cadr(step_expr)) && - ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_x1))) || - ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr))))) - return(step_expr); - } - return(NULL); -} - -static bool is_simple_end(s7_scheme *sc, s7_pointer end) -{ - return((is_optimized(end)) && - (is_safe_c_op(optimize_op(end))) && - (is_pair(cddr(end))) && /* end: (zero? n) */ - (cadr(end) != caddr(end)) && - ((opt1_cfunc(end) == sc->num_eq_xi) || - (optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); -} - -static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code) -{ - s7_pointer vars = car(code); - s7_pointer e = collect_variables(sc, vars, sc->nil); /* only valid in step exprs, not in inits */ - - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_function callee = NULL; - s7_pointer expr = cdar(p); /* init */ - if (is_pair(expr)) - { - callee = fx_choose(sc, expr, sc->nil, do_symbol_is_safe); /* not vars -- they aren't defined yet */ - if (callee) set_fx(expr, callee); - } - expr = cddar(p); /* step */ - if (is_pair(expr)) - { - if ((is_pair(car(expr))) && - (!is_checked(car(expr)))) - optimize_expression(sc, car(expr), 0, e, false); - callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ - if (callee) set_fx(expr, callee); - }} - if ((is_pair(cdr(code))) && - (is_pair(cadr(code)))) - { - s7_pointer result = cdadr(code); - if ((is_pair(result)) && - (is_fxable(sc, car(result)))) - set_fx_direct(result, fx_choose(sc, result, vars, do_symbol_is_safe)); - } - return(code); -} - -static bool do_vector_has_definers(s7_scheme *sc, s7_pointer v) -{ - s7_int len = vector_length(v); - s7_pointer *els = vector_elements(v); - for (s7_int i = 0; i < len; i++) - if ((is_pair(els[i])) && - (is_symbol(car(els[i]))) && - (is_definer(car(els[i])))) /* this is a desperate kludge */ - return(true); - return(false); -} - -static /* inline */ bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) -{ - /* we can't be very fancy here because quote gloms up everything: (cond '(define x 0) ...) etc, and the tree here can - * be arbitrarily messed up, and we need to be reasonably fast. So we accept some false positives: (case ((define)...)...) or '(define...) - * but what about ((f...)...) where (f...) returns a macro that defines something? Or (for-each or ...) where for-each and or might be - * obfuscated and the args might contain a definer? - */ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - { - s7_pointer pp = car(p); - if (is_symbol(pp)) - { - if (is_definer(pp)) - { - if (pp == sc->varlet_symbol) /* tlet case (varlet e1 ...) */ - { - if ((is_pair(cdr(p))) && (is_symbol(cadr(p))) && (!symbol_is_in_list(sc, cadr(p)))) - return(true); - } - else - if (pp == sc->apply_symbol) - { - s7_pointer val; - if ((!is_pair(cdr(p))) || (!is_symbol(cadr(p)))) return(true); - val = lookup_unexamined(sc, cadr(p)); - if ((!val) || (!is_c_function(val))) return(true); - } - else return(true); - }} - else - if (is_pair(pp)) - { - if (do_tree_has_definers(sc, pp)) - return(true); - } - else - if ((is_applicable(pp)) && - (((is_normal_vector(pp)) && (do_vector_has_definers(sc, pp))) || - ((is_c_function(pp)) && (is_func_definer(pp))) || - ((is_syntax(pp)) && (is_syntax_definer(pp))))) - return(true); - } - return(false); -} - -static void check_do_for_obvious_errors(s7_scheme *sc, s7_pointer form) -{ - s7_pointer x, code = cdr(form); - - if ((!is_pair(code)) || /* (do . 1) */ - ((!is_pair(car(code))) && /* (do 123) */ - (is_not_null(car(code))))) /* (do () ...) is ok */ - syntax_error_nr(sc, "do: variable list is not a list: ~S", 35, form); - - if (!is_pair(cdr(code))) /* (do () . 1) */ - syntax_error_nr(sc, "do body is messed up: ~A", 24, form); - - if ((!is_pair(cadr(code))) && /* (do ((i 0)) 123) */ - (is_not_null(cadr(code)))) /* no end-test? */ - syntax_error_nr(sc, "do: end-test and end-value list is not a list: ~A", 49, form); - - if (is_pair(car(code))) - { - clear_symbol_list(sc); - for (x = car(code); is_pair(x); x = cdr(x)) - { - s7_pointer y = car(x); - if (!(is_pair(y))) /* (do (4) (= 3)) */ - syntax_error_nr(sc, "do: variable name missing? ~A", 29, form); - - if (!is_symbol(car(y))) /* (do ((3 2)) ()) */ - syntax_error_nr(sc, "do step variable: ~S is not a symbol?", 37, y); - - if (is_constant_symbol(sc, car(y))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ - syntax_error_nr(sc, "do step variable: ~S is immutable", 33, y); - - if (!is_pair(cdr(y))) - syntax_error_nr(sc, "do: step variable has no initial value: ~A", 42, x); - if (!is_pair(cddr(y))) - { - if (is_not_null(cddr(y))) /* (do ((i 0 . 1)) ...) */ - syntax_error_nr(sc, "do: step variable info is an improper list?: ~A", 47, x); - } - else - if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ - syntax_error_nr(sc, "do: step variable info has extra stuff after the increment: ~A", 62, x); - set_local(car(y)); - - if (symbol_is_in_list(sc, car(y))) /* (do ((i 0 (+ i 1)) (i 2))...) */ - syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, x); - add_symbol_to_list(sc, car(y)); - } - if (is_not_null(x)) /* (do ((i 0 i) . 1) ((= i 1))) */ - syntax_error_nr(sc, "do: list of variables is improper: ~A", 37, form); - } - if (is_pair(cadr(code))) - { - for (x = cadr(code); is_pair(x); x = cdr(x)); - if (is_not_null(x)) /* (do ((i 0 (+ i 1))) ((= i 2) . 3) */ - syntax_error_nr(sc, "stray dot in do end section? ~A", 31, form); - } - for (x = cddr(code); is_pair(x); x = cdr(x)); - if (is_not_null(x)) - syntax_error_nr(sc, "stray dot in do body? ~A", 24, form); -} - -static s7_pointer do_end_bad(s7_scheme *sc, s7_pointer form) -{ - s7_pointer code = cdr(form); - if (is_null(cddr(code))) - { - s7_pointer p; - /* no body, end not fxable (if eval car(end) might be unopt) */ - for (p = car(code); is_pair(p); p = cdr(p)) /* gather var names */ - { - s7_pointer var = car(p); - if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ - set_match_symbol(car(var)); - } - for (p = car(code); is_pair(p); p = cdr(p)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */ - { - s7_pointer var = car(p); - s7_pointer val = cddr(var); - if (is_pair(val)) - { - clear_match_symbol(car(var)); /* ignore current var */ - if (tree_match(car(val))) - { - for (s7_pointer q = car(code); is_pair(q); q = cdr(q)) - clear_match_symbol(caar(q)); - return(code); - }} - set_match_symbol(car(var)); - } - for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */ - clear_match_symbol(caar(p)); - - if (is_null(p)) - { - if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */ - (is_null(cddr(code)))) - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: infinite do loop: %s\n", __func__, display(form)); - return(code); - } - fxify_step_exprs(sc, code); - for (p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!has_fx(cdr(var))) || - ((is_pair(cddr(var))) && (!has_fx(cddr(var))))) - return(code); - } - pair_set_syntax_op(form, OP_DO_NO_BODY_NA_VARS); - return(sc->nil); - }} - return(fxify_step_exprs(sc, code)); -} - -static s7_pointer check_do(s7_scheme *sc) -{ - /* returns nil if optimizable */ - s7_pointer form = sc->code, code, vars, end, body, p; - - check_do_for_obvious_errors(sc, form); - pair_set_syntax_op(form, OP_DO_UNCHECKED); - code = cdr(form); - end = cadr(code); - - if ((!is_pair(end)) || (!is_fxable(sc, car(end)))) - return(do_end_bad(sc, form)); - - /* sc->curlet is the outer environment, local vars are in the symbol_list via check_do_for_obvious_error, and it's only needed for fx_unsafe_s */ - set_fx_direct(end, fx_choose(sc, end, sc->curlet, let_symbol_is_safe_or_listed)); - if ((is_pair(cdr(end))) && - (is_fxable(sc, cadr(end)))) - set_fx_direct(cdr(end), fx_choose(sc, cdr(end), sc->curlet, let_symbol_is_safe_or_listed)); - - vars = car(code); - if (is_null(vars)) - { - pair_set_syntax_op(form, OP_DO_NO_VARS); - if (is_fx_treeable(end)) - { - if ((is_pair(car(end))) && /* this code is repeated below */ - (has_fx(end)) && - (!(is_syntax(caar(end)))) && - (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) - { - s7_pointer v1 = NULL, v2 = NULL, v3 = NULL; - bool more_vs = false; - if (tis_slot(let_slots(sc->curlet))) /* outer vars */ - { - p = let_slots(sc->curlet); - v1 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - v2 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - v3 = slot_symbol(p); - more_vs = tis_slot(next_slot(p)); - }}} - if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); - }} - return(sc->nil); - } - if (do_tree_has_definers(sc, form)) /* we don't want definers in body, vars, or end test */ - return(fxify_step_exprs(sc, code)); - - body = cddr(code); - if ((is_pair(end)) && (is_pair(car(end))) && /* end test is a pair */ - (is_pair(vars)) && (is_null(cdr(vars))) && /* one stepper */ - (is_pair(body)) && (is_pair(car(body))) && /* body is normal-looking */ - ((is_symbol(caar(body))) || (is_safe_c_function(caar(body))))) - { - /* loop has one step variable, and normal-looking end test */ - s7_pointer v = car(vars), step_expr; - - fx_tree(sc, end, car(v), NULL, NULL, false); - if (is_fx_treeable(body)) /* this is thwarted by gotos */ - fx_tree(sc, body, car(v), NULL, NULL, false); - - step_expr = simple_stepper(sc, v); - if (step_expr) - { - s7_pointer orig_end = end; - set_fx(cdr(v), fx_choose(sc, cdr(v), vars, do_symbol_is_safe)); /* v is (i 0 (+ i 1)) or the like */ - - /* step var is (var const|symbol (op var const)|(op const var)) */ - end = car(end); - if ((is_simple_end(sc, end)) && - (car(v) == cadr(end))) - { - /* end var is (op var const|symbol) using same var as step so at least we can use SIMPLE_DO */ - bool has_set = false; - bool one_line = ((is_null(cdr(body))) && (is_pair(car(body)))); - if ((car(end) == sc->num_eq_symbol) && (is_symbol(cadr(end))) && (is_t_integer(caddr(end)))) - { - set_c_function(end, sc->num_eq_2); - set_opt2_con(cdr(end), caddr(end)); - set_fx_direct(orig_end, (integer(caddr(end)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - } - set_opt1_any(code, caddr(end)); /* symbol or int(?) */ - set_opt2_pair(code, step_expr); /* caddr(caar(code)) */ - pair_set_syntax_op(form, OP_SIMPLE_DO); /* simple_do: 1 var easy step/end */ - - if ((c_function_class(opt1_cfunc(step_expr)) == sc->add_class) && /* we check above that (car(v) == cadr(step_expr)) and (car(v) == cadr(end)) */ - ((c_function_class(opt1_cfunc(end)) == sc->num_eq_class) || - (opt1_cfunc(end) == sc->geq_2))) - { - if ((one_line) && - ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_NC)) && /* this does happen: (if (= i 3) (vector-set! j 0 i)) */ - (is_symbol_and_syntactic(caar(body))) && - (s7_is_integer(caddr(step_expr))) && /* this currently blocks s7_optimize of float steppers */ - (s7_integer_clamped_if_gmp(sc, caddr(step_expr)) == 1)) - { - pair_set_syntax_op(car(body), symbol_syntax_op_checked(car(body))); - pair_set_syntax_op(form, OP_DOTIMES_P); /* dotimes_p: simple + syntax body + 1 expr */ - } - - if (((caddr(step_expr) == int_one) || (cadr(step_expr) == int_one)) && - (do_is_safe(sc, body, car(v), sc->nil, &has_set))) - { - pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ - /* no semipermanent let here because apparently do_is_safe accepts recursive calls? */ - if ((!has_set) && - (c_function_class(opt1_cfunc(end)) == sc->num_eq_class)) - { - pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ - if (is_fxable(sc, car(body))) - fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); - } - fx_tree(sc, body, car(v), NULL, NULL, false); - /* an experiment (this never works...) */ - if (stack_op(sc->stack, current_stack_top(sc) - 1) == OP_SAFE_DO_STEP) - fx_tree_outer(sc, body, caaar(stack_code(sc->stack, (current_stack_top(sc) - 1))), NULL, NULL, true); - }} - return(sc->nil); - }}} - - /* we get here if there is more than one local var or anything "non-simple" about the rest */ - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_fxable(sc, cadr(var))) || - ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) || - ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))) - { - for (s7_pointer q = vars; q != p; q = cdr(q)) - clear_match_symbol(caar(q)); - return(fxify_step_exprs(sc, code)); - } - if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ - set_match_symbol(car(var)); - } - - { - s7_pointer stepper0 = NULL, stepper1 = NULL, stepper2 = NULL, stepper3 = NULL; - bool got_pending = false, outer_shadowed = false; - - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - s7_pointer val = cddr(var); - stepper3 = stepper2; - stepper2 = stepper1; - stepper1 = stepper0; - stepper0 = car(var); - if (is_pair(val)) - { - var = car(var); - clear_match_symbol(var); /* ignore current var */ - if (tree_match(car(val))) - { - for (s7_pointer q = vars; is_pair(q); q = cdr(q)) - clear_match_symbol(caar(q)); - if (is_null(body)) - got_pending = true; - else return(fxify_step_exprs(sc, code)); - } - set_match_symbol(var); - }} - - for (p = vars; is_pair(p); p = cdr(p)) - set_match_symbol(caar(p)); - for (p = let_slots(sc->curlet); tis_slot(p); p = next_slot(p)) - if (is_matched_symbol(slot_symbol(p))) - { - outer_shadowed = true; - break; - } - for (p = vars; is_pair(p); p = cdr(p)) - clear_match_symbol(caar(p)); - - /* end and steps look ok! */ - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); /* init val */ - if (is_pair(cddr(var))) - { - s7_pointer step_expr = caddr(var); - set_fx_direct(cddr(var), fx_choose(sc, cddr(var), vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */ - if (!is_pair(step_expr)) /* (i 0 0) */ - { - if (cadr(var) == caddr(var)) /* not types match: (i x y) etc */ - set_safe_stepper_expr(cddr(var)); - } - else - { - s7_pointer endp = car(end); - s7_pointer var1 = car(var); - if ((car(step_expr) != sc->quote_symbol) && /* opt1_cfunc(==opt1) might not be set in this case (sigh) */ - (is_safe_c_op(optimize_op(step_expr))) && - ((preserves_type(sc, c_function_class(opt1_cfunc(step_expr)))) || /* add etc */ - (car(step_expr) == sc->cdr_symbol) || - (car(step_expr) == sc->cddr_symbol) || - ((is_pair(cadr(var))) && - (is_pair(c_function_signature(c_function_base(opt1_cfunc(step_expr))))) && - (car(c_function_signature(c_function_base(opt1_cfunc(step_expr)))) != sc->T) && - (caadr(var) == car(step_expr))))) /* i.e. accept char-position as init/step, but not iterate */ - set_safe_stepper_expr(cddr(var)); - - if ((is_proper_list_3(sc, endp)) && (is_proper_list_3(sc, step_expr)) && - ((car(endp) == sc->num_eq_symbol) || (car(endp) == sc->geq_symbol)) && - (is_symbol(cadr(endp))) && - ((is_t_integer(caddr(endp))) || (is_symbol(caddr(endp)))) && - (car(step_expr) == sc->add_symbol) && - (var1 == cadr(endp)) && (var1 == cadr(step_expr)) && - ((car(endp) != sc->num_eq_symbol) || ((caddr(step_expr) == int_one)))) - set_step_end_ok(end); - }}} - pair_set_syntax_op(form, (got_pending) ? OP_DOX_PENDING_NO_BODY : OP_DOX); - /* there are only a couple of cases in snd-test where a multi-statement do body is completely fx-able */ - - if ((is_null(body)) && - (is_null(cdr(vars))) && - (is_pair(cdr(end))) && - (is_null(cddr(end))) && - (has_fx(cdr(end))) && - (is_pair(cdar(vars))) && - (is_pair(cddar(vars)))) - { - s7_pointer var = caar(vars); - s7_pointer step = cddar(vars); - set_opt3_any(code, (in_heap(code)) ? sc->F : make_semipermanent_let(sc, vars)); - if (!got_pending) - pair_set_syntax_op(form, OP_DOX_NO_BODY); - if (is_safe_stepper_expr(step)) - { - step = car(step); - if ((is_pair(step)) && (is_proper_list_3(sc, step))) - { - if ((car(step) == sc->add_symbol) && - (((cadr(step) == var) && (caddr(step) == int_one)) || - (caddr(step) == var)) && (cadr(step) == int_one)) - set_opt2_con(code, int_one); - else - if ((car(step) == sc->subtract_symbol) && - (cadr(step) == var) && - (caddr(step) == int_one)) - set_opt2_con(code, minus_one); - else set_opt2_con(code, int_zero); - } - else set_opt2_con(code, int_zero); - } - else set_opt2_con(code, int_zero); - } - - if (do_passes_safety_check(sc, body, sc->nil, NULL)) - { - s7_pointer var1 = NULL, var2 = NULL, var3 = NULL; - bool more_vars = false; - if (tis_slot(let_slots(sc->curlet))) /* outer vars */ - { - p = let_slots(sc->curlet); - var1 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - var2 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - var3 = slot_symbol(p); - more_vars = tis_slot(next_slot(p)); - }}} - - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if (is_pair(cdr(var))) - { - if (var1) fx_tree_in(sc, cdr(var), var1, var2, var3, more_vars); /* init vals, more_vars refers to outer let, stepper3 == local let more_vars */ - if (is_pair(cddr(var))) - { - if (stepper0) fx_tree(sc, cddr(var), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cddr(var), var1, var2, var3, more_vars); - }}} - - if ((is_pair(cdr(end))) && - (is_null(cddr(end))) && - (has_fx(cdr(end)))) - { - if (!fx_tree_in(sc, cdr(end), stepper0, stepper1, stepper2, stepper3)) - fx_tree(sc, cadr(end), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cdr(end), var1, var2, var3, more_vars); - } - - if ((is_pair(car(end))) && - (has_fx(end)) && - (!(is_syntax(caar(end)))) && - (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) - { - if (!fx_tree_in(sc, end, stepper0, stepper1, stepper2, stepper3)) /* just the end-test, not the results */ - fx_tree(sc, car(end), stepper0, stepper1, stepper2, stepper3); /* car(end) might be (or ...) */ - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, end, var1, var2, var3, more_vars); - } - - if ((is_pair(body)) && (is_null(cdr(body))) && - (is_fxable(sc, car(body)))) - { - fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); - if (stepper0) fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, body, var1, var2, var3, more_vars); - }}} - return(sc->nil); -} - -static bool has_safe_steppers(s7_scheme *sc, s7_pointer let) -{ - for (s7_pointer slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) - { - s7_pointer val = slot_value(slot); - if (slot_has_expression(slot)) - { - s7_pointer step_expr = T_Pair(slot_expression(slot)); - if (is_safe_stepper_expr(step_expr)) - { - if (is_t_integer(val)) - { - if (is_int_optable(step_expr)) - set_safe_stepper(slot); - else - if (no_int_opt(step_expr)) - clear_safe_stepper(slot); - else - { - sc->pc = 0; - if (int_optimize(sc, step_expr)) - { - set_safe_stepper(slot); - set_is_int_optable(step_expr); - } - else - { - clear_safe_stepper(slot); - set_no_int_opt(step_expr); - }}} - else - if (is_small_real(val)) - { - if (is_float_optable(step_expr)) - set_safe_stepper(slot); - else - if (no_float_opt(step_expr)) - clear_safe_stepper(slot); - else - { - sc->pc = 0; - if (float_optimize(sc, step_expr)) - { - set_safe_stepper(slot); - set_is_float_optable(step_expr); - } - else - { - clear_safe_stepper(slot); - set_no_float_opt(step_expr); - }}} - else set_safe_stepper(slot); /* ?? shouldn't this check types ?? */ - }} - else - { - if (is_t_real(val)) - slot_set_value(slot, s7_make_mutable_real(sc, real(val))); - if (is_t_integer(val)) - slot_set_value(slot, make_mutable_integer(sc, integer(val))); - set_safe_stepper(slot); - } - if (!is_safe_stepper(slot)) - return(false); - } - return(true); -} - -static bool copy_if_end_ok(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int i, s7_pointer endp, s7_pointer stepper) -{ - if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp))) && (is_symbol(caddr(endp)))) - { - s7_pointer end_slot = lookup_slot_from((cadr(endp) == slot_symbol(stepper)) ? caddr(endp) : cadr(endp), sc->curlet); - if ((is_slot(end_slot)) && (is_t_integer(slot_value(end_slot)))) - { - copy_to_same_type(sc, dest, source, i, integer(slot_value(end_slot)), i); - return(true); - }} - return(false); -} - -static bool op_dox_init(s7_scheme *sc) -{ - s7_pointer test, code = cdr(sc->code); - s7_pointer let = inline_make_let(sc, sc->curlet); - sc->temp1 = let; - - for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) - { - add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); - if (is_pair(cddar(vars))) - slot_set_expression(let_slots(let), cddar(vars)); - else slot_just_set_expression(let_slots(let), sc->nil); - } - set_curlet(sc, let); - sc->temp1 = sc->unused; - test = cadr(code); - if (is_true(sc, sc->value = fx_call(sc, test))) - { - sc->code = cdr(test); - return(true); /* goto DO_END_CLAUSES */ - } - sc->code = T_Pair(cddr(code)); - push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_O : OP_DOX_STEP), code); - return(false); /* goto BEGIN */ -} - -static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, int32_t steppers, s7_pointer stepper) -{ - s7_function endf = fx_proc(end); - s7_pointer endp = car(end); - if (endf == fx_c_nc) - { - endf = fn_proc(endp); - endp = cdr(endp); - } - if (steppers == 1) - { - s7_function f = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ - s7_pointer a = car(slot_expression(stepper)); - if (f == fx_c_nc) - { - f = fn_proc(a); - a = cdr(a); - } - if (((f == fx_cdr_s) || (f == fx_cdr_t)) && - (cadr(a) == slot_symbol(stepper))) - { - do {slot_set_value(stepper, cdr(slot_value(stepper)));} while (endf(sc, endp) == sc->F); - sc->value = sc->T; - } - else /* (- n 1) tpeak dup */ - if (((f == fx_add_t1) || (f == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) - { - s7_pointer p = make_mutable_integer(sc, integer(slot_value(stepper))); - slot_set_value(stepper, p); - if (!no_bool_opt(end)) - { - sc->pc = 0; - if (bool_optimize(sc, end)) /* in dup.scm this costs more than the fb(o) below saves (search is short) */ - { /* but tc is much slower (and bool|int_optimize dominates) */ - opt_info *o = sc->opts[0]; - bool (*fb)(opt_info *o) = o->v[0].fb; - do {integer(p)++;} while (!fb(o)); /* do {integer(p)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ - clear_mutable_integer(p); - sc->value = sc->T; - sc->code = cdr(end); - return(goto_do_end_clauses); - } - set_no_bool_opt(end); - } - do {integer(p)++;} while ((sc->value = endf(sc, endp)) == sc->F); - clear_mutable_integer(p); - } - else do {slot_set_value(stepper, f(sc, a));} while ((sc->value = endf(sc, endp)) == sc->F); - - sc->code = cdr(end); - return(goto_do_end_clauses); - } - if ((steppers == 2) && - (!tis_slot(next_slot(next_slot(slots))))) - { - s7_pointer step1 = slots; - s7_pointer expr1 = slot_expression(step1); - s7_pointer step2 = next_slot(step1); - s7_pointer expr2 = slot_expression(step2); /* presetting fx_proc/car(expr) is not faster */ - if ((fx_proc(expr2) == fx_subtract_u1) && - (is_t_integer(slot_value(step2))) && - (endf == fx_num_eq_ui)) - { - s7_int lim = integer(caddr(endp)); - for (s7_int i = integer(slot_value(step2)) - 1; i >= lim; i--) - slot_set_value(step1, fx_call(sc, expr1)); - } - else - do { - slot_set_value(step1, fx_call(sc, expr1)); - slot_set_value(step2, fx_call(sc, expr2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - if (!is_symbol(car(sc->code))) - return(goto_do_end_clauses); - step1 = lookup_slot_from(car(sc->code), sc->curlet); - sc->value = slot_value(step1); - if (is_t_real(sc->value)) - clear_mutable_number(sc->value); - return(goto_start); - } - do { - s7_pointer slt = slots; - do { - if (slot_has_expression(slt)) - slot_set_value(slt, fx_call(sc, slot_expression(slt))); - slt = next_slot(slt); - } while (tis_slot(slt)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); -} - -static goto_t op_dox(s7_scheme *sc) -{ - /* any number of steppers using dox exprs, end also dox, body and end result arbitrary. - * since all these exprs are local, we don't need to jump until the body - */ - int64_t id, steppers = 0; - s7_pointer code, end, endp, stepper = NULL, form = sc->code, slots; - s7_function endf; -#if WITH_GMP - bool got_bignum = false; -#endif - s7_pointer let = inline_make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */ - sc->temp1 = let; - sc->code = cdr(sc->code); - for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) - { - s7_pointer expr = cdar(vars), slot; - s7_pointer val = fx_call(sc, expr); - s7_pointer stp = cdr(expr); /* cddar(vars) */ -#if WITH_GMP - if (!got_bignum) got_bignum = is_big_number(val); -#endif - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, caar(vars), val); - if (is_pair(stp)) - { - steppers++; - stepper = slot; - slot_set_expression(slot, stp); - } - else slot_just_set_expression(slot, sc->nil); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - } - set_curlet(sc, let); - slots = let_slots(sc->curlet); - sc->temp1 = sc->unused; - id = let_id(let); - - /* the fn_calls above could have redefined a previous stepper, so that its symbol_id is > let let_id when we get here, - * so we use symbol_set_local_slot_unchecked below to sidestep the debugger (see zauto.scm: i is a stepper, but then mock-vector-ref uses i as its index) - */ - for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot)) - symbol_set_local_slot_unchecked_and_unincremented(slot_symbol(slot), id, slot); - - end = cadr(sc->code); - endp = car(end); - endf = fx_proc(end); - - /* an experiment */ - if ((step_end_ok(end)) && (steppers == 1) && - (is_t_integer(slot_value(stepper)))) - { - s7_pointer stop_slot = (is_symbol(caddr(endp))) ? opt_integer_symbol(sc, caddr(endp)) : sc->nil; - if (stop_slot) /* sc->nil -> it's an integer */ - { - set_step_end(stepper); - set_do_loop_end(slot_value(stepper), (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(endp))); - }} - - if (is_true(sc, sc->value = endf(sc, endp))) - { - sc->code = cdr(end); - return(goto_do_end_clauses); - } - code = cddr(sc->code); - if (is_null(code)) /* no body -- how does this happen? */ - return(op_dox_no_body_1(sc, slots, end, steppers, stepper)); - - if ((is_null(cdr(code))) && /* 1 expr, code is cdddr(form) here */ - (is_pair(car(code)))) - { - s7_pointer body = car(code); - s7_pfunc bodyf = NULL; - if ((!no_cell_opt(code)) && -#if WITH_GMP - (!got_bignum) && -#endif - (has_safe_steppers(sc, sc->curlet))) - bodyf = s7_optimize_nv(sc, code); - - if ((!bodyf) && - (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */ - (is_c_function(car(body)))) - bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_name_to_symbol(sc, car(body)), cdr(body)))); - - if (bodyf) - { - if (steppers == 1) /* one expr body, 1 stepper */ - { - s7_pointer stepa = car(slot_expression(stepper)); - s7_function stepf = fx_proc(slot_expression(stepper)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) - { - s7_int i = integer(slot_value(stepper)); - opt_info *o = sc->opts[0]; - if (bodyf == opt_cell_any_nv) - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* a laborious experiment... */ - if (!((fp == opt_p_pip_sso) && (o->v[2].p == o->v[4].p) && - (((o->v[5].p_pip_f == string_set_p_pip_unchecked) && (o->v[6].p_pi_f == string_ref_p_pi_unchecked)) || - ((o->v[5].p_pip_f == string_set_p_pip_direct) && (o->v[6].p_pi_f == string_ref_p_pi_direct)) || - ((o->v[5].p_pip_f == vector_set_p_pip_unchecked) && (o->v[6].p_pi_f == normal_vector_ref_p_pi_unchecked)) || - ((o->v[5].p_pip_f == normal_vector_set_p_pip_direct) && (o->v[6].p_pi_f == normal_vector_ref_p_pi_direct)) || - ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[3].p), i, endp, stepper)))) - { - if (is_step_end(stepper)) - { - s7_int lim = do_loop_end(slot_value(stepper)); - if ((i >= 0) && (lim < NUM_SMALL_INTS)) - do {fp(o); slot_set_value(stepper, small_int(++i));} while (i < lim); - else do {fp(o); slot_set_value(stepper, make_integer(sc, ++i));} while (i < lim); - sc->value = sc->T; - } - else - do { - fp(o); - slot_set_value(stepper, make_integer(sc, ++i)); - } while ((sc->value = endf(sc, endp)) == sc->F); - }} - else - if (!(((bodyf == opt_float_any_nv) && (o->v[0].fd == opt_d_7pid_ss_ss) && - (o->v[2].p == o->v[6].p) && - ((o->v[4].d_7pid_f == float_vector_set_d_7pid) || (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) && - (o->v[3].d_7pi_f == float_vector_ref_d_7pi) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), i, endp, stepper))) || - - ((bodyf == opt_int_any_nv) && ((o->v[0].fi == opt_i_7pii_ssf) || (o->v[0].fi == opt_i_7pii_ssf_vset)) && - (o->v[2].p == o->v[4].o1->v[2].p) && - (((o->v[3].i_7pii_f == int_vector_set_i_7pii) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_7pi)) || - ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_7pi_direct))) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), i, endp, stepper))))) - /* here the is_step_end business doesn't happen much */ - do { - bodyf(sc); - slot_set_value(stepper, make_integer(sc, ++i)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - do { - bodyf(sc); - slot_set_value(stepper, stepf(sc, stepa)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - if ((steppers == 2) && - (!tis_slot(next_slot(next_slot(slots))))) - { - s7_pointer s1 = slots, s2 = next_slot(slots); - s7_function f1 = fx_proc(slot_expression(s1)); - s7_function f2 = fx_proc(slot_expression(s2)); - s7_pointer p1 = car(slot_expression(s1)); - s7_pointer p2 = car(slot_expression(s2)); - /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv */ - if (bodyf == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* maybe this can be generalized (thash:79) -- explicit integer stepper, but there must be a simpler way */ - if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) && (endf == fx_num_eq_ui) && - (is_symbol(cadr(endp))) && (cadr(endp) == slot_symbol(s2)) && - (is_t_integer(caddr(endp))) && (!s7_tree_memq(sc, cadr(endp), body))) - { - s7_int i = integer(slot_value(s2)), endi = integer(caddr(endp)); - do { - fp(o); - slot_set_value(s1, f1(sc, p1)); - i++; - } while (i < endi); - } - else - do { - fp(o); - slot_set_value(s1, f1(sc, p1)); - slot_set_value(s2, f2(sc, p2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - } - else - do { - bodyf(sc); - slot_set_value(s1, f1(sc, p1)); - slot_set_value(s2, f2(sc, p2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - if (bodyf == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - do { - s7_pointer slot1 = slots; - fp(o); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - } - else - do { - s7_pointer slot1 = slots; - bodyf(sc); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - if ((steppers == 1) && - (car(body) == sc->set_symbol) && - (is_pair(cdr(body))) && - (is_symbol(cadr(body))) && - (is_pair(cddr(body))) && - ((has_fx(cddr(body))) || (is_fxable(sc, caddr(body)))) && - (is_null(cdddr(body)))) - { - s7_pointer val = cddr(body), stepa; - s7_function stepf, valf; - s7_pointer slot = lookup_slot_from(cadr(body), sc->curlet); - if (!has_fx(val)) - set_fx(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); - valf = fx_proc(val); - val = car(val); - if (slot == sc->undefined) - unbound_variable_error_nr(sc, cadr(body)); - stepf = fx_proc(slot_expression(stepper)); - stepa = car(slot_expression(stepper)); - do { - slot_set_value(slot, valf(sc, val)); - slot_set_value(stepper, stepf(sc, stepa)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - /* not fxable body (bodyf nil) but body might be gxable here: is_gxable(body) */ - if ((has_gx(body)) || (gx_annotate_arg(sc, code, sc->curlet))) - { - s7_function f = fx_proc_unchecked(code); - do { - s7_pointer slot1 = slots; - f(sc, body); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - }} - else /* more than one expr */ - { - s7_pointer p = code; - bool use_opts = false; - int32_t body_len = 0; - opt_info *body[32]; - #define MAX_OPT_BODY_SIZE 32 - - if ((!no_cell_opt(code)) && -#if WITH_GMP - (!got_bignum) && -#endif - (has_safe_steppers(sc, sc->curlet))) - { - sc->pc = 0; - for (int32_t k = 0; (is_pair(p)) && (k < MAX_OPT_BODY_SIZE); k++, p = cdr(p), body_len++) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - { - set_no_cell_opt(code); - p = code; - break; - } - oo_idp_nr_fixup(start); - body[k] = start; - } - use_opts = is_null(p); - } - - if (p == code) - for (; is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - - if (is_null(p)) - { - s7_pointer stepa = NULL; - s7_function stepf = NULL; - if (!use_opts) - fx_annotate_args(sc, code, sc->curlet); - - if (stepper) - { - stepf = fx_proc(slot_expression(stepper)); - stepa = car(slot_expression(stepper)); - } - while (true) - { - if (use_opts) - for (int32_t i = 0; i < body_len; i++) - body[i]->v[0].fp(body[i]); - else - for (p = code; is_pair(p); p = cdr(p)) - fx_call(sc, p); - - if (steppers == 1) - slot_set_value(stepper, stepf(sc, stepa)); - else - { - s7_pointer slot = slots; - do { - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - slot = next_slot(slot); - } while (tis_slot(slot)); - } - if (is_true(sc, sc->value = endf(sc, endp))) - { - sc->code = cdr(end); - return(goto_do_end_clauses); - }}}} - if ((is_null(cdr(code))) && /* one expr */ - (is_pair(car(code)))) - { - code = car(code); - if ((is_syntactic_pair(code)) || - (is_symbol_and_syntactic(car(code)))) - { - push_stack_no_args_direct(sc, OP_DOX_STEP_O); - if (is_syntactic_pair(code)) - sc->cur_op = (opcode_t)optimize_op(code); - else - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(code, sc->cur_op); - } - sc->code = code; - return(goto_top_no_pop); - }} - pair_set_syntax_op(form, OP_DOX_INIT); - sc->code = T_Pair(cddr(sc->code)); - push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_O : OP_DOX_STEP), cdr(form)); - return(goto_begin); -} - -static inline bool op_dox_step_1(s7_scheme *sc) -{ - s7_pointer slot = let_slots(sc->curlet); - do { /* every dox case has vars (else op_do_no_vars) */ - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - slot = next_slot(slot); - } while (tis_slot(slot)); - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - return(true); - } - return(false); -} - -static void op_dox_step(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_DOX_STEP); - sc->code = T_Pair(cddr(sc->code)); -} - -static void op_dox_step_o(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_DOX_STEP_O); - sc->code = caddr(sc->code); -} - -static void op_dox_no_body(s7_scheme *sc) -{ - s7_pointer slot, var, test, result; - s7_function testf; - - sc->code = cdr(sc->code); - var = caar(sc->code); - testf = fx_proc(cadr(sc->code)); - test = caadr(sc->code); - result = cdadr(sc->code); - - if ((!in_heap(sc->code)) && - (is_let(opt3_any(sc->code)))) /* (*repl* 'keymap) anything -> segfault because opt3_any here is #f. (see line 80517) */ - { - s7_pointer let = update_let_with_slot(sc, opt3_any(sc->code), fx_call(sc, cdr(var))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - } - else sc->curlet = make_let_with_slot(sc, sc->curlet, car(var), fx_call(sc, cdr(var))); - - slot = let_slots(sc->curlet); - if ((is_t_integer(slot_value(slot))) && - ((integer(opt2_con(sc->code))) != 0)) - { - s7_int incr = integer(opt2_con(sc->code)); - s7_pointer istep = make_mutable_integer(sc, integer(slot_value(slot))); - /* this can cause unexpected, but correct behavior: (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f - * because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar. - */ - slot_set_value(slot, istep); - if (testf == fx_or_2a) - { - s7_pointer t1 = cadr(test); - s7_pointer t2 = caddr(test); - s7_function f1 = fx_proc(cdr(test)); - s7_function f2 = fx_proc(cddr(test)); - while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F)) - integer(istep) += incr; - } - else while (testf(sc, test) == sc->F) {integer(istep) += incr;} - if (is_small_int(integer(istep))) - slot_set_value(slot, small_int(integer(istep))); - else clear_mutable_integer(istep); - sc->value = fx_call(sc, result); - } - else - { - s7_function stepf = fx_proc(cddr(var)); - s7_pointer step = caddr(var); - if (testf == fx_or_and_2a) - { - s7_pointer f1_arg = cadr(test), p = opt3_pair(test); /* cdadr(p) */ - s7_function f1 = fx_proc(cdr(test)); - s7_pointer f2_arg = car(p); - s7_pointer f3_arg = cadr(p); - s7_function f2 = fx_proc(p); - s7_function f3 = fx_proc(cdr(p)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) - { - s7_pointer ip = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, ip); - while ((f1(sc, f1_arg) == sc->F) && - ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) - integer(ip)++; - clear_mutable_integer(ip); - } - else - while ((f1(sc, f1_arg) == sc->F) && - ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) - slot_set_value(slot, stepf(sc, step)); - } - else while (testf(sc, test) == sc->F) {slot_set_value(slot, stepf(sc, step));} - sc->value = fx_call(sc, result); - } -} - -static void op_dox_pending_no_body(s7_scheme *sc) -{ - s7_pointer test, slots; - bool all_steps = true; - s7_pointer let = inline_make_let(sc, sc->curlet); - sc->temp1 = let; - sc->code = cdr(sc->code); - for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) - { - add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); - if (is_pair(cddar(vars))) - slot_set_expression(let_slots(let), cddar(vars)); - else - { - all_steps = false; - slot_just_set_expression(let_slots(let), sc->nil); - }} - slots = let_slots(let); - set_curlet(sc, let); - sc->temp1 = sc->unused; - test = cadr(sc->code); - - let_set_has_pending_value(sc->curlet); - if ((all_steps) && - (!tis_slot(next_slot(next_slot(slots)))) && - (is_pair(cdr(test)))) - { - s7_pointer slot1 = slots; - s7_pointer expr1 = slot_expression(slot1); - s7_pointer slot2 = next_slot(slot1); - s7_pointer expr2 = slot_expression(slot2); - while (fx_call(sc, test) == sc->F) - { - slot_simply_set_pending_value(slot1, fx_call(sc, expr1)); /* use pending_value for GC protection */ - slot_set_value(slot2, fx_call(sc, expr2)); - slot_set_value(slot1, slot_pending_value(slot1)); - } - sc->code = cdr(test); - let_clear_has_pending_value(sc->curlet); - return; - } - while ((sc->value = fx_call(sc, test)) == sc->F) - { - s7_pointer slt = slots; - do { - if (slot_has_expression(slt)) - slot_simply_set_pending_value(slt, fx_call(sc, slot_expression(slt))); - slt = next_slot(slt); - } while (tis_slot(slt)); - slt = slots; - do { - if (slot_has_expression(slt)) - slot_set_value(slt, slot_pending_value(slt)); - slt = next_slot(slt); - } while (tis_slot(slt)); - } - sc->code = cdr(test); - let_clear_has_pending_value(sc->curlet); -} - -static bool op_do_no_vars(s7_scheme *sc) -{ - s7_pointer p, form = sc->code; - int32_t i; - opt_info *body[32]; - sc->code = cdr(sc->code); - sc->pc = 0; - - for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32); i++, p = cdr(p)) - { - body[i] = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(p)) - { - s7_pointer end = cadr(sc->code); - sc->curlet = inline_make_let(sc, sc->curlet); - if (i == 1) - { - while ((sc->value = fx_call(sc, end)) == sc->F) body[0]->v[0].fp(body[0]); - sc->code = cdr(end); - return(true); - } - if (i == 0) /* null body! */ - { - s7_function endf = fx_proc(end); - s7_pointer endp = car(end); - while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */ - sc->code = cdr(end); - return(true); - } - while ((sc->value = fx_call(sc, end)) == sc->F) - for (int32_t k = 0; k < i; k++) - body[k]->v[0].fp(body[k]); - sc->code = cdr(end); - return(true); - } - /* back out */ - pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT); - sc->curlet = make_let(sc, sc->curlet); - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - return(true); - } - push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); - sc->code = T_Pair(cddr(sc->code)); - return(false); -} - -static void op_do_no_vars_no_opt(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - sc->curlet = inline_make_let(sc, sc->curlet); -} - -static bool op_do_no_vars_no_opt_1(s7_scheme *sc) -{ - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - return(true); - } - push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); - sc->code = T_Pair(cddr(sc->code)); - return(false); -} - -static void op_do_no_body_na_vars(s7_scheme *sc) /* vars fxable, end-test not */ -{ - s7_pointer stepper = NULL; - s7_int steppers = 0; - s7_pointer let = inline_make_let(sc, sc->curlet); - sc->temp1 = let; - sc->code = cdr(sc->code); - for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) - { - add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); - if (is_pair(cddar(vars))) - { - slot_set_expression(let_slots(let), cddar(vars)); - steppers++; - stepper = let_slots(let); - } - else slot_just_set_expression(let_slots(let), sc->nil); - } - if (steppers == 1) let_set_dox_slot1(let, stepper); - set_curlet(sc, let); - sc->temp1 = sc->unused; - push_stack_no_args_direct(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_NA_VARS_STEP_1 : OP_DO_NO_BODY_NA_VARS_STEP)); - sc->code = caadr(sc->code); -} - -static bool op_do_no_body_na_vars_step(s7_scheme *sc) -{ - if (sc->value != sc->F) - { - sc->code = cdadr(sc->code); - return(true); - } - for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - push_stack_no_args_direct(sc, OP_DO_NO_BODY_NA_VARS_STEP); - sc->code = caadr(sc->code); - return(false); -} - -static bool op_do_no_body_na_vars_step_1(s7_scheme *sc) -{ - if (sc->value != sc->F) - { - sc->code = cdadr(sc->code); - return(true); - } - slot_set_value(let_dox_slot1(sc->curlet), fx_call(sc, slot_expression(let_dox_slot1(sc->curlet)))); - push_stack_no_args_direct(sc, OP_DO_NO_BODY_NA_VARS_STEP_1); - sc->code = caadr(sc->code); - return(false); -} - -static bool do_step1(s7_scheme *sc) -{ - while (true) - { - s7_pointer code; - if (is_null(sc->args)) /* after getting the new values, transfer them into the slot_values */ - { - for (s7_pointer x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ - { - slot_set_value(car(x), slot_pending_value(car(x))); - slot_clear_has_pending_value(car(x)); - } - pop_stack_no_op(sc); - return(true); - } - code = T_Pair(slot_expression(car(sc->args))); /* get the next stepper new value */ - if (has_fx(code)) - { - sc->value = fx_call(sc, code); - slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */ - sc->args = cdr(sc->args); /* go to next step var */ - } - else - { - push_stack_direct(sc, OP_DO_STEP2); - sc->code = car(code); - return(false); - }} -} - -static bool op_do_step2(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) - syntax_error_nr(sc, "do: variable step value can't be ~S", 35, set_ulist_1(sc, sc->values_symbol, sc->value)); - slot_set_pending_value(car(sc->args), sc->value); /* save current value */ - sc->args = cdr(sc->args); /* go to next step var */ - return(do_step1(sc)); -} - -static bool op_do_step(s7_scheme *sc) -{ - /* increment all vars, return to endtest - * these are also updated in parallel at the end, so we gather all the incremented values first - * here we know car(sc->args) is not null, args is the list of steppable vars, - * any unstepped vars in the do var section are not in this list, so - * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) - */ - push_stack_direct(sc, OP_DO_END); - sc->args = car(sc->args); /* the var data lists */ - sc->code = sc->args; /* save the top of the list */ - return(do_step1(sc)); -} - -static goto_t do_end_code(s7_scheme *sc) -{ - if (is_pair(cdr(sc->code))) - { - if (is_undefined_feed_to(sc, car(sc->code))) - return(goto_feed_to); - /* never has_fx(sc->code) here (first of a body) */ - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - sc->code = car(sc->code); - return(goto_eval); - } - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(goto_start); - } - sc->code = T_Pair(car(sc->code)); - return(goto_eval); -} - -static bool do_end_clauses(s7_scheme *sc) -{ - if (!is_null(sc->code)) - return(false); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(true); -} - -static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop) -{ - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; /* o->v[6].p_pi_f is getter, o->v[5].p_pip_f is setter */ - if (start >= stop) return(true); - if ((fp == opt_p_pip_sso) && - (type(slot_value(o->v[1].p)) == type(slot_value(o->v[3].p))) && - (o->v[2].p == o->v[4].p)) - { - s7_pointer caller = NULL; - s7_pointer dest = slot_value(o->v[1].p); - s7_pointer source = slot_value(o->v[3].p); - if ((is_normal_vector(dest)) && - (((o->v[5].p_pip_f == vector_set_p_pip_unchecked) || - (o->v[5].p_pip_f == normal_vector_set_p_pip_direct)) && - ((o->v[6].p_pi_f == normal_vector_ref_p_pi_unchecked) || - (o->v[6].p_pi_f == vector_ref_p_pi_unchecked) || - (o->v[6].p_pi_f == normal_vector_ref_p_pi_direct)))) - caller = sc->vector_set_symbol; - else - if ((is_string(dest)) && - (((o->v[5].p_pip_f == string_set_p_pip_unchecked) || (o->v[5].p_pip_f == string_set_p_pip_direct)) && - ((o->v[6].p_pi_f == string_ref_p_pi_unchecked) || (o->v[6].p_pi_f == string_ref_p_pi_direct)))) - caller = sc->string_set_symbol; - else - if ((is_pair(dest)) && - ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) - caller = sc->list_set_symbol; - else return(false); - if (start < 0) - out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, start), it_is_negative_string); - if ((stop > integer(s7_length(sc, source))) || (stop > integer(s7_length(sc, dest)))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, stop), it_is_too_large_string); - if ((caller) && (copy_to_same_type(sc, dest, source, start, stop, start))) - return(true); - } - return(false); -} - -static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer step_expr, step_var, ctr_slot, end_slot; - s7_function stepf, endf; - s7_pfunc func; - - if (no_cell_opt(cddr(code))) - return(false); - func = s7_optimize_nv(sc, cddr(code)); - if (!func) - { - set_no_cell_opt(cddr(code)); - return(false); - } - /* func must be set */ - step_expr = opt2_pair(code); /* caddr(caar(code)) */ - stepf = fn_proc(step_expr); - endf = fn_proc(caadr(code)); - ctr_slot = let_dox_slot1(sc->curlet); - end_slot = let_dox_slot2(sc->curlet); - step_var = caddr(step_expr); - /* use g* funcs (not fx) because we're passing the actual values, not the expressions */ - - if ((stepf == g_add_x1) && - (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) && - (is_t_integer(slot_value(end_slot)))) - { - s7_int i; - s7_int start = integer(slot_value(ctr_slot)); - s7_int stop = integer(slot_value(end_slot)); - - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) || (fp == opt_p_ppp_sss_hset)) - { - s7_p_ppp_t fpt = o->v[4].p_ppp_f; - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fpt(sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)); - }} - else - if (fp == opt_p_ppp_sfs) - { - s7_p_ppp_t fpt = o->v[3].p_ppp_f; - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)); - }} - else - if ((fp == opt_p_pip_sss_vset) && (start >= 0) && (stop <= vector_length(slot_value(o->v[1].p)))) - { - s7_pointer *vels = vector_elements(slot_value(o->v[1].p)); /* better in callgrind, possibly slightly slower in time */ - check_free_heap_size(sc, stop - start); - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer_unchecked(sc, i)); - vels[integer(slot_value(o->v[2].p))] = slot_value(o->v[3].p); - }} - else - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} - else - /* splitting out opt_float_any_nv here saves almost nothing */ - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - } - if ((stepf == g_subtract_x1) && - (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_less_x0) || (endf == g_less_2) || (endf == g_less_xi)) && - (is_t_integer(slot_value(end_slot)))) - { - s7_int i, start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - if (!opt_do_copy(sc, o, stop, start + 1)) - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }}} - else - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - } - if ((stepf == g_add_2_xi) && - (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) && - (is_t_integer(slot_value(end_slot)))) - { - s7_int i, start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)), incr = integer(caddr(step_expr)); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} - else - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - } - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) && - (endf == g_greater_2) && (is_t_integer(slot_value(end_slot)))) - { - s7_int start = integer(slot_value(ctr_slot)); - s7_int stop = integer(slot_value(end_slot)); - if (fp == opt_cond_1b) - { - s7_pointer (*test_fp)(opt_info *o) = o->v[4].o1->v[O_WRAP].fp; - opt_info *test_o1 = o->v[4].o1; - opt_info *o2 = o->v[6].o1; - for (s7_int i = start; i <= stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - if (test_fp(test_o1) != sc->F) cond_value(o2); - }} - else - for (s7_int i = start; i <= stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} - else - do { - fp(o); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, step_var); - slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, slot_value(end_slot)); - } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); - } - else - do { - func(sc); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, step_var); - slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, slot_value(end_slot)); - } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); - - sc->code = cdadr(code); - return(true); -} - -static bool op_simple_do(s7_scheme *sc) -{ - /* body might not be safe in this case, but the step and end exprs are easy */ - s7_pointer code = cdr(sc->code); - s7_pointer end = opt1_any(code); /* caddr(caadr(code)) */ - s7_pointer body = cddr(code); - - sc->curlet = make_let(sc, sc->curlet); - sc->value = fx_call(sc, cdaar(code)); - let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), sc->value)); - - if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); - else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); - set_car(sc->t2_1, let_dox1_value(sc->curlet)); - set_car(sc->t2_2, let_dox2_value(sc->curlet)); - sc->value = fn_proc(caadr(code))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(code); - return(true); /* goto DO_END_CLAUSES */ - } - if ((is_null(cdr(body))) && /* one expr in body */ - (is_pair(car(body))) && /* and it is a pair */ - (is_symbol(cadr(opt2_pair(code)))) && /* caddr(caar(code)), caar=(i 0 (+ i 1)), caddr=(+ i 1), so this checks that stepf is reasonable? */ - (is_t_integer(caddr(opt2_pair(code)))) && - (op_simple_do_1(sc, cdr(sc->code)))) - return(true); /* goto DO_END_CLAUSES */ - - push_stack_no_args(sc, OP_SIMPLE_DO_STEP, code); - sc->code = body; - return(false); /* goto BEGIN */ -} - -static bool op_simple_do_step(s7_scheme *sc) -{ - s7_pointer ctr = let_dox_slot1(sc->curlet); - s7_pointer end = let_dox_slot2(sc->curlet); - s7_pointer code = sc->code; - s7_pointer step = opt2_pair(code); /* caddr(caar(code)) */ - if (is_symbol(cadr(step))) - { - set_car(sc->t2_1, slot_value(ctr)); - set_car(sc->t2_2, caddr(step)); - } - else /* is_symbol(caddr(step)) I think: (+ 1 x) vs (+ x 1) */ - { - set_car(sc->t2_2, slot_value(ctr)); - set_car(sc->t2_1, cadr(step)); - } - slot_set_value(ctr, fn_proc(step)(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr)); - set_car(sc->t2_2, slot_value(end)); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - } - push_stack_direct(sc, OP_SIMPLE_DO_STEP); - sc->code = T_Pair(cddr(code)); - return(false); -} - -static bool op_safe_do_step(s7_scheme *sc) -{ - s7_int end = integer(let_dox2_value(sc->curlet)); - s7_pointer slot = let_dox_slot1(sc->curlet); - s7_int step = integer(slot_value(slot)) + 1; - slot_set_value(slot, make_integer(sc, step)); - if ((step == end) || - ((step > end) && (opt1_cfunc(caadr(sc->code)) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(sc->code); - return(true); - } - push_stack_direct(sc, OP_SAFE_DO_STEP); - sc->code = T_Pair(opt2_pair(sc->code)); - return(false); -} - -static bool op_safe_dotimes_step(s7_scheme *sc) -{ - s7_pointer arg = slot_value(sc->args); - numerator(arg)++; - if (numerator(arg) == do_loop_end(arg)) - { - sc->value = sc->T; - sc->code = cdadr(sc->code); - return(true); - } - push_stack_direct(sc, OP_SAFE_DOTIMES_STEP); - sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */ - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - return(false); -} - -static bool op_safe_dotimes_step_o(s7_scheme *sc) -{ - s7_pointer arg = slot_value(sc->args); - numerator(arg)++; - if (numerator(arg) == do_loop_end(arg)) - { - sc->value = sc->T; - sc->code = cdadr(sc->code); - return(true); - } - push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O); - sc->code = opt2_pair(sc->code); - return(false); -} - -static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval, mat(10+6), num(7+1) */ -{ - s7_pointer ctr = let_dox_slot1(sc->curlet); - s7_pointer end = let_dox2_value(sc->curlet); - s7_pointer now = slot_value(ctr); - s7_pointer code = sc->code; - s7_pointer end_test = opt2_pair(code); - - if (is_t_integer(now)) - { - slot_set_value(ctr, make_integer(sc, integer(now) + 1)); - now = slot_value(ctr); - if (is_t_integer(end)) - { - if ((integer(now) == integer(end)) || - ((integer(now) > integer(end)) && (opt1_cfunc(end_test) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - }} - else - { - set_car(sc->t2_1, now); - set_car(sc->t2_2, end); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - }}} - else - { - slot_set_value(ctr, g_add_x1(sc, with_list_t1(now))); - /* (define (hi) (let ((x 0.0) (y 1.0)) (do ((i y (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((>= i 7)) (set! x (+ x i)))) x)) */ - set_car(sc->t2_1, slot_value(ctr)); - set_car(sc->t2_2, end); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - }} - push_stack_direct(sc, OP_DOTIMES_STEP_O); - sc->code = caddr(code); - return(false); -} - -static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step) -{ - if (safe_step) /* I think safe_step means the stepper is completely unproblematic */ - set_safe_stepper(sc->args); - else set_safe_stepper(let_dox_slot1(sc->curlet)); - - if (is_null(cdr(code))) - { - s7_pfunc func; - if (no_cell_opt(code)) return(false); - func = s7_optimize_nv(sc, code); - if (!func) - { - set_no_cell_opt(code); - return(false); - } - if (safe_step) - { - s7_int end = do_loop_end(slot_value(sc->args)); - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - if ((func == opt_float_any_nv) || - (func == opt_cell_any_nv)) - { - opt_info *o = sc->opts[0]; - if (func == opt_float_any_nv) - { - s7_double (*fd)(opt_info *o) = o->v[0].fd; - if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ - (is_slot(o->v[1].p)) && - (stepper == slot_value(o->v[1].p))) - { - opt_info *o1 = sc->opts[1]; - s7_int end8 = end - 8; - s7_d_id_t f0 = o->v[3].d_id_f; - fd = o1->v[0].fd; - while (integer(stepper) < end8) - LOOP_8(f0(integer(stepper), fd(o1)); integer(stepper)++); - while (integer(stepper) < end) - { - f0(integer(stepper), fd(o1)); - integer(stepper)++; - }} - else - if ((o->v[0].fd == opt_d_7pid_ss_ss) && (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && - (o->v[3].d_7pi_f == float_vector_ref_d_7pi) && (o->v[2].p == o->v[6].p)) - copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), integer(stepper), end, integer(stepper)); - else - if ((o->v[0].fd == opt_d_7pid_ssc) && - (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && - (stepper == slot_value(o->v[2].p))) - s7_fill(sc, set_elist_4(sc, slot_value(o->v[1].p), make_real(sc, o->v[3].x), stepper, make_integer(sc, end))); - else - { - s7_int end4 = end - 4; - while (integer(stepper) < end4) - LOOP_4(fd(o); integer(stepper)++); - for (; integer(stepper) < end; integer(stepper)++) - fd(o); - }} - else - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((fp == opt_p_pip_ssc) && - (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */ - ((o->v[3].p_pip_f == string_set_p_pip_direct) || - (o->v[3].p_pip_f == normal_vector_set_p_pip_direct) || - (o->v[3].p_pip_f == list_set_p_pip_unchecked))) - s7_fill(sc, set_elist_4(sc, slot_value(o->v[1].p), o->v[4].p, stepper, make_integer(sc, end))); - else - if (fp == opt_if_bp) - { - for (; integer(stepper) < end; integer(stepper)++) - if (o->v[3].fb(o->v[2].o1)) o->v[5].fp(o->v[4].o1); - } - else - if (fp == opt_if_nbp_fs) - { - for (; integer(stepper) < end; integer(stepper)++) - if (!(o->v[2].b_pi_f(sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) o->v[11].fp(o->v[10].o1); - } - else - if (fp == opt_unless_p_1) - { - for (; integer(stepper) < end; integer(stepper)++) - if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1); - } - else for (; integer(stepper) < end; integer(stepper)++) fp(o); - }} - else - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - if ((fi == opt_i_7pii_ssc) && (stepper == slot_value(o->v[2].p)) && (o->v[3].i_7pii_f == int_vector_set_i_7pii_direct)) - s7_fill(sc, set_elist_4(sc, slot_value(o->v[1].p), make_integer(sc, o->v[4].i), stepper, make_integer(sc, end))); - else - if ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[5].fi == opt_7pi_ss_ivref) && (o->v[2].p == o->v[4].o1->v[2].p)) - copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), integer(stepper), end, integer(stepper)); - else - for (; integer(stepper) < end; integer(stepper)++) - fi(o); - } - else /* (((i 0 (+ i 1))) ((= i 1)) (char-alphabetic? (string-ref #u(0 1) 1))) or (logbit? i -1): kinda nutty */ - for (; integer(stepper) < end; integer(stepper)++) - func(sc); - - clear_mutable_integer(stepper); - } - else /* not safe_step */ - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int step = integer(slot_value(step_slot)); - s7_int stop = integer(slot_value(end_slot)); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (!opt_do_copy(sc, o, step, stop)) - { - if ((step >= 0) && (stop < NUM_SMALL_INTS)) - { - if (fp == opt_when_p_2) - { - while (step < stop) - { - slot_set_value(step_slot, small_int(step)); - if (o->v[4].fb(o->v[3].o1)) - { - o->v[6].fp(o->v[5].o1); - o->v[8].fp(o->v[7].o1); - } - step = integer(slot_value(step_slot)) + 1; - }} - else - while (step < stop) - { - slot_set_value(step_slot, small_int(step)); - fp(o); - step = integer(slot_value(step_slot)) + 1; - }} - else - while (step < stop) - { - slot_set_value(step_slot, make_integer(sc, step)); - fp(o); - step = integer(slot_value(step_slot)) + 1; - }}} - else - if ((step >= 0) && (stop < NUM_SMALL_INTS)) - while (step < stop) - { - slot_set_value(step_slot, small_int(step)); - func(sc); - step = integer(slot_value(step_slot)) + 1; - } - else - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - while (step < stop) - { - slot_set_value(step_slot, make_integer(sc, step)); - fi(o); - step = integer(slot_value(step_slot)) + 1; - }} - else - while (step < stop) - { - slot_set_value(step_slot, make_integer(sc, step)); - func(sc); - step = integer(slot_value(step_slot)) + 1; - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - } - { - s7_pointer p; - s7_int body_len = s7_list_length(sc, code); - opt_info *body[32]; - int32_t k; - - sc->pc = 0; - if (body_len >= 32) return(false); - - if (!no_float_opt(code)) - { - for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) - { - body[k] = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - break; - } - if (is_pair(p)) - { - pc_fallback(sc, 0); - set_no_float_opt(code); - } - else - { - s7_int end = do_loop_end(slot_value(sc->args)); - if (safe_step) - { - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - clear_mutable_integer(stepper); - } - else - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int stop = integer(slot_value(end_slot)); - for (s7_int step = integer(slot_value(step_slot)); step < stop; step = integer(slot_value(step_slot)) + 1) - { - slot_set_value(step_slot, make_integer(sc, step)); - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - }} - - /* not float opt */ - sc->pc = 0; - for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - oo_idp_nr_fixup(start); - body[k] = start; - } - if (is_null(p)) - { - s7_int end = do_loop_end(slot_value(sc->args)); - if (safe_step) - { - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - if ((body_len & 0x3) == 0) - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; ) - LOOP_4(body[i]->v[0].fp(body[i]); i++); - else - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); - clear_mutable_integer(stepper); - } - else - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int stop = integer(slot_value(end_slot)); - for (s7_int step = integer(slot_value(step_slot)); step < stop; step = integer(slot_value(step_slot)) + 1) - { - slot_set_value(step_slot, make_integer(sc, step)); - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - }} - return(false); -} - -static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) -{ - s7_pointer let_body, p = NULL, let_vars, let_code = caddr(scc), ip; - bool let_star; - s7_pointer old_e, stepper; - s7_int body_len, var_len, k, end; - #define O_SIZE 32 - opt_info *body[O_SIZE], *vars[O_SIZE]; - memclr((void *)body, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */ - memclr((void *)vars, O_SIZE * sizeof(opt_info *)); - - /* do_let with non-float vars doesn't get many fixable hits */ - if ((!is_pair(cdr(let_code))) || (!is_list(cadr(let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */ - return(false); - let_body = cddr(let_code); - body_len = s7_list_length(sc, let_body); - if ((body_len <= 0) || (body_len >= 32)) return(false); - let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR); - let_vars = cadr(let_code); - set_safe_stepper(step_slot); - stepper = slot_value(step_slot); - old_e = sc->curlet; - sc->curlet = make_let(sc, sc->curlet); - - sc->pc = 0; - for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32); var_len++, p = cdr(p)) - { - if ((!is_pair(car(p))) || - (!is_normal_symbol(caar(p))) || - (!is_pair(cdar(p)))) - return(false); - vars[var_len] = sc->opts[sc->pc]; - if (!float_optimize(sc, cdar(p))) /* each of these needs to set the associated variable */ - { - set_curlet(sc, old_e); - return(false); - } - if (let_star) - add_slot_checked(sc, sc->curlet, caar(p), s7_make_mutable_real(sc, 1.5)); - } - - if (!let_star) - for (p = let_vars; is_pair(p); p = cdr(p)) - add_slot_checked(sc, sc->curlet, caar(p), s7_make_mutable_real(sc, 1.5)); - - for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p)) - { - body[k] = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - { - set_curlet(sc, old_e); - return(false); - }} - if (!is_null(p)) /* no hits in s7test or snd-test */ - { - set_curlet(sc, old_e); - return(false); - } - end = do_loop_end(stepper); - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - ip = slot_value(step_slot); - - if (body_len == 1) - { - if (var_len == 1) - { - opt_info *first = sc->opts[0]; - opt_info *o = body[0]; - s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); - s7_double (*f1)(opt_info *o) = first->v[0].fd; - s7_double (*f2)(opt_info *o) = o->v[0].fd; - integer(ip) = numerator(stepper); - set_real(xp, f1(first)); - f2(o); - if ((f2 == opt_fmv) && - (f1 == opt_d_dd_ff_o2) && - (first->v[3].d_dd_f == add_d_dd) && - (slot_symbol(step_slot) == slot_symbol(o->v[2].p))) - { - opt_info *o1 = o->v[12].o1; - opt_info *o2 = o->v[13].o1; - opt_info *o3 = o->v[14].o1; - s7_d_vid_t vf7 = o->v[4].d_vid_f; - s7_d_v_t vf1 = first->v[4].d_v_f; - s7_d_v_t vf2 = first->v[5].d_v_f; - s7_d_v_t vf3 = o1->v[2].d_v_f; - s7_d_v_t vf4 = o3->v[5].d_v_f; - s7_d_vd_t vf5 = o2->v[3].d_vd_f; - s7_d_vd_t vf6 = o3->v[6].d_vd_f; - void *obj1 = first->v[1].obj; - void *obj2 = first->v[2].obj; - void *obj3 = o1->v[1].obj; - void *obj4 = o3->v[1].obj; - void *obj5 = o->v[5].obj; - void *obj6 = o2->v[5].obj; - void *obj7 = o3->v[2].obj; - for (k = numerator(stepper) + 1; k < end; k++) - { - s7_double vib = vf1(obj1) + vf2(obj2); - s7_double amp_env = vf3(obj3); - vf7(obj5, k, amp_env * vf5(obj6, vib + (vf4(obj4) * vf6(obj7, vib)))); - }} - else - for (k = numerator(stepper) + 1; k < end; k++) - { - integer(ip) = k; - set_real(xp, f1(first)); - f2(o); - }} /* body_len == 1 and var_len == 1 */ - else - { - if (var_len == 2) - { - s7_pointer s1 = let_slots(sc->curlet); - s7_pointer s2 = next_slot(s1); - for (k = numerator(stepper); k < end; k++) - { - integer(ip) = k; - set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); - set_real(slot_value(s2), vars[1]->v[0].fd(vars[1])); - body[0]->v[0].fd(body[0]); - }} /* body_len == 1 and var_len == 2 */ - else - for (k = numerator(stepper); k < end; k++) - { - integer(ip) = k; - p = let_slots(sc->curlet); - for (int32_t n = 0; tis_slot(p); n++, p = next_slot(p)) - set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); - body[0]->v[0].fd(body[0]); - }}} /* end body_len == 1 */ - else - if ((body_len == 2) && (var_len == 1)) - { - s7_pointer s1 = let_slots(sc->curlet); - for (k = numerator(stepper); k < end; k++) - { - integer(ip) = k; - set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); - body[0]->v[0].fd(body[0]); - body[1]->v[0].fd(body[1]); - }} - else - for (k = numerator(stepper); k < end; k++) - { - int32_t i; - integer(ip) = k; - for (i = 0, p = let_slots(sc->curlet); tis_slot(p); i++, p = next_slot(p)) - set_real(slot_value(p), vars[i]->v[0].fd(vars[i])); - for (i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - } - set_curlet(sc, old_e); - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); -} - -static bool dotimes(s7_scheme *sc, s7_pointer code, bool safe_case) -{ - s7_pointer body = caddr(code); /* here we assume one expr in body */ - if (((is_syntactic_pair(body)) || - (is_symbol_and_syntactic(car(body)))) && - ((symbol_syntax_op_checked(body) == OP_LET) || - (symbol_syntax_op(car(body)) == OP_LET_STAR))) - return(do_let(sc, sc->args, code)); - return(opt_dotimes(sc, cddr(code), code, safe_case)); -} - -static goto_t op_safe_dotimes(s7_scheme *sc) -{ - s7_pointer init_val, form = sc->code; - sc->code = cdr(sc->code); - - init_val = fx_call(sc, cdaar(sc->code)); - if (s7_is_integer(init_val)) - { - s7_pointer end_expr = caadr(sc->code); - s7_pointer code = sc->code; - s7_pointer end_val = caddr(end_expr); - if (is_symbol(end_val)) - end_val = lookup_checked(sc, end_val); - - if (s7_is_integer(end_val)) - { - sc->code = cddr(code); - sc->curlet = make_let(sc, sc->curlet); - sc->args = add_slot_checked(sc, sc->curlet, caaar(code), make_mutable_integer(sc, s7_integer_clamped_if_gmp(sc, init_val))); - set_do_loop_end(slot_value(sc->args), s7_integer_clamped_if_gmp(sc, end_val)); - set_step_end(sc->args); /* safe_dotimes step is by 1 */ - - /* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the let even if the loop is not evaluated */ - - /* safe_dotimes: (car(body) is known to be a pair here) - * if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes - * if they are unhappy, got safe_dotimes_step_o - * else goto opt_dotimes then safe_dotimes_step_o - * if multi-line body, check opt_dotimes, then safe_dotimes_step - */ - if (s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - if ((is_null(cdr(sc->code))) && - (is_pair(car(sc->code)))) - { - sc->code = car(sc->code); - set_opt2_pair(code, sc->code); /* is_pair above */ - if ((is_syntactic_pair(sc->code)) || - (is_symbol_and_syntactic(car(sc->code)))) - { - if (!is_unsafe_do(code)) - { - if (dotimes(sc, code, true)) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - } - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); - if (is_syntactic_pair(sc->code)) - sc->cur_op = (opcode_t)optimize_op(sc->code); - else - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); - } - return(goto_top_no_pop); - } - /* car not syntactic? */ - if ((!is_unsafe_do(code)) && - (opt_dotimes(sc, cddr(code), code, true))) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - - if (has_fx(cddr(code))) /* this almost never happens and the func case below is only in timing tests */ - { - s7_int end = s7_integer_clamped_if_gmp(sc, end_val); - s7_pointer body = cddr(code), stepper = slot_value(sc->args); - for (; integer(stepper) < end; integer(stepper)++) - fx_call(sc, body); - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); /* arg is local step var slot, code is do form - do, sc->code is the body */ - return(goto_eval); - } - /* multi-line body */ - if ((!is_unsafe_do(code)) && - (opt_dotimes(sc, sc->code, code, true))) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - set_opt2_pair(code, sc->code); - push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code); - return(goto_begin); - }} - pair_set_syntax_op(form, OP_SIMPLE_DO); - sc->code = form; - if (op_simple_do(sc)) return(goto_do_end_clauses); - return(goto_begin); -} - -static goto_t op_safe_do(s7_scheme *sc) -{ - /* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body: - * (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst) - * however, we're very restrictive about this in check_do and do_is_safe; even this is considered trouble: - * (let ((x 0)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i))) x) - * but end might not be an integer -- need to catch this earlier. - */ - s7_pointer end, init_val, end_val, code, form = sc->code; - - /* inits, if not >= opt_dotimes else safe_do_step */ - sc->code = cdr(sc->code); - code = sc->code; - init_val = fx_call(sc, cdaar(code)); - end = opt1_any(code); /* caddr(caadr(code)) */ - end_val = (is_symbol(end)) ? lookup_checked(sc, end) : end; - - if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) /* this almost never happens */ - { - pair_set_syntax_op(form, OP_DO_UNCHECKED); - return(goto_do_unchecked); - } - - /* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi)) */ - sc->curlet = make_let(sc, sc->curlet); - let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); /* define the step var -- might be needed in the end clauses */ - - if ((s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) || - ((s7_integer_clamped_if_gmp(sc, init_val) > s7_integer_clamped_if_gmp(sc, end_val)) && - (opt1_cfunc(caadr(code)) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - - if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); - else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); - sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */ - - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - set_step_end(step_slot); - slot_set_value(step_slot, make_mutable_integer(sc, integer(slot_value(step_slot)))); - set_do_loop_end(slot_value(step_slot), s7_integer_clamped_if_gmp(sc, end_val)); - } - - if (!is_unsafe_do(sc->code)) - { - s7_pointer old_let = sc->curlet; - sc->temp7 = old_let; - if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) - return(goto_safe_do_end_clauses); - set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */ - sc->temp7 = sc->unused; - } - if (is_null(cdddr(sc->code))) - { - s7_pointer body = caddr(sc->code); - if ((car(body) == sc->set_symbol) && - (is_pair(cdr(body))) && - (is_symbol(cadr(body))) && - (is_pair(cddr(body))) && - (has_fx(cddr(body))) && - (is_null(cdddr(body)))) - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - if (slot_symbol(step_slot) != cadr(body)) - { - s7_int endi = integer(let_dox2_value(sc->curlet)); - s7_pointer fx_p = cddr(body); - s7_pointer val_slot = lookup_slot_from(cadr(body), sc->curlet); - s7_int step = integer(slot_value(step_slot)); - s7_pointer step_val = make_mutable_integer(sc, step); - slot_set_value(step_slot, step_val); - do { - slot_set_value(val_slot, fx_call(sc, fx_p)); - integer(step_val) = ++step; - } while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */ - clear_mutable_integer(step_val); - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - }}} - sc->code = cddr(code); - set_unsafe_do(sc->code); - set_opt2_pair(code, sc->code); - push_stack_no_args(sc, OP_SAFE_DO_STEP, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */ - return(goto_begin); -} - -static goto_t op_dotimes_p(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code), end_val, slot, old_e; - s7_pointer end = opt1_any(code); /* caddr(opt2_pair(code)) */ - /* (do ... (set! args ...)) -- one line, syntactic */ - - s7_pointer init_val = fx_call(sc, cdaar(code)); - sc->value = init_val; - set_opt2_pair(code, caadr(code)); - if (is_symbol(end)) - { - slot = lookup_slot_from(end, sc->curlet); - end_val = slot_value(slot); - } - else - { - slot = make_slot(sc, make_symbol(sc, "___end___", 9), end); /* name is ignored, but needs to be > 8 chars for gcc's benefit (version 10.2.1)! */ - end_val = end; - } - if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) - { - pair_set_syntax_op(sc->code, OP_DO_UNCHECKED); - sc->code = cdr(sc->code); - return(goto_do_unchecked); - } - - old_e = sc->curlet; - sc->curlet = make_let(sc, sc->curlet); - let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); - let_set_dox_slot2(sc->curlet, slot); - - set_car(sc->t2_1, let_dox1_value(sc->curlet)); - set_car(sc->t2_2, let_dox2_value(sc->curlet)); - if (is_true(sc, sc->value = fn_proc(caadr(code))(sc, sc->t2_1))) - { - sc->code = cdadr(code); - return(goto_do_end_clauses); - } - if ((!is_unsafe_do(code)) && - (opt1_cfunc(caadr(code)) != sc->geq_2)) - { - s7_pointer old_args = sc->args; - s7_pointer old_init = let_dox1_value(sc->curlet); - sc->args = T_Slt(let_dox_slot1(sc->curlet)); /* used in opt_dotimes */ - slot_set_value(sc->args, make_mutable_integer(sc, integer(let_dox1_value(sc->curlet)))); - set_do_loop_end(slot_value(sc->args), integer(let_dox2_value(sc->curlet))); - set_step_end(sc->args); /* dotimes step is by 1 */ - sc->code = cdr(sc->code); - if (dotimes(sc, code, false)) - return(goto_do_end_clauses); /* not safe_do here */ - slot_set_value(sc->args, old_init); - set_curlet(sc, old_e); /* free_cell(sc, sc->curlet) beforehand is not safe */ - sc->args = old_args; - set_unsafe_do(code); - return(goto_do_unchecked); - } - push_stack_no_args(sc, OP_DOTIMES_STEP_O, code); - sc->code = caddr(code); - return(goto_eval); -} - -static bool op_do_init_1(s7_scheme *sc) -{ - s7_pointer y, z; - while (true) /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */ - { - s7_pointer init; - sc->args = cons(sc, sc->value, sc->args); /* code will be last element (first after reverse), these cons's will be used below for the new let/slots */ - if (!is_pair(sc->code)) break; - /* here sc->code is a list like: ((i 0 (+ i 1)) ...) so cadar gets the init value */ - init = cdar(sc->code); - if (has_fx(init)) - sc->value = fx_call(sc, init); - else - { - init = car(init); - if (is_pair(init)) - { - push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ - sc->code = init; - return(true); /* goto eval */ - } - sc->value = (is_symbol(init)) ? lookup_checked(sc, init) : init; - } - sc->code = cdr(sc->code); - } - /* all the initial values are now in the args list */ - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->code = car(sc->args); /* saved at the start */ - z = sc->args; - sc->args = cdr(sc->args); /* init values */ - - /* sc->args was cons'd above, so it should be safe to reuse it as the new let */ - set_curlet(sc, reuse_as_let(sc, z, sc->curlet)); /* sc->curlet = make_let(sc, sc->curlet); */ - - /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet, also reuse sc->args as the new let slots */ - sc->value = sc->nil; - y = sc->args; - for (s7_pointer x = car(sc->code); is_not_null(y); x = cdr(x)) - { - s7_pointer sym = caar(x), args = cdr(y); - reuse_as_slot(sc, y, sym, unchecked_car(y)); - slot_set_next(y, let_slots(sc->curlet)); - let_set_slots(sc->curlet, y); - symbol_set_local_slot(sym, let_id(sc->curlet), y); - if (is_pair(cddar(x))) /* else no incr expr, so ignore it henceforth */ - { - slot_set_expression(y, cddar(x)); - sc->value = cons_unchecked(sc, y, sc->value); - } - y = args; - } - sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code)); - sc->code = cddr(sc->code); - return(false); /* fall through */ -} - -static bool op_do_init(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "do: variable initial value can't be ~S", 38), - set_ulist_1(sc, sc->values_symbol, sc->value))); - return(!op_do_init_1(sc)); -} - -static void op_do_unchecked(s7_scheme *sc) -{ - push_stack_no_code(sc, OP_GC_PROTECT, sc->code); - sc->code = cdr(sc->code); -} - -static bool do_unchecked(s7_scheme *sc) -{ - if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */ - { - sc->curlet = make_let(sc, sc->curlet); - sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code)); - sc->code = cddr(sc->code); - return(false); - } - /* eval each init value, then set up the new let (like let, not let*) */ - sc->args = sc->nil; /* the evaluated var-data */ - sc->value = sc->code; /* protect it */ - sc->code = car(sc->code); /* the vars */ - return(op_do_init_1(sc)); -} - -static bool op_do_end(s7_scheme *sc) -{ - /* car(sc->args) here is the var list used by do_end2 */ - if (is_pair(cdr(sc->args))) - { - if (!has_fx(cdr(sc->args))) - { - push_stack_direct(sc, OP_DO_END1); - sc->code = cadr(sc->args); /* evaluate the end expr */ - return(true); - } - sc->value = fx_call(sc, cdr(sc->args)); - } - else sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */ - return(false); -} - -static goto_t op_do_end_false(s7_scheme *sc) -{ - if (!is_pair(sc->code)) - return((is_null(car(sc->args))) ? /* no steppers */ goto_do_end : fall_through); - if (is_null(car(sc->args))) - push_stack_direct(sc, OP_DO_END); - else push_stack_direct(sc, OP_DO_STEP); - return(goto_begin); -} - -static goto_t op_do_end_true(s7_scheme *sc) -{ - /* we're done -- deal with result exprs, if there isn't an end test, there also isn't a result (they're in the same list) - * multiple-value end-test result is ok - */ - sc->code = T_Lst(cddr(sc->args)); /* result expr (a list -- implicit begin) */ - free_cell(sc, sc->args); - sc->args = sc->nil; - if (is_null(sc->code)) - { - if (is_multiple_value(sc->value)) /* (define (f) (+ 1 (do ((i 2 (+ i 1))) ((values i (+ i 1)))))) -> 6 */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); - /* similarly, if the result is a multiple value: (define (f) (+ 1 (do ((i 2 (+ i 1))) ((= i 3) (values i (+ i 1)))))) -> 8 */ - return(goto_start); - } - /* might be => here as in cond and case */ - if (is_null(cdr(sc->code))) - { - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(goto_start); - } - sc->code = car(sc->code); - return(goto_eval); - } - if (is_undefined_feed_to(sc, car(sc->code))) - return(goto_feed_to); - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - sc->code = car(sc->code); - return(goto_eval); -} - - -/* -------------------------------- apply functions -------------------------------- */ -static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_pointer args) /* -------- C-based function -------- */ -{ - s7_int len = proper_list_length(args); - if (len < c_function_min_args(func)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); - if (c_function_max_args(func) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); - /* fprintf(stderr, "%s %s %s\n", __func__, display(func), display(args)); */ - return(c_function_call(func)(sc, args)); - /* just by chance, this code is identical to macroexpand_c_macro's code (after macro expansion)! So, - * gcc -O2 uses the macroexpand code, but then valgrind shows us calling macros all the time, and - * gdb with break apply_c_function breaks at macroexpand -- confusing! - */ -} - -static void apply_c_rst_no_req_function(s7_scheme *sc) /* -------- C-based function that can take any number of arguments -------- */ -{ - sc->value = c_function_call(sc->code)(sc, sc->args); -} - -static void apply_c_macro(s7_scheme *sc) /* -------- C-based macro -------- */ -{ - s7_int len = proper_list_length(sc->args); - if (len < c_macro_min_args(sc->code)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); - if (c_macro_max_args(sc->code) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); - sc->code = c_macro_call(sc->code)(sc, sc->args); -} - -static void apply_syntax(s7_scheme *sc) /* -------- syntactic keyword as applicable object -------- */ -{ /* current reader-cond macro uses this via (map quote ...) */ - s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */ - if (is_pair(sc->args)) /* this is ((pars) . body) */ - { - len = s7_list_length(sc, sc->args); - if (len == 0) - syntax_error_nr(sc, "attempt to evaluate a circular list: ~S", 39, sc->args); - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, sc->args))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "apply ~S: body is circular: ~S", 30), sc->code, sc->args)); - } - else len = 0; - - if (len < syntax_min_args(sc->code)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); - if ((syntax_max_args(sc->code) < len) && - (syntax_max_args(sc->code) != -1)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); - sc->cur_op = syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */ - /* I had elaborate checks here for embedded circular lists, but now I think that is the caller's problem */ - sc->code = cons(sc, sc->code, sc->args); - set_current_code(sc, sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); -} - -static void apply_vector(s7_scheme *sc) /* -------- vector as applicable object -------- */ -{ - /* sc->code is the vector, sc->args is the list of indices */ - if (is_null(sc->args)) /* (#2d((1 2) (3 4))) */ - wrong_number_of_args_error_nr(sc, "vector ref: no index: (~A)", sc->code); - if ((is_null(cdr(sc->args))) && - (s7_is_integer(car(sc->args))) && - (vector_rank(sc->code) == 1)) - { - s7_int index = s7_integer_clamped_if_gmp(sc, car(sc->args)); - if ((index >= 0) && - (index < vector_length(sc->code))) - sc->value = vector_getter(sc->code)(sc, sc->code, index); - else out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(sc->args), (index < 0) ? it_is_negative_string : it_is_too_large_string); - } - else sc->value = vector_ref_1(sc, sc->code, sc->args); -} - -static void apply_string(s7_scheme *sc) /* -------- string as applicable object -------- */ -{ - if (!is_pair(sc->args)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "string ref: no index: (~S~{~^ ~S~})", 35), sc->code, sc->args)); - if (!is_null(cdr(sc->args))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "string ref: too many indices: (~S~{~^ ~S~})", 43), sc->code, sc->args)); - - if (s7_is_integer(car(sc->args))) - { - s7_int index = s7_integer_clamped_if_gmp(sc, car(sc->args)); - if ((index >= 0) && - (index < string_length(sc->code))) - { - sc->value = chars[((uint8_t *)string_value(sc->code))[index]]; - return; - }} - sc->value = string_ref_1(sc, sc->code, car(sc->args)); -} - -static bool apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */ -{ - if (is_multiple_value(sc->code)) /* ((values + 2 3) 4) */ - { - /* car of values can be anything, so conjure up a new expression, and apply again */ - sc->args = pair_append(sc, cdr(sc->code), sc->args); - sc->code = car(sc->code); - return(false); - } - if (is_null(sc->args)) - wrong_number_of_args_error_nr(sc, "list ref: no index: (~S)", sc->code); - sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */ - if (!is_null(cdr(sc->args))) - sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); - return(true); -} - -static void apply_hash_table(s7_scheme *sc) /* -------- hash-table as applicable object -------- */ -{ - if (is_null(sc->args)) - wrong_number_of_args_error_nr(sc, "hash-table ref: no key: (~S)", sc->code); - sc->value = s7_hash_table_ref(sc, sc->code, car(sc->args)); - if (!is_null(cdr(sc->args))) - sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); -} - -static void apply_let(s7_scheme *sc) /* -------- environment as applicable object -------- */ -{ - if (is_null(sc->args)) - wrong_number_of_args_error_nr(sc, "let ref: no field: (~S)", sc->code); - sc->value = let_ref(sc, sc->code, car(sc->args)); - if (is_pair(cdr(sc->args))) - sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); - /* (let ((v #(1 2 3))) (let ((e (curlet))) ((e 'v) 1))) -> 2 - * so (let ((v #(1 2 3))) (let ((e (curlet))) (e 'v 1))) -> 2 - */ -} - -static void apply_iterator(s7_scheme *sc) /* -------- iterator as applicable object -------- */ -{ - if (!is_null(sc->args)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "iterator takes no arguments: (~A~{~^ ~S~})", 42), sc->code, sc->args)); - sc->value = s7_iterate(sc, sc->code); -} - -static Inline void inline_apply_lambda(s7_scheme *sc) /* -------- normal function (lambda), or macro --------, called once in eval */ -{ /* load up the current args into the ((args) (lambda)) layout [via the current environment] */ - s7_pointer x, z, e = sc->curlet, slot, last_slot = slot_end(sc); - uint64_t id = let_id(sc->curlet); - - for (x = closure_args(sc->code), z = T_Lst(sc->args); is_pair(x); x = cdr(x), z = cdr(z)) /* closure_args can be a symbol, for example */ - { - s7_pointer sym = car(x); - if (is_null(z)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_5(sc, wrap_string(sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), - closure_name(sc, sc->code), - (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), - closure_args(sc->code), sc->args)); - slot = make_slot(sc, sym, T_Ext(unchecked_car(z))); - symbol_set_local_slot(sym, id, slot); - if (tis_slot(last_slot)) - slot_set_next(last_slot, slot); - else let_set_slots(e, slot); - last_slot = slot; - slot_set_next(slot, slot_end(sc)); - } - if (is_null(x)) - { - if (is_not_null(z)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_5(sc, wrap_string(sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", 46), - closure_name(sc, sc->code), - (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), - closure_args(sc->code), sc->args)); - } - else - { - slot = make_slot(sc, x, z); - symbol_set_local_slot(x, id, slot); - if (tis_slot(last_slot)) - slot_set_next(last_slot, slot); - else let_set_slots(e, slot); - slot_set_next(slot, slot_end(sc)); - } - sc->code = closure_body(sc->code); -} - -static void op_f(s7_scheme *sc) /* sc->code: ((lambda () 32)) -> (let () 32) */ -{ - sc->curlet = make_let(sc, sc->curlet); - sc->code = opt3_pair(sc->code); /* cddar */ -} - -static void op_f_a(s7_scheme *sc) /* sc->code: ((lambda (x) (+ x 1)) i) -> (let ((x i)) (+ x 1)) */ -{ - /* if caddar(sc->code) is fxable [(+ x 1) above], this could call fx and return to the top */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(cdr(sc->code)), fx_call(sc, cdr(sc->code))); - sc->code = opt3_pair(sc->code); -} - -static void op_f_aa(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) i j) -> (let ((x i) (y j)) (+ x y)) */ -{ - gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); - sc->curlet = make_let_with_two_slots(sc, sc->curlet, opt3_sym(cdr(sc->code)), stack_protected1(sc), cadadr(car(sc->code)), fx_call(sc, cddr(sc->code))); - unstack(sc); - sc->code = opt3_pair(sc->code); -} - -static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (values i j)) -> (let ((x i) (y j)) (+ x y)) after splice */ -{ - s7_pointer pars = cadar(sc->code); - s7_pointer e = make_let(sc, sc->curlet); - if (is_pair(pars)) - { - s7_pointer last_slot; - if (is_null(cdr(sc->code))) /* ((lambda (x) 21)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); - if (is_constant(sc, car(pars))) - error_nr(sc, sc->syntax_error_symbol, /* (lambda (a) 1) where 'a is immutable (locally perhaps) */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: ((lambda ~S ...)~{~^ ~S~})", 61), - car(pars), cadar(sc->code), cdr(sc->code))); - - add_slot_unchecked_no_local(sc, e, car(pars), sc->undefined); - last_slot = let_slots(e); - for (pars = cdr(pars); is_pair(pars); pars = cdr(pars)) - last_slot = add_slot_at_end_no_local(sc, last_slot, car(pars), sc->undefined); - /* last par might be rest par (dotted) */ - if (!is_null(pars)) - { - last_slot = add_slot_at_end_no_local(sc, last_slot, pars, sc->undefined); - set_is_rest_slot(last_slot); - }} - /* check_stack_size(sc); */ - if ((sc->stack_end + 4) >= sc->stack_resize_trigger) resize_stack(sc); - push_stack(sc, OP_GC_PROTECT, let_slots(e), cddr(sc->code)); /* not for gc-protection, but as implicit loop vars */ - push_stack(sc, OP_F_NP_1, e, sc->code); - sc->code = cadr(sc->code); -} - -static bool op_f_np_1(s7_scheme *sc) -{ - s7_pointer e, slot = stack_protected1(sc), arg = stack_protected2(sc); - if (is_multiple_value(sc->value)) - { - s7_pointer p, oslot = slot; - for (p = sc->value; (is_pair(p)) && (tis_slot(slot)); p = cdr(p), oslot = slot, slot = next_slot(slot)) - if (is_rest_slot(slot)) - { - if (slot_value(slot) == sc->undefined) - slot_set_value(slot, copy_proper_list(sc, p)); - else slot_set_value(slot, pair_append(sc, slot_value(slot), copy_proper_list(sc, p))); - p = sc->nil; - break; - } - else slot_set_value(slot, car(p)); - if (is_pair(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); - slot = oslot; /* snd-test 22 grani */ - } - else /* not mv */ - if (!is_rest_slot(slot)) - slot_set_value(slot, sc->value); - else - if (slot_value(slot) == sc->undefined) - slot_set_value(slot, list_1(sc, sc->value)); - else slot_set_value(slot, pair_append(sc, slot_value(slot), list_1(sc, sc->value))); - - if (is_pair(arg)) - { - if ((!tis_slot(next_slot(slot))) && (!is_rest_slot(slot))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46), - cadar(sc->code), cdr(sc->code))); - set_stack_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot)); - set_stack_protected2(sc, cdr(arg)); - push_stack_direct(sc, OP_F_NP_1); /* sc->args=e, sc->code from start */ - sc->code = car(arg); - return(true); - } - if (tis_slot(next_slot(slot))) - { - if (!is_rest_slot(next_slot(slot))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); - if (slot_value(next_slot(slot)) == sc->undefined) - slot_set_value(next_slot(slot), sc->nil); - } - e = sc->args; - let_set_id(e, ++sc->let_number); - set_curlet(sc, e); - update_symbol_ids(sc, e); - sc->code = cddar(sc->code); - unstack(sc); - return(false); -} - -static void op_lambda_star(s7_scheme *sc) -{ - check_lambda_star(sc); - if (!is_pair(car(sc->code))) - sc->value = make_closure(sc, car(sc->code), cdr(sc->code), - (is_symbol(car(sc->code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, - CLOSURE_ARITY_NOT_SET); - else sc->value = make_closure(sc, car(sc->code), cdr(sc->code), - (!arglist_has_rest(sc, car(sc->code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), - CLOSURE_ARITY_NOT_SET); -} - -static void op_lambda_star_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if (!is_pair(car(code))) - sc->value = make_closure(sc, car(code), cdr(code), - (is_symbol(car(code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, - CLOSURE_ARITY_NOT_SET); - else sc->value = make_closure(sc, car(code), cdr(code), - (!arglist_has_rest(sc, car(code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), - CLOSURE_ARITY_NOT_SET); -} - -static s7_pointer star_set(s7_scheme *sc, s7_pointer slot, s7_pointer val, bool check_rest) -{ - if (is_checked_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - if ((check_rest) && (is_rest_slot(slot))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), slot_symbol(slot), val)); - set_checked_slot(slot); - slot_set_value(slot, val); - return(val); -} - -static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val, s7_pointer slot, bool check_rest) -{ - if (val == sc->no_value) val = sc->unspecified; - if (sym == slot_symbol(slot)) - return(star_set(sc, slot, val, check_rest)); - for (s7_pointer x = let_slots(sc->curlet) /* presumably the arglist */; tis_slot(x); x = next_slot(x)) - if (slot_symbol(x) == sym) - return(star_set(sc, x, val, check_rest)); - return(sc->no_value); -} - -static s7_pointer lambda_star_set_args(s7_scheme *sc) -{ - s7_pointer arg_vals = sc->args, rest_key = sc->nil, code = sc->code, args = sc->args; - s7_pointer slot = let_slots(sc->curlet); - s7_pointer pars = closure_args(code); - bool allow_other_keys = ((is_pair(pars)) && (allows_other_keys(pars))); - - while ((is_pair(pars)) && - (is_pair(arg_vals))) - { - if (car(pars) == sc->rest_keyword) /* the rest arg: a default is not allowed here (see check_lambda_star_args) */ - { - /* next arg is bound to trailing args from this point as a list */ - pars = cdr(pars); - if ((is_symbol_and_keyword(car(arg_vals))) && - (is_pair(cdr(arg_vals))) && - (keyword_symbol(car(arg_vals)) == car(pars))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), - car(pars), cadr(arg_vals))); - lambda_star_argument_set_value(sc, car(pars), (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals), slot, false); /* sym5 :rest bug */ - rest_key = sc->rest_keyword; - arg_vals = cdr(arg_vals); - pars = cdr(pars); - slot = next_slot(slot); - } - else - { - s7_pointer arg_val = car(arg_vals); - if (is_symbol_and_keyword(arg_val)) - { - if (!is_pair(cdr(arg_vals))) - { - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, keyword_value_missing_string, closure_name(sc, code), arg_vals, args)); - slot_set_value(slot, arg_val); - set_checked_slot(slot); - arg_vals = cdr(arg_vals); - } - else - { - s7_pointer sym = keyword_symbol(arg_val); - if (lambda_star_argument_set_value(sc, sym, cadr(arg_vals), slot, true) == sc->no_value) - { - /* if default value is a key, go ahead and use this value. - * (define* (f (a :b)) a) (f :c) - * this has become much trickier than I anticipated... - */ - if (allow_other_keys) - /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3 - * in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3 - */ - arg_vals = cddr(arg_vals); - else - { - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: unknown key: ~S in ~S", 25), closure_name(sc, code), arg_vals, args)); - slot_set_value(slot, arg_val); - set_checked_slot(slot); - arg_vals = cdr(arg_vals); - pars = cdr(pars); - slot = next_slot(slot); - } - continue; - } - arg_vals = cddr(arg_vals); - } - slot = next_slot(slot); - } - else /* not a key/value pair */ - { - if (is_checked_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - set_checked_slot(slot); - slot_set_value(slot, car(arg_vals)); - slot = next_slot(slot); - arg_vals = cdr(arg_vals); - } - pars = cdr(pars); - }} - /* (let () (define* (hi (a 1) :allow-other-keys) a) (hi :a 2 32)) -> 'error */ - /* (let () (define* (f (a :b)) a) (list (f) (f 1) (f :c) (f :a :c) (f :a 1) (f))) -> 'error */ - - /* check for trailing args with no :rest arg */ - if (is_not_null(arg_vals)) - { - if ((is_not_null(pars)) || - (rest_key == sc->rest_keyword)) - { - if (is_symbol(pars)) - { - if ((is_symbol_and_keyword(car(arg_vals))) && - (is_pair(cdr(arg_vals))) && - (keyword_symbol(car(arg_vals)) == pars)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), pars, cadr(arg_vals))); - slot_set_value(slot, (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals)); /* sym5 :rest bug */ - }} - else - { - if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "too many arguments: (~S ~S ...)~{~^ ~S~})", 41), - (is_closure_star(code)) ? sc->lambda_star_symbol : ((is_bacro_star(sc->code)) ? sc->bacro_star_symbol : sc->macro_star_symbol), - closure_args(code), args)); - /* check trailing args for repeated keys or keys with no values or values with no keys */ - while (is_pair(arg_vals)) - { - if ((!is_symbol_and_keyword(car(arg_vals))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */ - (!is_pair(cdr(arg_vals)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: not a key/value pair: ~S", 28), closure_name(sc, code), arg_vals)); - slot = symbol_to_local_slot(sc, keyword_symbol(car(arg_vals)), sc->curlet); - if ((is_slot(slot)) && - (is_checked_slot(slot))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - arg_vals = cddr(arg_vals); - }}} - return(sc->nil); -} - -static inline bool lambda_star_default(s7_scheme *sc) -{ - for (s7_pointer z = sc->args; tis_slot(z); z = next_slot(z)) - { - if ((slot_value(z) == sc->undefined) && /* trouble: (lambda* ((e #))...) */ - (slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */ - (!is_checked_slot(z))) - { - s7_pointer val = slot_expression(z); - if (is_symbol(val)) - { - slot_set_value(z, lookup_checked(sc, val)); - if (slot_value(z) == sc->undefined) - { - /* the current environment here contains the function parameters which defaulted to # - * (or maybe #?) earlier in apply_*_closure_star_1, so (define (f f) (define* (f (f f)) f) (f)) (f 0) - * looks for the default f, finds itself currently undefined, and raises an error! So, before - * claiming it is unbound, we need to check outlet as well. But in the case above, the inner - * define* shadows the caller's parameter before checking the default arg values, so the default f - * refers to the define* -- I'm not sure this is a bug. It means that (define* (f (a f)) a) - * returns f: (equal? f (f)) -> #t, so any outer f needs an extra let and endless outlets: - * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3 - * We want the shadowing once the define* is done, so the current mess is simplest. - */ - slot_set_value(z, s7_symbol_local_value(sc, val, let_outlet(sc->curlet))); - if (slot_value(z) == sc->undefined) - syntax_error_nr(sc, "lambda* defaults: ~A is unbound", 31, slot_symbol(z)); - }} - else - if (!is_pair(val)) - slot_set_value(z, val); - else - if (car(val) == sc->quote_symbol) - { - if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */ - (is_pair(cddr(val)))) - syntax_error_nr(sc, "lambda* default: ~A is messed up", 32, val); - slot_set_value(z, cadr(val)); - } - else - { - push_stack(sc, OP_LAMBDA_STAR_DEFAULT, z, sc->code); - sc->code = val; - return(true); /* goto eval */ - }}} - return(false); -} - -static bool op_lambda_star_default(s7_scheme *sc) -{ - /* sc->args is the current let slots position, sc->value is the default expression's value */ - if (is_multiple_value(sc->value)) - syntax_error_nr(sc, "lambda*: argument default value can't be ~S", 43, set_ulist_1(sc, sc->values_symbol, sc->value)); - slot_set_value(sc->args, sc->value); - sc->args = next_slot(sc->args); - if (lambda_star_default(sc)) return(true); - pop_stack_no_op(sc); - sc->code = T_Pair(closure_body(sc->code)); - return(false); -} - -static inline bool set_star_args(s7_scheme *sc, s7_pointer top) -{ - lambda_star_set_args(sc); /* load up current arg vals */ - sc->args = top; - if (is_slot(sc->args)) - { - /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */ - push_stack_direct(sc, OP_GC_PROTECT); - if (lambda_star_default(sc)) return(true); /* else fall_through */ - pop_stack_no_op(sc); /* get original args and code back */ - } - sc->code = closure_body(sc->code); - return(false); -} - -static inline bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */ -{ - /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */ - set_curlet(sc, closure_let(sc->code)); - if (has_no_defaults(sc->code)) - { - for (s7_pointer z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) - { - clear_checked_slot(z); - slot_set_value(z, sc->F); - } - if (!is_null(sc->args)) - lambda_star_set_args(sc); /* load up current arg vals */ - sc->code = closure_body(sc->code); - return(false); /* goto BEGIN */ - } - for (s7_pointer z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) - { - clear_checked_slot(z); - slot_set_value(z, (slot_defaults(z)) ? sc->undefined : slot_expression(z)); - } - return(set_star_args(sc, slot_pending_value(let_slots(sc->curlet)))); -} - -static bool apply_unsafe_closure_star_1(s7_scheme *sc) -{ - s7_pointer z, top = sc->nil; - for (z = closure_args(sc->code); is_pair(z); z = cdr(z)) - { - s7_pointer car_z = car(z); - if (is_pair(car_z)) /* arg has a default value */ - { - s7_pointer slot, val = cadr(car_z); - if ((!is_pair(val)) && - (!is_symbol(val))) - slot = add_slot_checked(sc, sc->curlet, car(car_z), val); - else - { - add_slot(sc, sc->curlet, car(car_z), sc->undefined); - slot = let_slots(sc->curlet); - slot_set_expression(slot, val); - } - if (is_null(top)) - top = slot; - } - else - if (!is_keyword(car_z)) - add_slot(sc, sc->curlet, car_z, sc->F); - else - if (car_z == sc->rest_keyword) /* else it's :allow-other-keys? */ - { - set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(z), sc->nil)); - z = cdr(z); - }} - if (is_symbol(z)) - set_is_rest_slot(add_slot_checked(sc, sc->curlet, z, sc->nil)); /* set up rest arg */ - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - return(set_star_args(sc, top)); -} - -static void apply_macro_star_1(s7_scheme *sc) -{ - /* here the defaults (if any) are not evalled, and there is not an existing let */ - s7_pointer p; - for (p = closure_args(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer par = car(p); - if (is_pair(par)) - add_slot_checked(sc, sc->curlet, car(par), cadr(par)); - else - if (!is_keyword(par)) - add_slot_checked(sc, sc->curlet, par, sc->F); - else - if (par == sc->rest_keyword) - { - set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(p), sc->nil)); - p = cdr(p); - }} - if (is_symbol(p)) - set_is_rest_slot(add_slot_checked(sc, sc->curlet, p, sc->nil)); - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - lambda_star_set_args(sc); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void clear_absolutely_all_optimizations(s7_pointer p) -{ - if ((is_pair(p)) && (!is_matched_pair(p))) - { - clear_has_fx(p); - clear_optimized(p); - clear_optimize_op(p); - set_match_pair(p); - clear_absolutely_all_optimizations(cdr(p)); - clear_absolutely_all_optimizations(car(p)); - } -} - -static void clear_matches(s7_pointer p) -{ - if ((is_pair(p)) && (is_matched_pair(p))) - { - clear_match_pair(p); - clear_matches(car(p)); - clear_matches(cdr(p)); - } -} - -static void apply_macro(s7_scheme *sc) /* this is not from the reader, so treat expansions here as normal macros */ -{ - check_stack_size(sc); - if (closure_arity_to_int(sc, sc->code) < 0) - { - clear_absolutely_all_optimizations(sc->args); /* desperation... */ - clear_matches(sc->args); - } - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); /* closure_let -> sc->curlet, sc->code is the macro */ - transfer_macro_info(sc, sc->code); -} - -static void apply_bacro(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = make_let(sc, sc->curlet); /* like let* -- we'll be adding macro args, so might as well sequester things here */ - transfer_macro_info(sc, sc->code); -} - -static void apply_macro_star(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = make_let(sc, closure_let(sc->code)); - transfer_macro_info(sc, sc->code); - apply_macro_star_1(sc); -} - -static void apply_bacro_star(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = make_let(sc, sc->curlet); - transfer_macro_info(sc, sc->code); - apply_macro_star_1(sc); -} - -static void apply_closure(s7_scheme *sc) -{ - /* we can get safe_closures here, but can't easily determine whether we have the expected saved funclet */ - check_stack_size(sc); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); -} - -static bool apply_closure_star(s7_scheme *sc) -{ - if (is_safe_closure(sc->code)) - return(apply_safe_closure_star_1(sc)); - check_stack_size(sc); - sc->curlet = make_let(sc, closure_let(sc->code)); - return(apply_unsafe_closure_star_1(sc)); -} - -static inline s7_pointer op_safe_closure_star_a1(s7_scheme *sc, s7_pointer code) /* called in eval and below, tlamb */ -{ - s7_pointer func = opt1_lambda(code); - s7_pointer val = fx_call(sc, cdr(code)); - if ((is_symbol_and_keyword(val)) && - (!sc->accept_all_keyword_arguments)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), val, sc->args)); - sc->curlet = update_let_with_slot(sc, closure_let(func), val); - sc->code = T_Pair(closure_body(func)); - return(func); -} - -static void op_safe_closure_star_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer func = op_safe_closure_star_a1(sc, code); - s7_pointer p = cdr(closure_args(func)); - if (is_pair(p)) - for (s7_pointer x = next_slot(let_slots(closure_let(func))); is_pair(p); p = cdr(p), x = next_slot(x)) - { - if (is_pair(car(p))) - { - s7_pointer defval = cadar(p); - slot_set_value(x, (is_pair(defval)) ? cadr(defval) : defval); - } - else slot_set_value(x, sc->F); - symbol_set_local_slot(slot_symbol(x), let_id(sc->curlet), x); - } -} - -static void op_safe_closure_star_ka(s7_scheme *sc, s7_pointer code) /* two args, but k=arg key, key has been checked. no trailing pars */ -{ - s7_pointer func = opt1_lambda(code); - sc->curlet = update_let_with_slot(sc, closure_let(func), fx_call(sc, cddr(code))); - sc->code = T_Pair(closure_body(func)); -} - -static void op_safe_closure_star_aa(s7_scheme *sc, s7_pointer code) -{ - /* here closure_arity == 2 and we have 2 args and those args' defaults are simple (no eval or lookup needed) */ - s7_pointer arg2, func = opt1_lambda(code); - s7_pointer arg1 = fx_call(sc, cdr(code)); - sc->w = arg1; /* weak GC protection */ - arg2 = fx_call(sc, cddr(code)); - - if (is_symbol_and_keyword(arg1)) - { - if (keyword_symbol(arg1) == slot_symbol(let_slots(closure_let(func)))) - { - arg1 = arg2; - arg2 = cadr(closure_args(func)); - if (is_pair(arg2)) arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2); else arg2 = sc->F; - } - else - if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(closure_let(func))))) - { - arg1 = car(closure_args(func)); - if (is_pair(arg1)) arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); else arg1 = sc->F; - } - else - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), - closure_name(sc, func), arg1, code)); /* arg1 is already the value */ - } - else - if ((is_symbol_and_keyword(arg2)) && - (!sc->accept_all_keyword_arguments)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), arg2, code)); - sc->curlet = update_let_with_two_slots(sc, closure_let(func), arg1, arg2); - sc->code = T_Pair(closure_body(func)); -} - -static bool call_lambda_star(s7_scheme *sc, s7_pointer code, s7_pointer arglist) -{ - bool target; - sc->code = opt1_lambda(code); - target = apply_safe_closure_star_1(sc); - clear_list_in_use(arglist); - return(target); -} - -static bool op_safe_closure_star_aaa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg2, arg3, func = opt1_lambda(code); - s7_pointer arg1 = fx_call(sc, cdr(code)); - gc_protect_via_stack(sc, arg1); - arg2 = fx_call(sc, cddr(code)); - set_stack_protected2(sc, arg2); - arg3 = fx_call(sc, cdddr(code)); - if ((is_symbol_and_keyword(arg1)) || (is_symbol_and_keyword(arg2)) || (is_symbol_and_keyword(arg3))) - { - s7_pointer arglist = make_safe_list(sc, 3); - sc->args = arglist; - set_car(arglist, arg1); - set_cadr(arglist, arg2); - set_caddr(arglist, arg3); - unstack(sc); - return(call_lambda_star(sc, code, arglist)); /* this clears list_in_use */ - } - sc->curlet = update_let_with_three_slots(sc, closure_let(func), arg1, arg2, arg3); - unstack(sc); - sc->code = T_Pair(closure_body(func)); - if_pair_set_up_begin_unchecked(sc); - return(true); -} - -static bool op_safe_closure_star_na_0(s7_scheme *sc, s7_pointer code) -{ - sc->args = sc->nil; - sc->code = opt1_lambda(code); - return(apply_safe_closure_star_1(sc)); -} - -static bool op_safe_closure_star_na_1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arglist = safe_list_1(sc); - sc->args = arglist; - set_car(arglist, fx_call(sc, cdr(code))); - return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ -} - -static bool op_safe_closure_star_na_2(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arglist = safe_list_2(sc); - sc->args = arglist; - set_car(arglist, fx_call(sc, cdr(code))); - set_cadr(arglist, fx_call(sc, cddr(code))); - return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ -} - -static inline bool op_safe_closure_star_na(s7_scheme *sc, s7_pointer code) /* called once in eval, clo */ -{ - s7_pointer arglist = safe_list_if_possible(sc, opt3_arglen(cdr(code))); - sc->args = arglist; - for (s7_pointer p = arglist, old_args = cdr(code); is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - if ((S7_DEBUGGING) && (sc->args != arglist)) fprintf(stderr, "%s[%d]: lost gc\n", __func__, __LINE__); - return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ -} - -static void op_closure_star_ka(s7_scheme *sc, s7_pointer code) -{ - s7_pointer func = opt1_lambda(code); - s7_pointer p = car(closure_args(func)); - sc->value = fx_call(sc, cddr(code)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, sc->value); - sc->code = T_Pair(closure_body(func)); -} - -static void op_closure_star_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p, func = opt1_lambda(code); - sc->value = fx_call(sc, cdr(code)); - if ((is_symbol_and_keyword(sc->value)) && - (!sc->accept_all_keyword_arguments)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, keyword_value_missing_string, closure_name(sc, opt1_lambda(code)), sc->value, code)); - p = car(closure_args(func)); - sc->curlet = make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, sc->value); - if (closure_star_arity_to_int(sc, func) > 1) - { - s7_pointer last_slot = let_slots(sc->curlet); - s7_int id = let_id(sc->curlet); - for (p = cdr(closure_args(func)); is_pair(p); p = cdr(p)) - { - s7_pointer par = car(p); - if (is_pair(par)) - last_slot = add_slot_at_end(sc, id, last_slot, car(par), (is_pair(cadr(par))) ? cadadr(par) : cadr(par)); /* possible quoted list as default value */ - else last_slot = add_slot_at_end(sc, id, last_slot, par, sc->F); - }} - sc->code = T_Pair(closure_body(func)); -} - -static inline bool op_closure_star_na(s7_scheme *sc, s7_pointer code) -{ - /* check_stack_size(sc); */ - if (is_pair(cdr(code))) - { - sc->w = cdr(code); /* args aren't evaluated yet */ - sc->args = make_list(sc, opt3_arglen(cdr(code)), sc->unused); - for (s7_pointer p = sc->args, old_args = sc->w; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - sc->w = sc->unused; - } - else sc->args = sc->nil; - sc->code = opt1_lambda(code); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); - return(apply_unsafe_closure_star_1(sc)); -} - -static s7_pointer define1_caller(s7_scheme *sc) -{ - /* we can jump to op_define1, so this is not fool-proof */ - if (sc->cur_op == OP_DEFINE_CONSTANT) return(sc->define_constant_symbol); - if ((sc->cur_op == OP_DEFINE_STAR) || (sc->cur_op == OP_DEFINE_STAR_UNCHECKED)) return(sc->define_star_symbol); - return(sc->define_symbol); -} - -static bool op_define1(s7_scheme *sc) -{ - /* sc->code is the symbol being defined, sc->value is its value - * if sc->value is a closure, car is of the form ((args...) body...) - * it's not possible to expand and replace macros at this point without evaluating - * the body. Just as examples, say we have a macro "mac", - * (define (hi) (call/cc (lambda (mac) (mac 1)))) - * (define (hi) (quote (mac 1))) or macroexpand etc - * (define (hi mac) (mac 1)) assuming mac here is a function passed as an arg, etc... - * the immutable constant check needs to wait until we have the actual new value because - * we want to ignore the rebinding (not raise an error) if it is the existing value. - * This happens when we reload a file that calls define-constant. But we want a - * warning if we got define (as opposed to the original define-constant). - */ - s7_pointer x; - if (is_multiple_value(sc->value)) /* (define x (values 1 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "~A: more than one value: (~A ~A ~S)", 35), - define1_caller(sc), define1_caller(sc), sc->code, sc->value)); - if (is_constant_symbol(sc, sc->code)) /* (define pi 3) or (define (pi a) a) */ - { - x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : lookup_slot_from(sc->code, sc->curlet); - /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ - - if (!((is_slot(x)) && - (type(sc->value) == unchecked_type(slot_value(x))) && - (s7_is_equivalent(sc, sc->value, slot_value(x))))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_with_caller_nr(sc, "~A: ~S is immutable", 19, define1_caller(sc), sc->code); /* can't use s7_is_equal because value might be NaN, etc */ - - if ((sc->safety > 0) && /* (define-constant x 3) (define x 3)... */ - (sc->cur_op == OP_DEFINE)) - s7_warn(sc, 256, "(define %s %s), but %s is a constant\n", display(sc->code), display(sc->value), display(sc->code)); - } - else x = lookup_slot_from(sc->code, sc->curlet); - if ((is_slot(x)) && (slot_has_setter(x))) - { - sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); - if (sc->value == sc->no_value) - return(true); /* goto apply, if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ - } - return(false); /* fall through */ -} - -static void set_let_file_and_line(s7_scheme *sc, s7_pointer new_let, s7_pointer new_func) -{ - if (port_file(current_input_port(sc)) != stdin) - { - if ((is_pair(closure_args(new_func))) && - (has_location(closure_args(new_func)))) - { - let_set_file(new_let, pair_file_number(closure_args(new_func))); - let_set_line(new_let, pair_line_number(closure_args(new_func))); - } - else - if (has_location(closure_body(new_func))) - { - let_set_file(new_let, pair_file_number(closure_body(new_func))); - let_set_line(new_let, pair_line_number(closure_body(new_func))); - } - else - { - s7_pointer p; - for (p = cdr(closure_body(new_func)); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && (has_location(car(p)))) - break; - let_set_file(new_let, (is_pair(p)) ? pair_file_number(car(p)) : port_file_number(current_input_port(sc))); - let_set_line(new_let, (is_pair(p)) ? pair_line_number(car(p)) : port_line_number(current_input_port(sc))); - } - set_has_let_file(new_let); - } - else - { - let_set_file(new_let, 0); - let_set_line(new_let, 0); - clear_has_let_file(new_let); - } -} - -static void op_define_with_setter(s7_scheme *sc) -{ - s7_pointer code = sc->code; - if ((is_immutable(sc->curlet)) && - (is_let(sc->curlet))) /* not () */ - error_nr(sc, sc->immutable_error_symbol, - set_elist_2(sc, wrap_string(sc, "can't define ~S: curlet is immutable", 36), code)); - - if ((is_any_closure(sc->value)) && - ((!(is_let(closure_let(sc->value)))) || - (!(is_funclet(closure_let(sc->value)))))) /* otherwise it's (define f2 f1) or something similar */ - { - s7_pointer new_func = sc->value, new_let; - if (is_safe_closure_body(closure_body(new_func))) - { - set_safe_closure(new_func); - if (is_very_safe_closure_body(closure_body(new_func))) - set_very_safe_closure(new_func); - } - new_let = make_funclet(sc, new_func, code, closure_let(new_func)); - - /* this should happen only if the closure* default values do not refer in any way to - * the enclosing environment (else we can accidentally shadow something that happens - * to share an argument name that is being used as a default value -- kinda dumb!). - * I think I'll check this before setting the safe_closure bit. - */ - set_let_file_and_line(sc, new_let, new_func); - /* add the newly defined thing to the current environment */ - if (is_let(sc->curlet)) - { - if (let_id(sc->curlet) <= symbol_id(code)) /* we're adding a later-bound symbol to an old let (?) */ - { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ - s7_pointer slot; - sc->let_number++; /* dummy let, force symbol lookup */ - for (slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (slot_symbol(slot) == code) - { - if (is_immutable(slot)) - syntax_error_nr(sc, "define ~S, but it is immutable", 30, code); /* someday give the location of the immutable definition or setting */ - slot_set_value(slot, new_func); - symbol_set_local_slot(code, sc->let_number, slot); - set_local(code); - sc->value = new_func; /* probably not needed? */ - return; - } - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, code, new_func); - symbol_set_local_slot(code, sc->let_number, slot); - slot_set_next(slot, let_slots(sc->curlet)); - let_set_slots(sc->curlet, slot); - } - else add_slot(sc, sc->curlet, code, new_func); - set_local(code); - } - else - { - if ((is_slot(global_slot(code))) && - (is_immutable(global_slot(code)))) - { - s7_pointer old_symbol = code, old_value = global_value(code); - if ((type(old_value) != type(new_func)) || - (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); - } - s7_make_slot(sc, sc->curlet, code, new_func); - } - sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */ - } - else - { - s7_pointer slot = symbol_to_local_slot(sc, code, sc->curlet); /* add the newly defined thing to the current environment */ - if (is_slot(slot)) - { - if (is_immutable(slot)) - { - s7_pointer old_symbol = code, old_value = slot_value(slot); - if ((type(old_value) != type(sc->value)) || - (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); - } - slot_set_value_with_hook(slot, sc->value); - symbol_increment_ctr(code); - } - else s7_make_slot(sc, sc->curlet, code, sc->value); - if ((is_any_macro(sc->value)) && (!is_c_macro(sc->value))) - { - set_pair_macro(closure_body(sc->value), code); - set_has_pair_macro(sc->value); - }} -} - - -/* -------------------------------- eval -------------------------------- */ -static void check_for_cyclic_code(s7_scheme *sc, s7_pointer code) -{ - if (tree_is_cyclic(sc, code)) - { - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); - syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, code); - } - resize_stack(sc); /* we've already checked that resize_stack is needed */ -} - -static void op_thunk(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = inline_make_let(sc, closure_let(p)); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin(sc); -} - -static void op_thunk_o(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = inline_make_let(sc, closure_let(p)); - sc->code = car(closure_body(p)); -} - -static void op_safe_thunk(s7_scheme *sc) /* no let needed */ -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = closure_let(p); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static s7_pointer op_safe_thunk_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer f = opt1_lambda(code); - set_curlet(sc, closure_let(f)); - return(fx_call(sc, closure_body(f))); -} - -static void op_thunk_any(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = make_let_with_slot(sc, closure_let(p), closure_args(p), sc->nil); - sc->code = closure_body(p); -} - -static void op_safe_thunk_any(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = closure_let(p); - slot_set_value(let_slots(sc->curlet), sc->nil); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_closure_s(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = inline_make_let_with_slot(sc, closure_let(p), car(closure_args(p)), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static inline void op_closure_s_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), car(closure_args(f)), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_s(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(p), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_s_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args(sc, OP_SAFE_CLOSURE_P_1, opt1_lambda(sc->code)); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_p_1(s7_scheme *sc) -{ - sc->curlet = update_let_with_slot(sc, closure_let(sc->code), sc->value); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_p_a(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_CLOSURE_P_A_1); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_p_a_1(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), sc->value); - sc->value = fx_call(sc, closure_body(f)); -} - -static Inline void inline_op_closure_a(s7_scheme *sc) /* called twice in eval */ -{ - s7_pointer f = opt1_lambda(sc->code); - sc->value = fx_call(sc, cdr(sc->code)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), car(closure_args(f)), sc->value); - sc->code = T_Pair(closure_body(f)); -} - -static void op_safe_closure_3s(s7_scheme *sc) -{ - s7_pointer args = cddr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, car(args)), lookup(sc, cadr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_ssa(s7_scheme *sc) /* possibly inline b */ -{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx overhead, etc */ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), lookup(sc, car(args)), lookup(sc, cadr(args)), fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_saa(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - s7_pointer args = cddr(sc->code); - s7_pointer arg2 = lookup(sc, cadr(sc->code)); /* I don't see fx_t|u here? */ - sc->code = fx_call(sc, args); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), arg2, sc->code, fx_call(sc, cdr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_agg(s7_scheme *sc) /* possibly inline tleft */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), fx_call(sc, args), fx_call(sc, cdr(args)), fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_closure_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args(sc, OP_CLOSURE_P_1, opt1_lambda(sc->code)); - sc->code = cadr(sc->code); -} - -static void op_closure_p_1(s7_scheme *sc) -{ - sc->curlet = inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_args(sc->code)), sc->value); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_a(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), fx_call(sc, cdr(sc->code))); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static void op_safe_closure_a_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), fx_call(sc, cdr(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_closure_ap(s7_scheme *sc) -{ - s7_pointer code = sc->code; - sc->args = fx_call(sc, cdr(code)); - /* (hook-push (undo-hook ind 0) (lambda (hook) (set! u0 #t))) -> # - * g_undo_hook calls s7_eval_c_string so it obviously should be declared unsafe! - */ - push_stack(sc, OP_CLOSURE_AP_1, opt1_lambda(sc->code), sc->args); - sc->code = caddr(code); -} - -static void op_closure_ap_1(s7_scheme *sc) -{ - /* sc->value is presumably the "P" argument value, "A" is sc->args->sc->code above (sc->args here is opt1_lambda(original sc->code)) */ - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(sc->args), car(closure_args(sc->args)), sc->code, cadr(closure_args(sc->args)), sc->value); - sc->code = T_Pair(closure_body(sc->args)); -} - -static void op_closure_pa(s7_scheme *sc) -{ - s7_pointer code = sc->code; - sc->args = fx_call(sc, cddr(code)); - check_stack_size(sc); - push_stack(sc, OP_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); /* "p" can be self-call changing func locally! so pass opt1_lambda(sc->code), not sc->code */ - sc->code = cadr(code); -} - -static void op_closure_pa_1(s7_scheme *sc) -{ - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(sc->code), car(closure_args(sc->code)), sc->value, cadr(closure_args(sc->code)), sc->args); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_closure_pp(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack(sc, OP_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); - sc->code = cadr(sc->code); -} - -static void op_closure_pp_1(s7_scheme *sc) -{ - push_stack(sc, OP_CLOSURE_AP_1, sc->args, sc->value); - sc->code = caddr(sc->code); -} - -static void op_safe_closure_ap(s7_scheme *sc) -{ - check_stack_size(sc); - sc->args = fx_call(sc, cdr(sc->code)); - push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->args, opt1_lambda(sc->code)); - sc->code = caddr(sc->code); -} - -static void op_safe_closure_ap_1(s7_scheme *sc) -{ - sc->curlet = update_let_with_two_slots(sc, closure_let(sc->code), sc->args, sc->value); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_pa(s7_scheme *sc) -{ - check_stack_size(sc); - sc->args = fx_call(sc, cddr(sc->code)); - push_stack(sc, OP_SAFE_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_pa_1(s7_scheme *sc) -{ - sc->curlet = update_let_with_two_slots(sc, closure_let(sc->code), sc->value, sc->args); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_pp(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack(sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_pp_1(s7_scheme *sc) -{ - push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args); - sc->code = caddr(sc->code); -} - -static void op_any_closure_3p(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - if (has_fx(p)) - { - sc->args = fx_call(sc, p); - p = cdr(p); - if (has_fx(p)) - { - sc->stack_end[0] = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */ - sc->stack_end[2] = sc->args; /* stack[args] == arg1 to closure) */ - sc->stack_end[3] = (s7_pointer)(OP_ANY_CLOSURE_3P_3); - sc->stack_end += 4; - set_stack_protected3_with(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3); - /* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */ - sc->code = cadr(p); - } - else - { - push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ - sc->code = car(p); - }} - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_3P_1); - sc->code = car(p); - } -} - -static bool closure_3p_end(s7_scheme *sc, s7_pointer p) -{ - if (has_fx(p)) - { - s7_pointer func = opt1_lambda(sc->code); - gc_protect_2_via_stack(sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */ - set_stack_protected3(sc, fx_call(sc, p)); - if (is_safe_closure(func)) - sc->curlet = update_let_with_three_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc)); - else make_let_with_three_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc)); - unstack(sc); - sc->code = T_Pair(closure_body(func)); - return(true); - } - push_stack_direct(sc, OP_ANY_CLOSURE_3P_3); - set_stack_protected3_with(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* arg2 == curlet stack loc */ - sc->code = car(p); - return(false); -} - -static bool op_any_closure_3p_1(s7_scheme *sc) -{ - s7_pointer p = cddr(sc->code); - sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ - if (has_fx(p)) - { - sc->value = fx_call(sc, p); - return(closure_3p_end(sc, cdr(p))); - } - push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); - sc->code = car(p); - return(false); -} - -static bool op_any_closure_3p_2(s7_scheme *sc) {return(closure_3p_end(sc, cdddr(sc->code)));} - -static void op_any_closure_3p_3(s7_scheme *sc) -{ - /* display(obj) will not work here because sc->curlet is being used as arg2 of the closure3 */ - s7_pointer func = opt1_lambda(sc->code); /* incoming args (from pop_stack): sc->args, sc->curlet, and sc->value from last evaluation */ - if (is_safe_closure(func)) - sc->curlet = update_let_with_three_slots(sc, closure_let(func), sc->args, sc->curlet, sc->value); - else make_let_with_three_slots(sc, func, sc->args, sc->curlet, sc->value); - sc->code = T_Pair(closure_body(func)); -} - -static void op_any_closure_4p(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - check_stack_size(sc); - if (has_fx(p)) - { - gc_protect_via_stack(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected2(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); - sc->code = cadr(p); - } - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - }} - else - { - sc->stack_end[2] = sc->unused; /* copy_stack dangling pair */ - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); - sc->code = car(p); - }} - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1); - sc->code = car(p); - } -} - -static bool closure_4p_end(s7_scheme *sc, s7_pointer p) -{ - if (has_fx(p)) - { - s7_pointer func = opt1_lambda(sc->code); - sc->args = fx_call(sc, p); - if (is_safe_closure(func)) - sc->curlet = update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args); - else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args); - sc->code = T_Pair(closure_body(func)); - unstack(sc); - return(true); - } - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); - sc->code = car(p); - return(false); -} - -static bool op_any_closure_4p_1(s7_scheme *sc) -{ - s7_pointer p = cddr(sc->code); - gc_protect_via_stack(sc, sc->value); - if (has_fx(p)) - { - set_stack_protected2(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - return(closure_4p_end(sc, cdr(p))); - } - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - } - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); - sc->code = car(p); - } - return(false); -} - -static bool op_any_closure_4p_2(s7_scheme *sc) -{ - s7_pointer p = cdddr(sc->code); - set_stack_protected2(sc, sc->value); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - return(closure_4p_end(sc, cdr(p))); - } - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - return(false); -} - -static bool op_any_closure_4p_3(s7_scheme *sc) -{ - set_stack_protected3(sc, sc->value); - return(closure_4p_end(sc, cddddr(sc->code))); -} - -static inline void op_any_closure_4p_4(s7_scheme *sc) -{ - s7_pointer func = opt1_lambda(sc->code); - if (is_safe_closure(func)) - sc->curlet = update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value); - else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value); - sc->code = T_Pair(closure_body(func)); - unstack(sc); -} - -static void op_safe_closure_ss(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static void op_safe_closure_ss_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static inline void op_closure_ss(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), - car(closure_args(f)), lookup(sc, cadr(sc->code)), - cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static inline void op_closure_ss_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), - car(closure_args(f)), lookup(sc, cadr(sc->code)), - cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_sc(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), opt2_con(sc->code)); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static void op_safe_closure_sc_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), opt2_con(sc->code)); - sc->code = car(closure_body(f)); -} - -static void op_closure_sc(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), lookup(sc, cadr(sc->code)), cadr(closure_args(f)), opt2_con(sc->code)); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static inline void op_closure_sc_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), lookup(sc, cadr(sc->code)), cadr(closure_args(f)), opt2_con(sc->code)); - sc->code = car(closure_body(f)); -} - -static void op_closure_3s(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cdr(args); - make_let_with_three_slots(sc, f, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static inline void op_closure_3s_o(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cdr(args); - make_let_with_three_slots(sc, f, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = car(closure_body(f)); -} - -static void op_closure_4s(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer v2 = lookup(sc, cadr(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cddr(args); - make_let_with_four_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static inline void op_closure_4s_o(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer v2 = lookup(sc, cadr(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cddr(args); - make_let_with_four_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_aa(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code); - p = T_Pair(closure_body(f)); - /* check_stack_size(sc); */ /* pretty-print if cycles=#f? */ - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p))); - sc->code = car(p); -} - -static inline void op_safe_closure_aa_o(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code); - sc->code = car(closure_body(f)); -} - -static void op_closure_aa(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), sc->value, cadr(closure_args(f)), sc->code); - p = T_Pair(closure_body(f)); - check_stack_size(sc); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p))); - sc->code = car(p); -} - -static Inline void inline_op_closure_aa_o(s7_scheme *sc) /* called once in eval, b cb left lg list */ -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), sc->value, cadr(closure_args(f)), sc->code); - sc->code = car(closure_body(f)); -} - -static inline void op_closure_fa(s7_scheme *sc) -{ - s7_pointer new_clo, code = sc->code; - s7_pointer farg = opt2_pair(code); /* cdadr(code); */ - s7_pointer aarg = fx_call(sc, cddr(code)); - s7_pointer func = opt1_lambda(code); /* outer func */ - s7_pointer func_args = closure_args(func); - sc->value = inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->F, cadr(func_args), aarg); - new_clo = make_closure_unchecked(sc, car(farg), cdr(farg), T_CLOSURE | ((is_symbol(car(farg))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET); - slot_set_value(let_slots(sc->value), new_clo); /* this order allows us to use make_closure_unchecked */ - sc->curlet = sc->value; - sc->code = car(closure_body(func)); -} - -static void op_safe_closure_ns(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - s7_pointer let = closure_let(f); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - for (s7_pointer x = let_slots(let); tis_slot(x); x = next_slot(x), args = cdr(args)) - { - slot_set_value(x, lookup(sc, car(args))); - symbol_set_local_slot(slot_symbol(x), id, x); - } - set_curlet(sc, let); - sc->code = closure_body(f); - if_pair_set_up_begin_unchecked(sc); -} - -static inline void op_safe_closure_3a(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->args = fx_call(sc, cddr(p)); /* is sc->args safe here? */ - sc->curlet = update_let_with_three_slots(sc, closure_let(f), fx_call(sc, p), sc->code, sc->args); - sc->code = closure_body(f); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_na(s7_scheme *sc) -{ - s7_pointer let; - uint64_t id; - - sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); - for (s7_pointer args = cdr(sc->code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - sc->code = opt1_lambda(sc->code); - id = ++sc->let_number; - let = closure_let(sc->code); - let_set_id(let, id); - for (s7_pointer x = let_slots(let), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) - { - slot_set_value(x, car(z)); - symbol_set_local_slot(slot_symbol(x), id, x); - } - clear_list_in_use(sc->args); - set_curlet(sc, let); - sc->code = closure_body(sc->code); - if_pair_set_up_begin_unchecked(sc); -} - -static /* inline */ void op_closure_ns(s7_scheme *sc) /* called once in eval, lg? */ -{ - /* in this case, we have just lambda (not lambda*), and no dotted arglist, - * and no accessed symbols in the arglist, and we know the arglist matches the parameter list. - */ - s7_pointer args = cdr(sc->code), last_slot; - s7_pointer f = opt1_lambda(sc->code); - s7_pointer p = closure_args(f); - s7_pointer e = inline_make_let(sc, closure_let(f)); - s7_int id = let_id(e); - sc->z = e; - add_slot_unchecked(sc, e, car(p), lookup(sc, car(args)), id); - last_slot = let_slots(e); - for (p = cdr(p), args = cdr(args); is_pair(p); p = cdr(p), args = cdr(args)) - last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), lookup(sc, car(args))); /* main such call in lt (fx_s is 1/2, this is 1/5 of all calls) */ - set_curlet(sc, e); - sc->z = sc->unused; - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_ass(s7_scheme *sc) /* possibly inline b */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - make_let_with_three_slots(sc, f, fx_call(sc, args), lookup(sc, cadr(args)), lookup(sc, caddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_aas(s7_scheme *sc) /* possibly inline b */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->z = fx_call(sc, args); - make_let_with_three_slots(sc, f, sc->z, fx_call(sc, cdr(args)), lookup(sc, caddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_saa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->z = fx_call(sc, cdr(args)); - make_let_with_three_slots(sc, f, lookup(sc, car(args)), sc->z, fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_asa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->z = fx_call(sc, args); - make_let_with_three_slots(sc, f, sc->z, lookup(sc, cadr(args)), fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_sas(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - make_let_with_three_slots(sc, f, lookup(sc, car(args)), fx_call(sc, cdr(args)), lookup(sc, caddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static inline void op_closure_3a(s7_scheme *sc) /* if inlined, tlist -60 */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cdr(args))); - make_let_with_three_slots(sc, f, stack_protected1(sc), stack_protected2(sc), fx_call(sc, cddr(args))); - unstack(sc); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_4a(s7_scheme *sc) /* sass */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args))); - args = cdr(args); - set_stack_protected3(sc, fx_call(sc, args)); /* [-3]=second */ - make_let_with_four_slots(sc, f, stack_protected1(sc), stack_protected3(sc), stack_protected2(sc), fx_call(sc, cddr(args))); - unstack(sc); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_na(s7_scheme *sc) -{ - s7_pointer exprs = cdr(sc->code); - s7_pointer func = opt1_lambda(sc->code), slot, last_slot; - s7_int id; - s7_pointer pars = closure_args(func); - s7_pointer e = inline_make_let(sc, closure_let(func)); - sc->z = e; - sc->value = fx_call(sc, exprs); - new_cell_no_check(sc, last_slot, T_SLOT); - slot_set_symbol_and_value(last_slot, car(pars), sc->value); - slot_set_next(last_slot, let_slots(e)); /* i.e. slot_end */ - let_set_slots(e, last_slot); - for (pars = cdr(pars), exprs = cdr(exprs); is_pair(pars); pars = cdr(pars), exprs = cdr(exprs)) - { - sc->value = fx_call(sc, exprs); /* before new_cell since it might call the GC */ - new_cell(sc, slot, T_SLOT); /* args < GC_TRIGGER checked in optimizer, but we're calling fx_call? */ - slot_set_symbol_and_value(slot, car(pars), sc->value); - /* setting up the let might use unrelated-but-same-name symbols, so wait to set the symbol ids */ - slot_set_next(slot, slot_end(sc)); - slot_set_next(last_slot, slot); - last_slot = slot; - } - set_curlet(sc, e); - sc->z = sc->unused; - let_set_id(e, ++sc->let_number); - for (id = let_id(e), slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) - { - symbol_set_local_slot(slot_symbol(slot), id, slot); - set_local(slot_symbol(slot)); - } - sc->code = T_Pair(closure_body(func)); - if_pair_set_up_begin(sc); -} - -static bool check_closure_sym(s7_scheme *sc, int32_t args) -{ - /* can't use closure_is_fine -- (lambda args 1) and (lambda (name . args) 1) are both arity -1 for the internal arity checkers! */ - if ((symbol_ctr(car(sc->code)) != 1) || - (unchecked_local_value(car(sc->code)) != opt1_lambda_unchecked(sc->code))) - { - s7_pointer f = lookup_unexamined(sc, car(sc->code)); - if ((f != opt1_lambda_unchecked(sc->code)) && - ((!f) || - ((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || - (((args == 1) && (!is_symbol(closure_args(f)))) || - ((args == 2) && ((!is_pair(closure_args(f))) || (!is_symbol(cdr(closure_args(f))))))))) - { - sc->last_function = f; - return(false); - } - set_opt1_lambda(sc->code, f); - } - return(true); -} - -static void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */ -{ - s7_pointer func = opt1_lambda(sc->code), old_args = cdr(sc->code); /* args aren't evaluated yet */ - s7_int num_args = opt3_arglen(old_args); - - if (num_args == 1) - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), closure_args(func), - ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? - set_plist_1(sc, fx_call(sc, old_args)) : list_1(sc, sc->value = fx_call(sc, old_args))); - else - if (num_args == 2) - { - gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ - sc->args = fx_call(sc, cdr(old_args)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), closure_args(func), - ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? - set_plist_2(sc, stack_protected1(sc), sc->args) : list_2(sc, stack_protected1(sc), sc->args)); - unstack(sc); - } - else - if (num_args == 0) - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), closure_args(func), sc->nil); - else - { - sc->args = make_list(sc, num_args, sc->unused); - for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - sc->curlet = make_let_with_slot(sc, closure_let(func), closure_args(func), sc->args); - } - sc->code = T_Pair(closure_body(func)); -} - -static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */ -{ - s7_pointer func = opt1_lambda(sc->code), old_args = cdr(sc->code); - s7_int num_args = opt3_arglen(old_args); - s7_pointer func_args = closure_args(func); - - if (num_args == 1) - sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->value = fx_call(sc, old_args), cdr(func_args), sc->nil); - else - { - gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ - if (num_args == 2) - { - sc->args = fx_call(sc, cdr(old_args)); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), list_1(sc, sc->args)); - } - else - { - sc->args = make_list(sc, num_args - 1, sc->unused); - old_args = cdr(old_args); - for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), sc->args); - } - unstack(sc); - } - sc->code = T_Pair(closure_body(func)); -} - - -/* -------- */ -#if S7_DEBUGGING -#define TC_REC_SIZE NUM_OPS -#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA - -static void init_tc_rec(s7_scheme *sc) -{ - sc->tc_rec_calls = (int *)Calloc(TC_REC_SIZE, sizeof(int)); - add_saved_pointer(sc, sc->tc_rec_calls); -} - -static s7_pointer g_report_missed_calls(s7_scheme *sc, s7_pointer args) -{ - for (int32_t i = TC_REC_LOW_OP; i < NUM_OPS; i++) - if (sc->tc_rec_calls[i] == 0) - fprintf(stderr, "%s missed\n", op_names[i]); - return(sc->F); -} - -static void tick_tc(s7_scheme *sc, int32_t op) -{ - sc->tc_rec_calls[op]++; -} -#else -#define tick_tc(Sc, Op) -#endif - -static bool op_tc_case_la(s7_scheme *sc, s7_pointer code) -{ - /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ - s7_pointer clauses = cddr(code), la_slot = let_slots(sc->curlet), endp, selp = cdr(code); - s7_int len = opt3_arglen(cdr(code)); - if (len == 3) - { - while (true) - { - s7_pointer selector = fx_call(sc, selp); - if (selector == opt1_any(clauses)) - endp = opt2_any(clauses); - else - { - s7_pointer p = cdr(clauses); - endp = (selector == opt1_any(p)) ? opt2_any(p) : opt2_any(cdr(p)); - } - if (has_tc(endp)) - slot_set_value(la_slot, fx_call(sc, cdr(endp))); - else break; - }} - else - while (true) - { - s7_pointer p, selector = fx_call(sc, selp); - for (p = clauses; is_pair(cdr(p)); p = cdr(p)) - if (selector == opt1_any(p)) {endp = opt2_any(p); goto CASE_ALA_END;} - endp = opt2_any(p); - CASE_ALA_END: - if (has_tc(endp)) - slot_set_value(la_slot, fx_call(sc, cdr(endp))); - else break; - } - if (has_fx(endp)) - { - sc->value = fx_call(sc, endp); - return(true); /* continue */ - } - sc->code = endp; - return(false); /* goto BEGIN (not like op_tc_z below) */ -} - -static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_CASE_LA); - op_tc_case_la(sc, arg); - return(sc->value); -} - -static bool op_tc_z(s7_scheme *sc, s7_pointer expr) -{ - if (has_fx(expr)) - { - sc->value = fx_call(sc, expr); - return(true); - } - sc->code = car(expr); - return(false); -} - -static void op_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or = cdadr(fx_and); - s7_pointer fx_la = cdadr(fx_or); - /* cell_optimize here is slower! */ - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_LA); - op_tc_and_a_or_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and = cdadr(fx_or); - s7_pointer fx_la = cdadr(fx_and); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_LA); - op_tc_or_a_and_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or1 = cdadr(fx_and); - s7_pointer fx_or2 = cdr(fx_or1); - s7_pointer fx_la = cdadr(fx_or2); - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or1); - if (p != sc->F) {sc->value = p; return;} - p = fx_call(sc, fx_or2); - if (p != sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_A_LA); - op_tc_and_a_or_a_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and1 = cdadr(fx_or); - s7_pointer fx_and2 = cdr(fx_and1); - s7_pointer fx_la = cdadr(fx_and2); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) == sc->F) || - (fx_call(sc, fx_and2) == sc->F)) - {sc->value = sc->F; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); - op_tc_or_a_and_a_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or1 = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or2 = cdr(fx_or1); - s7_pointer fx_and1 = cdadr(fx_or2); - s7_pointer fx_and2 = cdr(fx_and1); - s7_pointer fx_la = cdadr(fx_and2); - while (true) - { - s7_pointer p = fx_call(sc, fx_or1); - if (p != sc->F) {sc->value = p; return;} - p = fx_call(sc, fx_or2); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and1) == sc->F) {sc->value = sc->F; return;} - if (fx_call(sc, fx_and2) == sc->F) {sc->value = sc->F; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); - op_tc_or_a_a_and_a_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or = cdadr(fx_and); - s7_pointer fx_la = cdadr(fx_or); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer laa_slot = next_slot(la_slot); - - if ((fx_proc(fx_and) == fx_not_is_null_u) && (fx_proc(fx_or) == fx_is_null_t) && - (fx_proc(fx_la) == fx_cdr_t) && (fx_proc(fx_laa) == fx_cdr_u)) - { - s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); - while (true) - { - if (is_null(laa_val)) {sc->value = sc->F; return;} - if (is_null(la_val)) {sc->value = sc->T; return;} - la_val = cdr(la_val); - laa_val = cdr(laa_val); - }} - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - sc->rec_p1 = fx_call(sc, fx_la); - slot_set_value(laa_slot, fx_call(sc, fx_laa)); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_LAA); - op_tc_and_a_or_a_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and = cdadr(fx_or); - s7_pointer fx_la = cdadr(fx_and); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer laa_slot = next_slot(la_slot); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - slot_set_value(laa_slot, fx_call(sc, fx_laa)); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_LAA); - op_tc_or_a_and_a_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or = cdadr(fx_and); - s7_pointer fx_la = cdadr(fx_or); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer fx_l3a = cdr(fx_laa); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a_slot = next_slot(laa_slot); - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_L3A); - op_tc_and_a_or_a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static void op_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and = cdadr(fx_or); - s7_pointer fx_la = cdadr(fx_and); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer fx_l3a = cdr(fx_laa); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a_slot = next_slot(laa_slot); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_L3A); - op_tc_or_a_and_a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and1 = opt3_pair(fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */ - s7_pointer fx_and2 = cdr(fx_and1); - s7_pointer fx_la = cdadr(fx_and2); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer fx_l3a = cdr(fx_laa); - s7_pointer l3a_slot = next_slot(laa_slot); - if ((fx_proc(fx_and1) == fx_not_a) && (fx_proc(fx_and2) == fx_not_a)) - { - fx_and1 = cdar(fx_and1); - fx_and2 = cdar(fx_and2); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) != sc->F) || (fx_call(sc, fx_and2) != sc->F)) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(la_slot, sc->rec_p1); - slot_set_value(laa_slot, sc->rec_p2); - }} - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) == sc->F) || (fx_call(sc, fx_and2) == sc->F)) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(la_slot, sc->rec_p1); - slot_set_value(laa_slot, sc->rec_p2); - } -} - -static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A); - op_tc_or_a_and_a_a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code, bool cond) -{ - s7_pointer la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_true = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test); - s7_pointer la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test); - if (is_t_integer(slot_value(la_slot))) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - while (!(o->v[0].fb(o))){integer(val) = o1->v[0].fi(o1);} - return(op_tc_z(sc, if_true)); - }}} - while (fx_call(sc, if_test) == sc->F) {slot_set_value(la_slot, fx_call(sc, la));} - return(op_tc_z(sc, if_true)); -} - -static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_LA); - op_tc_if_a_z_la(sc, arg, false); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_LA); - op_tc_if_a_z_la(sc, arg, true); - return(sc->value); -} - -static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code, bool cond) -{ - s7_pointer la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_false = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test); - s7_pointer la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test); - if (is_t_integer(slot_value(la_slot))) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - while (o->v[0].fb(o)) {integer(val) = o1->v[0].fi(o1);} - return(op_tc_z(sc, if_false)); - }}} - while (fx_call(sc, if_test) != sc->F) {slot_set_value(la_slot, fx_call(sc, la));} - return(op_tc_z(sc, if_false)); -} - -static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_LA_Z); - op_tc_if_a_la_z(sc, arg, false); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_LA_Z); - op_tc_if_a_la_z(sc, arg, true); - return(sc->value); -} - -typedef enum {TC_IF, TC_COND, TC_AND} tc_choice_t; - -static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond) -{ - s7_pointer if_test, if_z, la, laa, laa_slot, la_slot = let_slots(sc->curlet); - s7_function tf; - if (cond == TC_IF) - { - if_test = cdr(code); - if_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */ - la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */ - } - else - { - if_test = cadr(code); - if_z = opt1_pair(cdr(code)); /* if_z = (z_first) ? cdr(if_test) : cdr(caddr(code)) */ - la = opt3_pair(cdr(code)); /* la = (z_first) ? cdr(cadaddr(code)) : cdadr(if_test) */ - } - laa = cdr(la); - laa_slot = next_slot(la_slot); -#if (!WITH_GMP) - if (!no_bool_opt(code)) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2; - int32_t start_pc = sc->pc; - if ((is_t_integer(slot_value(la_slot))) && - (is_t_integer(slot_value(laa_slot)))) - { - if (int_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (int_optimize(sc, laa)) - { - s7_int (*fi1)(opt_info *o) = o1->v[0].fi; - s7_int (*fi2)(opt_info *o) = o2->v[0].fi; - bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); - s7_pointer val2; - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2 = make_mutable_integer(sc, integer(slot_value(laa_slot)))); - if ((z_first) && - ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && - (fi1 == opt_i_ii_sc_sub)) - { - s7_int lim = o->v[2].i, m = o1->v[2].i; - s7_pointer slot1 = o->v[1].p, slot2 = o1->v[1].p; - while (integer(slot_value(slot1)) >= lim) - { - s7_int i1 = integer(slot_value(slot2)) - m; - integer(val2) = fi2(o2); - integer(val1) = i1; - }} - else - while (fb(o) != z_first) - { - s7_int i1 = fi1(o1); - integer(val2) = fi2(o2); - integer(val1) = i1; - } - return(op_tc_z(sc, if_z)); - }}} - - if ((is_t_real(slot_value(la_slot))) && - (is_t_real(slot_value(laa_slot)))) - { - sc->pc = start_pc; - if (float_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (float_optimize(sc, laa)) - { - s7_double (*fd1)(opt_info *o) = o1->v[0].fd; - s7_double (*fd2)(opt_info *o) = o2->v[0].fd; - bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = s7_make_mutable_real(sc, real(slot_value(la_slot))); - s7_pointer val2 = s7_make_mutable_real(sc, real(slot_value(laa_slot))); - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2); - if ((z_first) && - (fb == opt_b_dd_sc_lt) && - (fd1 == opt_d_dd_sc_sub)) - { - s7_double lim = o->v[2].x; - s7_double m = o1->v[2].x; - s7_pointer slot1 = o->v[1].p; - s7_pointer slot2 = o1->v[1].p; - while (real(slot_value(slot1)) >= lim) - { - s7_double x1 = real(slot_value(slot2)) - m; - real(val2) = fd2(o2); - real(val1) = x1; - }} - else - while (fb(o) != z_first) - { - s7_double x1 = fd1(o1); - real(val2) = fd2(o2); - real(val1) = x1; - } - return(op_tc_z(sc, if_z)); - }}}} - set_no_bool_opt(code); - } -#endif - tf = fx_proc(if_test); - if_test = car(if_test); - if (z_first) - { - if ((fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_subtract_u1) && - (fn_proc(if_test) == g_num_eq_xi) && /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */ - (is_pair(slot_value(la_slot))) && (is_t_integer(slot_value(laa_slot)))) - { /* list-tail ferchrissake */ - s7_int end = integer(caddr(if_test)); - s7_pointer lst = slot_value(la_slot); - for (s7_int start = integer(slot_value(laa_slot)); start > end; start--) - lst = cdr(lst); - slot_set_value(la_slot, lst); - } - else - while (tf(sc, if_test) == sc->F) - { - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - }} - else - while (tf(sc, if_test) != sc->F) - { - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, if_z)); -} - -static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_LAA); - op_tc_if_a_z_laa(sc, arg, true, TC_IF); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_LAA); - op_tc_if_a_z_laa(sc, arg, true, TC_COND); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_LAA_Z); - op_tc_if_a_z_laa(sc, arg, false, TC_IF); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_LAA_Z); - op_tc_if_a_z_laa(sc, arg, false, TC_COND); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_when_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cadr(code), body = cddr(code), la_call, la, la_slot = let_slots(sc->curlet); - s7_function tf = fx_proc(cdr(code)); - for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); - la = cdar(la_call); - while (tf(sc, if_test) != sc->F) - { - for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); - slot_set_value(la_slot, fx_call(sc, la)); - } - sc->value = sc->unspecified; -} - -static void op_tc_when_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cadr(code), body = cddr(code), la, laa, laa_slot, la_call, la_slot = let_slots(sc->curlet); - s7_function tf = fx_proc(cdr(code)); - for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); - la = cdar(la_call); - laa = cdr(la); - laa_slot = next_slot(la_slot); - while (tf(sc, if_test) != sc->F) - { - for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - sc->rec_p1 = sc->unused; - sc->value = sc->unspecified; -} - -static void op_tc_when_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cadr(code), body = cddr(code), la, laa, l3a, laa_slot, l3a_slot, la_call, la_slot = let_slots(sc->curlet); - s7_function tf = fx_proc(cdr(code)); - for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); - la = cdar(la_call); - laa = cdr(la); - l3a = cdr(laa); - laa_slot = next_slot(la_slot); - l3a_slot = next_slot(laa_slot); - while (tf(sc, if_test) != sc->F) - { - for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); - sc->rec_p1 = fx_call(sc, la); - sc->rec_p2 = fx_call(sc, laa); - slot_set_value(l3a_slot, fx_call(sc, l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } - sc->rec_p1 = sc->unused; - sc->value = sc->unspecified; -} - -static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool z_first) -{ - s7_pointer if_test = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer f_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */ - s7_pointer la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */ - s7_pointer laa = cdr(la); - s7_pointer l3a = cdr(laa); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a_slot = next_slot(laa_slot); - s7_function tf = fx_proc(if_test); - if_test = car(if_test); - while ((tf(sc, if_test) == sc->F) == z_first) - { - sc->rec_p1 = fx_call(sc, la); - sc->rec_p2 = fx_call(sc, laa); - slot_set_value(l3a_slot, fx_call(sc, l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, f_z)); -} - -static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_L3A); - op_tc_if_a_z_l3a(sc, arg, true); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_if_a_l3a_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_L3A_Z); - op_tc_if_a_z_l3a(sc, arg, false); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond) -{ - s7_pointer if_test, if_true, if_false, f_test, f_z, la, endp, la_slot = let_slots(sc->curlet); - bool tc_and = (cond == TC_AND); - if (cond != TC_COND) - { - if_test = cdr(code); - if_true = (!tc_and) ? cdr(if_test) : sc->F; - if_false = (!tc_and) ? cadr(if_true) : cadr(if_test); - f_test = cdr(if_false); - f_z = (z_first) ? cdr(f_test) : cddr(f_test); - la = (z_first) ? cdaddr(f_test) : cdadr(f_test); - } - else - { - if_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z2)) */ - if_true = cdr(if_test); - if_false = caddr(code); /* (a2 z2|la) */ - f_test = if_false; - f_z = (z_first) ? cdr(f_test) : cdr(cadddr(code)); - la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code)); - } -#if (!WITH_GMP) - if (is_t_integer(slot_value(la_slot))) - { - opt_info *o = sc->opts[0]; - sc->pc = 0; - if (bool_optimize_nw(sc, if_test)) - { - opt_info *o1 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, f_test)) - { - opt_info *o2 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - if (tc_and) - while (true) - { - if (!o->v[0].fb(o)) {sc->value = sc->F; return(true);} - if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - integer(val) = o2->v[0].fi(o2); - } - else - while (true) - { - if (o->v[0].fb(o)) {endp = if_true; break;} - if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - integer(val) = o2->v[0].fi(o2); - } - return(op_tc_z(sc, endp)); - }}}} -#endif - while (true) - { - if ((fx_call(sc, if_test) == sc->F) == tc_and) {if (tc_and) {sc->value = sc->F; return(true);} else {endp = if_true; break;}} - if ((fx_call(sc, f_test) == sc->F) != z_first) {endp = f_z; break;} - slot_set_value(la_slot, fx_call(sc, la)); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA); - op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_IF); - return(sc->value); -} - -static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_LA_Z); - op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_IF); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_Z_LA); - op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_COND); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_LA_Z); - op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_COND); - return(sc->value); -} - -static s7_pointer fx_tc_and_a_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_IF_A_Z_LA); - op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_AND); - return(sc->value); -} - -static s7_pointer fx_tc_and_a_if_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_IF_A_LA_Z); - op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_AND); - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code) -{ - s7_pointer if_false, f_test, f_true, la, laa, laa_slot, endp, slot1, la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_true = cdr(if_test); - if (!cond) if_false = cadr(if_true); - f_test = (cond) ? caddr(code) : cdr(if_false); - f_true = cdr(f_test); - la = (cond) ? opt3_pair(code) : cdadr(f_true); /* cdadr(cadddr(code)) */ - laa = cdr(la); - laa_slot = next_slot(la_slot); - slot1 = (fx_proc(if_test) == fx_is_null_t) ? la_slot : ((fx_proc(if_test) == fx_is_null_u) ? laa_slot : NULL); - if (slot1) - { - if ((slot1 == laa_slot) && (fx_proc(f_test) == fx_is_null_t) && (fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_cdr_u) && - (is_boolean(car(if_true))) && (is_boolean(car(f_true)))) - { - s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); - while (true) - { - if (is_null(laa_val)) {sc->value = car(if_true); return(true);} - if (is_null(la_val)) {sc->value = car(f_true); return(true);} - la_val = cdr(la_val); - laa_val = cdr(laa_val); - }} - while (true) - { - if (is_null(slot_value(slot1))) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - }} - else - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LAA); - op_tc_if_a_z_if_a_z_laa(sc, false, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_Z_LAA); - op_tc_if_a_z_if_a_z_laa(sc, true, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_laa_z(s7_scheme *sc, bool cond, s7_pointer code) -{ - s7_pointer if_false, f_test, f_true, f_false, la, laa, laa_slot, endp, la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_true = cdr(if_test); - if (!cond) if_false = cadr(if_true); - f_test = (cond) ? caddr(code) : cdr(if_false); - f_true = cdr(f_test); - f_false = (cond) ? cdr(cadddr(code)) : cdr(f_true); - la = (cond) ? opt3_pair(code) : cdar(f_true); /* cdadr(caddr(code)) */ - laa = cdr(la); - laa_slot = next_slot(la_slot); - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_LAA_Z); - op_tc_if_a_z_if_a_laa_z(sc, false, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_LAA_Z); - op_tc_if_a_z_if_a_laa_z(sc, true, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cdr(code); - s7_pointer endp, la_slot = let_slots(sc->curlet); - s7_pointer if_true = cdr(if_test); - s7_pointer if_false = cadr(if_true); - s7_pointer f_test = cdr(if_false); - s7_pointer f_true = cdr(f_test); - s7_pointer f_false = cdr(f_true); - s7_pointer la1 = cdar(f_true); - s7_pointer la2 = cdar(f_false); - s7_pointer laa1 = cdr(la1); - s7_pointer laa2 = cdr(la2); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a1 = cdr(laa1); - s7_pointer l3a2 = cdr(laa2); - s7_pointer l3a_slot = next_slot(laa_slot); - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) - { - sc->rec_p1 = fx_call(sc, la1); - sc->rec_p2 = fx_call(sc, laa1); - slot_set_value(l3a_slot, fx_call(sc, l3a1)); - } - else - { - sc->rec_p1 = fx_call(sc, la2); - sc->rec_p2 = fx_call(sc, laa2); - slot_set_value(l3a_slot, fx_call(sc, l3a2)); - } - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); - op_tc_if_a_z_if_a_l3a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static bool op_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer body = caddr(code); - s7_pointer outer_let = sc->curlet; - s7_pointer la_slot = let_slots(outer_let); - s7_pointer if_test = cdr(body); - s7_pointer if_true = cddr(body); - s7_pointer if_false = cadddr(body); - s7_pointer la = cdr(if_false); - s7_pointer let_var = caadr(code); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cdr(let_var); - - while (fx_call(sc, if_test) == sc->F) - { - slot_set_value(la_slot, fx_call(sc, la)); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - } - unstack(sc); - if (!op_tc_z(sc, if_true)) - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); -} - -static s7_pointer fx_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_IF_A_Z_LA); - op_tc_let_if_a_z_la(sc, arg); - return(sc->value); -} - -static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer body = caddr(code); - s7_pointer outer_let = sc->curlet; - s7_pointer la_slot = let_slots(outer_let); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer if_test = cdr(body); - s7_pointer if_true = cddr(body); - s7_pointer if_false = cadddr(body); - s7_pointer la = cdr(if_false); - s7_pointer laa = cddr(if_false); - s7_pointer let_var = caadr(code); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cdr(let_var); -#if (!WITH_GMP) - if (!no_bool_opt(code)) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0]; - opt_info *o1 = sc->opts[sc->pc], *o2, *o3; - if ((is_t_integer(slot_value(la_slot))) && - (is_t_integer(slot_value(laa_slot)))) - { - if (int_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (int_optimize(sc, laa)) - { - o3 = sc->opts[sc->pc]; - set_curlet(sc, outer_let); - if (int_optimize(sc, let_var)) - { - s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); - s7_pointer val2 = make_mutable_integer(sc, integer(slot_value(laa_slot))); - s7_pointer val3 = make_mutable_integer(sc, integer(slot_value(let_slot))); - set_curlet(sc, inner_let); - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2); - slot_set_value(let_slot, val3); - while (!(o->v[0].fb(o))) - { - s7_int i1 = o1->v[0].fi(o1); - integer(val2) = o2->v[0].fi(o2); - integer(val1) = i1; - integer(val3) = o3->v[0].fi(o3); - } - unstack(sc); - if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */ - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); - }}}}} - set_no_bool_opt(code); - } -#endif - while (fx_call(sc, if_test) == sc->F) - { - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - } - unstack(sc); - if (!op_tc_z(sc, if_true)) - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); -} - -static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_IF_A_Z_LAA); - op_tc_let_if_a_z_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code) -{ - s7_pointer p, body = caddr(code), la, laa, let_var = caadr(code), outer_let = sc->curlet; - s7_pointer if_test = cdr(body); - s7_pointer if_true = cddr(body); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cdr(let_var); - - for (p = if_true; is_pair(cdr(p)); p = cdr(p)); - la = cdar(p); - laa = cddar(p); - if ((car(la) == slot_symbol(let_slots(outer_let))) && - (car(laa) == slot_symbol(next_slot(let_slots(outer_let))))) - { - if ((cdr(if_true) == p) && (!when)) - { - s7_pointer a1 = slot_value(let_slots(outer_let)); - s7_pointer a2 = slot_value(next_slot(let_slots(outer_let))); - if ((is_input_port(a1)) && (is_output_port(a2)) && (is_string_port(a1)) && (is_file_port(a2)) && - (!port_is_closed(a1)) && (!port_is_closed(a2)) && (fx_proc(if_true) == fx_c_tU_direct) && - (fx_proc(let_var) == fx_c_t_direct) && (((s7_p_pp_t)opt3_direct(cdar(if_true))) == write_char_p_pp) && - (((s7_p_p_t)opt2_direct(cdar(let_var))) == read_char_p_p) && (fx_proc(if_test) == fx_is_eof_t)) - { - int32_t c = (int32_t)s7_character(slot_value(let_slots(inner_let))); - a1 = slot_value(let_slots(outer_let)); - a2 = slot_value(next_slot(let_slots(outer_let))); - while (c != EOF) - { - inline_file_write_char(sc, (uint8_t)c, a2); - c = string_read_char(sc, a1); - }} - else - while (fx_call(sc, if_test) == sc->F) - { - fx_call(sc, if_true); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} - else - while (true) - { - p = fx_call(sc, if_test); - if (when) {if (p == sc->F) break;} else {if (p != sc->F) break;} - for (p = if_true; is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} - else - { - s7_pointer la_slot = let_slots(outer_let); - s7_pointer laa_slot = next_slot(la_slot); - while (true) - { - p = fx_call(sc, if_test); - if (when) {if (p == sc->F) break;} else {if (p != sc->F) break;} - for (p = if_true; is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} - unstack(sc); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - sc->value = sc->unspecified; -} - -static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_WHEN_LAA); - op_tc_let_when_laa(sc, true, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_WHEN_LAA); - op_tc_let_when_laa(sc, false, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if1_test = cdr(code), endp, outer_let = sc->curlet, slot, var, la_slot = let_slots(sc->curlet); - s7_pointer if1_true = cdr(if1_test); /* cddr(code) */ - s7_pointer let_expr = cadr(if1_true); /* cadddr(code) */ - s7_pointer let_vars = cadr(let_expr); - s7_pointer if2 = caddr(let_expr); - s7_pointer if2_test = cdr(if2); - s7_pointer if2_true = cdr(if2_test); /* cddr(if2) */ - s7_pointer la = cdadr(if2_true); /* cdr(cadddr(if2)) */ - s7_pointer laa = cdr(la); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer inner_let = inline_make_let(sc, sc->curlet); - - s7_gc_protect_via_stack(sc, inner_let); - slot = make_slot(sc, caar(let_vars), sc->F); - slot_set_next(slot, slot_end(sc)); - let_set_slots(inner_let, slot); - symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let), slot); - for (var = cdr(let_vars); is_pair(var); var = cdr(var)) - slot = inline_add_slot_at_end(sc, let_id(inner_let), slot, caar(var), sc->F); - - while (true) - { - if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} - slot = let_slots(inner_let); - slot_set_value(slot, fx_call(sc, cdar(let_vars))); - set_curlet(sc, inner_let); - for (var = cdr(let_vars), slot = next_slot(slot); is_pair(var); var = cdr(var), slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, cdar(var))); - - if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - } - sc->rec_p1 = sc->unused; - unstack(sc); - if (!op_tc_z(sc, endp)) /* might refer to inner_let slots */ - return(false); - free_cell(sc, let_slots(inner_let)); /* true = has_fx, so we should be done with the let */ - free_cell(sc, inner_let); - return(true); -} - -static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) -{ - bool read_case; - s7_pointer result; - s7_pointer outer_let = sc->curlet; - s7_pointer slots = let_slots(outer_let); - s7_pointer cond_body = cdaddr(code); /* code here == body in check_tc */ - s7_pointer let_var = caadr(code); - s7_function letf = fx_proc(cdr(let_var)); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cadr(let_var); - if ((letf == fx_c_s_direct) && /* an experiment */ - (symbol_id(cadr(let_var)) != let_id(outer_let))) /* i.e. not an argument to the recursive function, and not set! (safe closure body) */ - { - letf = (s7_p_p_t)opt2_direct(cdr(let_var)); - let_var = lookup(sc, cadr(let_var)); - } - /* in the named let no-var case slots may contain the let name (it's the funclet) */ - - if (opt3_arglen(cdr(code)) == 0) /* (loop) etc -- no args */ - while (true) - { - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); - set_curlet(sc, inner_let); - break; - }} - else - if (opt3_arglen(cdr(code)) == 1) - while (true) - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); /* inner let var */ - set_curlet(sc, inner_let); - break; - } - - let_set_has_pending_value(outer_let); - read_case = ((letf == read_char_p_p) && (is_input_port(let_var)) && (is_string_port(let_var)) && (!port_is_closed(let_var))); - while (true) - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - for (s7_pointer slot = slots, arg = cdar(result); is_pair(arg); slot = next_slot(slot), arg = cdr(arg)) - slot_simply_set_pending_value(slot, fx_call(sc, arg)); - for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */ - slot_set_value(slot, slot_pending_value(slot)); - - if (read_case) - slot_set_value(let_slot, chars[string_read_char(sc, let_var)]); - else - { - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); - set_curlet(sc, inner_let); - } - break; - } - let_clear_has_pending_value(outer_let); - - TC_LET_COND_DONE: - unstack(sc); - if (has_fx(result)) - { - sc->value = fx_call(sc, result); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); - } - sc->code = car(result); - return(false); -} - -static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_COND); - op_tc_let_cond(sc, arg); - return(sc->value); -} - -static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer c1 = cadr(code), c2 = caddr(code), la_slot = let_slots(sc->curlet); - s7_pointer la1 = cdadr(c2); - s7_pointer laa1 = cddadr(c2); - s7_pointer c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */ - s7_pointer la2 = cdr(c3); - s7_pointer laa2 = cddr(c3); - s7_pointer laa_slot = next_slot(la_slot); - while (true) - { - if (fx_call(sc, c1) != sc->F) {c1 = cdr(c1); break;} - if (fx_call(sc, c2) != sc->F) - { - sc->rec_p1 = fx_call(sc, la1); - slot_set_value(laa_slot, fx_call(sc, laa1)); - } - else - { - sc->rec_p1 = fx_call(sc, la2); - slot_set_value(laa_slot, fx_call(sc, laa2)); - } - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, c1)); -} - -static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_LAA_LAA); - op_tc_cond_a_z_a_laa_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - - -#define RECUR_INITIAL_STACK_SIZE 1024 - -static void recur_resize(s7_scheme *sc) -{ - s7_pointer stack = sc->rec_stack; - block_t *ob, *nb; - vector_length(stack) = sc->rec_len * 2; - ob = vector_block(stack); - nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_pointer)); - block_info(nb) = NULL; - vector_block(stack) = nb; - vector_elements(stack) = (s7_pointer *)block_data(nb); /* GC looks only at elements within sc->rec_loc */ - sc->rec_len = vector_length(stack); - sc->rec_els = vector_elements(stack); -} - -static inline void recur_push(s7_scheme *sc, s7_pointer value) -{ - if (sc->rec_loc == sc->rec_len) - recur_resize(sc); - sc->rec_els[sc->rec_loc] = value; - sc->rec_loc++; -} - -static inline void recur_push_unchecked(s7_scheme *sc, s7_pointer value) {sc->rec_els[sc->rec_loc++] = value;} -static s7_pointer recur_pop(s7_scheme *sc) {return(sc->rec_els[--sc->rec_loc]);} -static s7_pointer recur_ref(s7_scheme *sc, s7_int loc) {return(sc->rec_els[sc->rec_loc - loc]);} - -static s7_pointer recur_pop2(s7_scheme *sc) -{ - sc->rec_loc -= 2; - return(sc->rec_els[sc->rec_loc + 1]); -} - -static s7_pointer recur_swap(s7_scheme *sc, s7_pointer value) -{ - s7_pointer res = sc->rec_els[sc->rec_loc - 1]; - sc->rec_els[sc->rec_loc - 1] = value; - return(res); -} - -static s7_pointer recur_make_stack(s7_scheme *sc) -{ - if (!sc->rec_stack) - { - sc->rec_stack = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE); - sc->rec_els = vector_elements(sc->rec_stack); - sc->rec_len = RECUR_INITIAL_STACK_SIZE; - } - sc->rec_loc = 0; - return(sc->rec_stack); -} - -static void rec_set_test(s7_scheme *sc, s7_pointer p) -{ - sc->rec_testp = p; - sc->rec_testf = fx_proc(sc->rec_testp); - sc->rec_testp = car(sc->rec_testp); -} - -static void rec_set_res(s7_scheme *sc, s7_pointer p) -{ - sc->rec_resp = p; - sc->rec_resf = fx_proc(sc->rec_resp); - sc->rec_resp = car(sc->rec_resp); -} - -static void rec_set_f1(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f1p = p; - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); -} - -static void rec_set_f2(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f2p = p; - sc->rec_f2f = fx_proc(sc->rec_f2p); - sc->rec_f2p = car(sc->rec_f2p); -} - -static void rec_set_f3(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f3p = p; - sc->rec_f3f = fx_proc(sc->rec_f3p); - sc->rec_f3p = car(sc->rec_f3p); -} - -static void rec_set_f4(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f4p = p; - sc->rec_f4f = fx_proc(sc->rec_f4p); - sc->rec_f4p = car(sc->rec_f4p); -} - -static void rec_set_f5(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f5p = p; - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); -} - -static void rec_set_f6(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f6p = p; - sc->rec_f6f = fx_proc(sc->rec_f6p); - sc->rec_f6p = car(sc->rec_f6p); -} - -/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ -typedef enum {OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0} opt_pid_t; - -static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_pointer code) -{ - s7_pointer caller = opt3_pair(code); /* false_p in check_recur */ -#if (!WITH_GMP) - s7_pointer c_op = car(caller); - if ((is_symbol(c_op)) && - ((is_global(c_op)) || - ((is_slot(global_slot(c_op))) && - (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) - { - s7_pointer s_func = global_value(c_op), slot = let_slots(sc->curlet); - if (is_c_function(s_func)) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cdr(code))) - { - int32_t start_pc = sc->pc; - sc->rec_result_o = sc->opts[start_pc]; - if (is_t_integer(slot_value(slot))) - { - sc->rec_i_ii_f = s7_i_ii_function(s_func); - if ((sc->rec_i_ii_f) && - (int_optimize(sc, (a_op) ? cddr(code) : cdddr(code)))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* cdadr? */ - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - return(OPT_INT); - }}}}}}} -#endif - rec_set_test(sc, cdr(code)); - rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code)); - rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); - return(OPT_PTR); -} - -static s7_int oprec_i_if_a_a_opa_laq(s7_scheme *sc) -{ - s7_int i1; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - return(sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc))); -} - -static s7_int oprec_i_if_a_opa_laq_a(s7_scheme *sc) -{ - s7_int i1; - if (!sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - return(sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc))); -} - -static s7_pointer oprec_if_a_a_opa_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_2, oprec_if_a_a_opa_laq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_a_opla_aq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_1, oprec_if_a_a_opla_aq(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_opa_laq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_2, oprec_if_a_opa_laq_a(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_opla_aq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_1, oprec_if_a_opla_aq_a(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static void wrap_recur_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op) -{ - opt_pid_t choice = opinit_if_a_a_opa_laq(sc, a_op, la_op, sc->code); - tick_tc(sc, sc->cur_op); - if (choice == OPT_INT) - sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opa_laq(sc) : oprec_i_if_a_opa_laq_a(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - if (a_op) - sc->value = (la_op) ? oprec_if_a_a_opa_laq(sc) : oprec_if_a_a_opla_aq(sc); - else sc->value = (la_op) ? oprec_if_a_opa_laq_a(sc) : oprec_if_a_opla_aq_a(sc); - sc->rec_loc = 0; - } -} - -static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq); - if (opinit_if_a_a_opa_laq(sc, true, true, arg) == OPT_INT) - sc->value = make_integer(sc, oprec_i_if_a_a_opa_laq(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - sc->value = oprec_if_a_a_opa_laq(sc); - sc->rec_loc = 0; - } - return(sc->value); -} - -static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_IF_A_opA_LAq_A); - if (opinit_if_a_a_opa_laq(sc, false, true, arg) == OPT_INT) - sc->value = make_integer(sc, oprec_i_if_a_opa_laq_a(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - sc->value = oprec_if_a_opa_laq_a(sc); - sc->rec_loc = 0; - } - return(sc->value); -} - -/* -------- cond_a_a_opa_laq -------- */ -static void opinit_cond_a_a_opa_laq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer op_recur_cond_a_a_opa_laq(s7_scheme *sc) -{ - opinit_cond_a_a_opa_laq(sc); - return(oprec_if_a_a_opa_laq(sc)); -} - -/* -------- if_a_a_opa_laaq and if_a_opa_laaq_a and cond_a_a_opa_laaq -------- */ -enum {IF1A_LA2, IF2A_LA2, COND2A_LA2}; - -static void opinit_if_a_a_opa_laaq(s7_scheme *sc, int32_t a_op) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, (a_op == COND2A_LA2) ? cadr(sc->code) : cdr(sc->code)); - rec_set_res(sc, (a_op == IF2A_LA2) ? cddr(sc->code) : ((a_op == IF1A_LA2) ? cdddr(sc->code) : cdadr(sc->code))); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - rec_set_f3(sc, cddr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_if_a_a_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_if_a_opa_laaq_a(sc)); - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_if_a_a_opa_laaq(s7_scheme *sc) -{ - opinit_if_a_a_opa_laaq(sc, IF2A_LA2); - return(oprec_if_a_a_opa_laaq(sc)); -} - -static s7_pointer op_recur_if_a_opa_laaq_a(s7_scheme *sc) -{ - opinit_if_a_a_opa_laaq(sc, IF1A_LA2); - return(oprec_if_a_opa_laaq_a(sc)); -} - -static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme *sc) -{ - opinit_if_a_a_opa_laaq(sc, COND2A_LA2); - return(oprec_if_a_a_opa_laaq(sc)); -} - - -/* -------- if_a_a_opa_l3aq -------- */ -static void opinit_if_a_a_opa_l3aq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code), l3a = cdr(opt3_pair(caller)); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, cddr(sc->code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, l3a); - rec_set_f3(sc, cdr(l3a)); - rec_set_f4(sc, cddr(l3a)); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_slot3 = next_slot(sc->rec_slot2); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc) -{ - opinit_if_a_a_opa_l3aq(sc); - return(oprec_if_a_a_opa_l3aq(sc)); -} - -/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ -static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) -{ - s7_pointer caller = opt3_pair(sc->code); -#if (!WITH_GMP) - s7_pointer c_op = car(caller); - if ((is_symbol(c_op)) && - ((is_global(c_op)) || - ((is_slot(global_slot(c_op))) && - (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) - { - s7_pointer s_func = global_value(c_op); - s7_pointer slot = let_slots(sc->curlet); - if (is_c_function(s_func)) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cdr(sc->code))) - { - int32_t start_pc = sc->pc; - sc->rec_result_o = sc->opts[start_pc]; - if (is_t_integer(slot_value(slot))) - { - sc->rec_i_ii_f = s7_i_ii_function(s_func); - if ((sc->rec_i_ii_f) && - (int_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(caller))) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - if (sc->pc != 4) - return(OPT_INT); - sc->rec_fb1 = sc->rec_test_o->v[0].fb; - sc->rec_fi1 = sc->rec_result_o->v[0].fi; - sc->rec_fi2 = sc->rec_a1_o->v[0].fi; - sc->rec_fi3 = sc->rec_a2_o->v[0].fi; - return(OPT_INT_0); - }}}} - if (is_t_real(slot_value(slot))) - { - sc->rec_d_dd_f = s7_d_dd_function(s_func); - if (sc->rec_d_dd_f) - { - sc->pc = start_pc; - sc->rec_result_o = sc->opts[start_pc]; - if (float_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (float_optimize(sc, cdadr(caller))) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = s7_make_mutable_real(sc, real(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - return(OPT_DBL); - }}}}}}}} -#endif - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); - rec_set_f1(sc, cdadr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); - return(OPT_PTR); -} - -static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */ - return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */ - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */ - i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ - integer(sc->rec_val1) = i1; /* slot1 = a1 */ - return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */ -} - -static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - i1 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - if (sc->rec_fb1(sc->rec_test_o)) - i2 = sc->rec_fi1(sc->rec_result_o); - else - { - s7_int i3; - i2 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - i3 = oprec_i_if_a_a_opla_laq_0(sc); - integer(sc->rec_val1) = i2; - i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3); - } - integer(sc->rec_val1) = i1; - return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2)); -} - -static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) -{ - s7_double x1, x2; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); - x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) - x2 = sc->rec_result_o->v[0].fd(sc->rec_result_o); - else - { - s7_double x3; - x2 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - x3 = oprec_d_if_a_a_opla_laq(sc); - real(sc->rec_val1) = x2; - x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3); - } - real(sc->rec_val1) = x1; - return(sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2)); -} - -static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opla_laq(sc))); - set_car(sc->t2_1, oprec_if_a_a_opla_laq(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) -{ - s7_int i1, i2; - if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - i2 = oprec_i_if_a_opla_laq_a(sc); - integer(sc->rec_val1) = i1; - return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2)); -} - -static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc) -{ - s7_int i1, i2; - if (!sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - i1 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - if (!sc->rec_fb1(sc->rec_test_o)) - i2 = sc->rec_fi1(sc->rec_result_o); - else - { - s7_int i3; - i2 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - i3 = oprec_i_if_a_opla_laq_a_0(sc); - integer(sc->rec_val1) = i2; - i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3); - } - integer(sc->rec_val1) = i1; - return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2)); -} - -static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) -{ - s7_double x1, x2; - if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); - x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - x2 = oprec_d_if_a_opla_laq_a(sc); - real(sc->rec_val1) = x1; - return(sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2)); -} - -static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_opla_laq_a(sc))); - set_car(sc->t2_1, oprec_if_a_opla_laq_a(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op) -{ - opt_pid_t choice = opinit_if_a_a_opla_laq(sc, a_op); - tick_tc(sc, sc->cur_op); - if ((choice == OPT_INT) || (choice == OPT_INT_0)) - { - if (choice == OPT_INT_0) - sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc)); - else sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq(sc) : oprec_i_if_a_opla_laq_a(sc)); - } - else - if (choice == OPT_PTR) - { - sc->rec_stack = recur_make_stack(sc); - sc->value = (a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc); - sc->rec_loc = 0; - } - else sc->value = make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc)); -} - - -/* -------- if_a_a_opa_la_laq and if_a_opa_la_laq_a -------- */ -static void opinit_if_a_a_opa_la_laq(s7_scheme *sc, bool a_op) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdaddr(caller)); - rec_set_f3(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opa_la_laq(sc))); - set_car(sc->t3_2, oprec_if_a_a_opa_la_laq(sc)); - set_car(sc->t3_3, recur_pop(sc)); - set_car(sc->t3_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t3_1)); -} - -static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_opa_la_laq_a(sc))); - set_car(sc->t3_2, oprec_if_a_opa_la_laq_a(sc)); - set_car(sc->t3_3, recur_pop(sc)); - set_car(sc->t3_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t3_1)); -} - -static s7_pointer op_recur_if_a_a_opa_la_laq(s7_scheme *sc) -{ - opinit_if_a_a_opa_la_laq(sc, true); - return(oprec_if_a_a_opa_la_laq(sc)); -} - -static s7_pointer op_recur_if_a_opa_la_laq_a(s7_scheme *sc) -{ - opinit_if_a_a_opa_la_laq(sc, false); - return(oprec_if_a_opa_la_laq_a(sc)); -} - -/* -------- if_a_a_opla_la_laq -------- */ -static void opinit_if_a_a_opla_la_laq(s7_scheme *sc, bool a_op) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); - rec_set_f1(sc, cdadr(caller)); - rec_set_f2(sc, cdaddr(caller)); - rec_set_f3(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opla_la_laq(sc))); - recur_push(sc, oprec_if_a_a_opla_la_laq(sc)); - slot_set_value(sc->rec_slot1, recur_ref(sc, 3)); - set_car(sc->t3_1, oprec_if_a_a_opla_la_laq(sc)); - set_car(sc->t3_2, recur_pop(sc)); - set_car(sc->t3_3, recur_pop2(sc)); - return(sc->rec_fn(sc, sc->t3_1)); -} - -static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc) -{ - opinit_if_a_a_opla_la_laq(sc, true); - return(oprec_if_a_a_opla_la_laq(sc)); -} - -/* -------- if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -------- - * esteemed reader, please ignore this nonsense! - * The opt_info version was not a lot faster -- ~/old/tak-st.c: say 10% faster. The current fx-based - * version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor. - * The opt version has its own overheads, and has to do the same amount of stack manipulations. - */ -static s7_pointer rec_x(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot1));} -static s7_pointer rec_y(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot2));} -static s7_pointer rec_z(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot3));} -static s7_pointer rec_sub_z1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer x = slot_value(sc->rec_slot3); - return((is_t_integer(x)) ? make_integer(sc, integer(x) - 1) : minus_c1(sc, x)); -} - -static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - s7_pointer la1 = cadr(caller); - s7_pointer la2 = caddr(caller); - s7_pointer la3 = opt3_pair(caller); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, cddr(sc->code)); - rec_set_f1(sc, cdr(la1)); - rec_set_f2(sc, cddr(la1)); - if (sc->rec_f2f == fx_u) sc->rec_f2f = rec_y; - rec_set_f3(sc, cdddr(la1)); - rec_set_f4(sc, cdr(la2)); - rec_set_f5(sc, cddr(la2)); - rec_set_f6(sc, cdddr(la2)); - if (sc->rec_f6f == fx_t) sc->rec_f6f = rec_x; - - sc->rec_f7p = cdr(la3); - sc->rec_f7f = fx_proc(sc->rec_f7p); - sc->rec_f7p = car(sc->rec_f7p); - - sc->rec_f8p = cddr(la3); - sc->rec_f8f = fx_proc(sc->rec_f8p); - if (sc->rec_f8f == fx_t) sc->rec_f8f = rec_x; - sc->rec_f8p = car(sc->rec_f8p); - - sc->rec_f9p = cdddr(la3); - sc->rec_f9f = fx_proc(sc->rec_f9p); - if (sc->rec_f9f == fx_u) sc->rec_f9f = rec_y; - sc->rec_f9p = car(sc->rec_f9p); - - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_slot3 = next_slot(sc->rec_slot2); - if (cadddr(la1) == slot_symbol(sc->rec_slot3)) sc->rec_f3f = rec_z; - if (caddr(la2) == slot_symbol(sc->rec_slot3)) sc->rec_f5f = rec_z; - if ((sc->rec_f7f == fx_subtract_s1) && (cadadr(la3) == slot_symbol(sc->rec_slot3))) sc->rec_f7f = rec_sub_z1; -} - -static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p)); - recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p)); - recur_push(sc, sc->rec_f8f(sc, sc->rec_f8p)); - slot_set_value(sc->rec_slot3, sc->rec_f9f(sc, sc->rec_f9p)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); - slot_set_value(sc->rec_slot3, recur_ref(sc, 2)); - slot_set_value(sc->rec_slot2, recur_ref(sc, 3)); - slot_set_value(sc->rec_slot1, recur_ref(sc, 4)); - recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); - slot_set_value(sc->rec_slot3, recur_ref(sc, 6)); - slot_set_value(sc->rec_slot2, recur_ref(sc, 7)); - slot_set_value(sc->rec_slot1, recur_ref(sc, 8)); - slot_set_value(sc->rec_slot1, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot3, recur_pop(sc)); - sc->rec_loc -= 6; - return(oprec_if_a_a_lopl3a_l3a_l3aq(sc)); -} - -static s7_pointer op_recur_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -{ - opinit_if_a_a_lopl3a_l3a_l3aq(sc); - return(oprec_if_a_a_lopl3a_l3a_l3aq(sc)); -} - -/* -------- if_a_a_and_a_laa_laa -------- */ -static void opinit_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer caller = opt3_pair(code); - s7_pointer la1 = caddr(caller); - s7_pointer la2 = cadddr(caller); - rec_set_test(sc, cdr(code)); - rec_set_res(sc, cddr(code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdr(la1)); - rec_set_f3(sc, cddr(la1)); - rec_set_f4(sc, cdr(la2)); - rec_set_f5(sc, cddr(la2)); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); -} - -static s7_pointer oprec_if_a_a_and_a_laa_laa(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) == sc->F) return(sc->F); - recur_push(sc, slot_value(sc->rec_slot1)); - recur_push(sc, slot_value(sc->rec_slot2)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (oprec_if_a_a_and_a_laa_laa(sc) == sc->F) - { - sc->rec_loc -= 2; - return(sc->F); - } - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_if_a_a_and_a_laa_laa(sc)); -} - -static s7_pointer op_recur_if_a_a_and_a_laa_laa(s7_scheme *sc) -{ - opinit_if_a_a_and_a_laa_laa(sc, sc->code); - return(oprec_if_a_a_and_a_laa_laa(sc)); -} - -static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA); - /* sc->curlet is set already and will be restored by the caller */ - sc->rec_stack = recur_make_stack(sc); - opinit_if_a_a_and_a_laa_laa(sc, arg); - sc->value = oprec_if_a_a_and_a_laa_laa(sc); - sc->rec_loc = 0; - return(sc->value); -} - -/* -------- cond_a_a_a_a_opla_laq -------- */ -static void opinit_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer code, bool cond_case) -{ - s7_pointer caller = opt3_pair(code); - if (cond_case) - { - rec_set_test(sc, cadr(code)); - rec_set_res(sc, cdadr(code)); - rec_set_f1(sc, caddr(code)); - rec_set_f2(sc, cdaddr(code)); - } - else - { - rec_set_test(sc, cdr(code)); - rec_set_res(sc, cddr(code)); /* (if a b...) */ - rec_set_f1(sc, opt1_pair(code)); /* cdr(cadddr(code)), (if a b (if c d...)) */ - rec_set_f2(sc, cdr(opt1_pair(code))); - } - rec_set_f3(sc, cdadr(caller)); - rec_set_f4(sc, opt3_pair(caller)); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static inline s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme *sc) /* inline = 27 in trec */ -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_cond_a_a_a_a_opla_laq(sc))); - set_car(sc->t2_1, oprec_cond_a_a_a_a_opla_laq(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_opla_laq(sc, sc->code, true); - return(oprec_cond_a_a_a_a_opla_laq(sc)); -} - -static s7_pointer op_recur_if_a_a_if_a_a_opla_laq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_opla_laq(sc, sc->code, false); - return(oprec_cond_a_a_a_a_opla_laq(sc)); -} - -static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq); - sc->rec_stack = recur_make_stack(sc); - opinit_cond_a_a_a_a_opla_laq(sc, arg, true); - sc->value = oprec_cond_a_a_a_a_opla_laq(sc); - sc->rec_loc = 0; - return(sc->value); -} - - -/* -------- cond_a_a_a_a_oplaa_laaq -------- */ -static void opinit_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc, bool cond_case) -{ - s7_pointer caller = opt3_pair(sc->code); /* cadr(cadddr(sc->code)) = (cfunc laa laa) */ - if (cond_case) - { - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - rec_set_f1(sc, caddr(sc->code)); - rec_set_f2(sc, cdaddr(sc->code)); - } - else - { - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, cddr(sc->code)); /* (if a b...) */ - rec_set_f1(sc, opt1_pair(sc->code)); /* cdr(cadddr(sc->code)), (if a b (if c d...)) */ - rec_set_f2(sc, cdr(opt1_pair(sc->code))); - } - sc->rec_f3p = cdadr(caller); - rec_set_f4(sc, cdr(sc->rec_f3p)); - sc->rec_f3f = fx_proc(sc->rec_f3p); - sc->rec_f3p = car(sc->rec_f3p); - sc->rec_f5p = opt3_pair(caller); - rec_set_f6(sc, cdr(sc->rec_f5p)); - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - sc->value = oprec_cond_a_a_a_a_oplaa_laaq(sc); /* second laa arg */ - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push_unchecked(sc, sc->value); - set_car(sc->t2_1, oprec_cond_a_a_a_a_oplaa_laaq(sc)); /* first laa arg */ - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_oplaa_laaq(sc, true); - return(oprec_cond_a_a_a_a_oplaa_laaq(sc)); -} - -static s7_pointer op_recur_if_a_a_if_a_a_oplaa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_oplaa_laaq(sc, false); - return(oprec_cond_a_a_a_a_oplaa_laaq(sc)); -} - - -/* -------- cond_a_a_a_a_opa_laaq -------- */ -static void opinit_cond_a_a_a_a_opa_laaq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - sc->rec_f1p = caddr(sc->code); - rec_set_f2(sc, cdr(sc->rec_f1p)); - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); - rec_set_f3(sc, cdr(caller)); - rec_set_f4(sc, opt3_pair(caller)); - rec_set_f5(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_a_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_a_opa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_opa_laaq(sc); - return(oprec_cond_a_a_a_a_opa_laaq(sc)); -} - - -/* -------- cond_a_a_a_laa_opa_laaq -------- */ -static void opinit_cond_a_a_a_laa_opa_laaq(s7_scheme *sc, bool cond) -{ - s7_pointer caller = opt3_pair(sc->code); /* opA_LAA */ - rec_set_test(sc, (cond) ? cadr(sc->code) : cdr(sc->code)); - rec_set_res(sc, (cond) ? cdadr(sc->code) : cddr(sc->code)); - sc->rec_f1p = (cond) ? caddr(sc->code) : cdr(cadddr(sc->code)); - sc->rec_f2p = cdadr(sc->rec_f1p); - rec_set_f3(sc, cdr(sc->rec_f2p)); - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); - sc->rec_f2f = fx_proc(sc->rec_f2p); - sc->rec_f2p = car(sc->rec_f2p); - rec_set_f4(sc, cdr(caller)); - sc->rec_f5p = cdr(opt3_pair(caller)); /* (L)AA */ - rec_set_f6(sc, cdr(sc->rec_f5p)); - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); - sc->rec_fn = fn_proc(caller); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); -} - -static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) - { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ - } - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) - { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ - } - else - { - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_laa_opa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_laa_opa_laaq(sc, true); - return(oprec_cond_a_a_a_laa_opa_laaq(sc)); -} - -static s7_pointer op_recur_if_a_a_if_a_laa_opa_laaq(s7_scheme *sc) /* if version, same logic as cond above */ -{ - opinit_cond_a_a_a_laa_opa_laaq(sc, false); - return(oprec_cond_a_a_a_laa_opa_laaq(sc)); -} - -/* -------- cond_a_a_a_laa_lopa_laaq -------- */ - -static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - -#if (!WITH_GMP) - if ((is_t_integer(slot_value(sc->rec_slot1))) && - (is_t_integer(slot_value(sc->rec_slot2)))) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cadr(sc->code))) - { - sc->rec_result_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(sc->code))) - { - s7_pointer laa1 = caddr(sc->code); - sc->rec_a1_o = sc->opts[sc->pc]; - if (bool_optimize(sc, laa1)) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(laa1))) - { - sc->rec_a3_o = sc->opts[sc->pc]; - if (int_optimize(sc, cddadr(laa1))) - { - s7_pointer laa2 = cadr(cadddr(sc->code)), laa3 = caddr(laa2); - sc->rec_a4_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(laa2))) - { - sc->rec_a5_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(laa3))) - { - sc->rec_a6_o = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(laa3))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot1))); - slot_set_value(sc->rec_slot1, sc->rec_val1); - sc->rec_val2 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot2))); - slot_set_value(sc->rec_slot2, sc->rec_val2); - if (sc->pc != 8) - return(OPT_INT); - sc->rec_fb1 = sc->rec_test_o->v[0].fb; - sc->rec_fb2 = sc->rec_a1_o->v[0].fb; - sc->rec_fi1 = sc->rec_result_o->v[0].fi; - sc->rec_fi2 = sc->rec_a2_o->v[0].fi; - sc->rec_fi3 = sc->rec_a3_o->v[0].fi; - sc->rec_fi4 = sc->rec_a4_o->v[0].fi; - sc->rec_fi5 = sc->rec_a5_o->v[0].fi; - sc->rec_fi6 = sc->rec_a6_o->v[0].fi; - return(OPT_INT_0); - }}}}}}}}} -#endif - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - sc->rec_f1p = caddr(sc->code); - sc->rec_f2p = cdadr(sc->rec_f1p); - rec_set_f3(sc, cdr(sc->rec_f2p)); - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); - sc->rec_f2f = fx_proc(sc->rec_f2p); - sc->rec_f2p = car(sc->rec_f2p); - rec_set_f4(sc, cdr(caller)); - sc->rec_f5p = opt3_pair(caller); - rec_set_f6(sc, cdr(sc->rec_f5p)); - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); - return(OPT_PTR); -} - -static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) - { - i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); - } - i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o); - i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o); - integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o); - integer(sc->rec_val1) = i2; - integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); -} - -static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - if (sc->rec_fb2(sc->rec_a1_o)) - { - i1 = sc->rec_fi2(sc->rec_a2_o); - integer(sc->rec_val2) = sc->rec_fi3(sc->rec_a3_o); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); - } - i1 = sc->rec_fi4(sc->rec_a4_o); - i2 = sc->rec_fi5(sc->rec_a5_o); - integer(sc->rec_val2) = sc->rec_fi6(sc->rec_a6_o); - integer(sc->rec_val1) = i2; - integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); -} - -static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) - { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_cond_a_a_a_laa_lopa_laaq(sc)); - } - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - slot_set_value(sc->rec_slot2, oprec_cond_a_a_a_laa_lopa_laaq(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_cond_a_a_a_laa_lopa_laaq(sc)); -} - -static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - opt_pid_t choice = opinit_cond_a_a_a_laa_lopa_laaq(sc); - tick_tc(sc, sc->cur_op); - if (choice != OPT_PTR) - sc->value = make_integer(sc, (choice == OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - sc->value = oprec_cond_a_a_a_laa_lopa_laaq(sc); - sc->rec_loc = 0; - } -} - -/* -------- and_a_or_a_laa_laa -------- */ -static void opinit_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer orp = cdr(opt3_pair(code)); - rec_set_test(sc, cdr(code)); - rec_set_res(sc, orp); - rec_set_f1(sc, cdr(cadr(orp))); - rec_set_f2(sc, cddr(cadr(orp))); - rec_set_f3(sc, cdr(caddr(orp))); - rec_set_f4(sc, cddr(caddr(orp))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); -} - -static s7_pointer oprec_and_a_or_a_laa_laa(s7_scheme *sc) -{ - s7_pointer p; - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F); - p = sc->rec_resf(sc, sc->rec_resp); - if (p != sc->F) return(p); - recur_push(sc, slot_value(sc->rec_slot1)); - recur_push(sc, slot_value(sc->rec_slot2)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot2, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - p = oprec_and_a_or_a_laa_laa(sc); - if (p != sc->F) - { - sc->rec_loc -= 2; - return(p); - } - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot2, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_and_a_or_a_laa_laa(sc)); -} - -static s7_pointer op_recur_and_a_or_a_laa_laa(s7_scheme *sc) -{ - opinit_and_a_or_a_laa_laa(sc, sc->code); - return(oprec_and_a_or_a_laa_laa(sc)); -} - -static s7_pointer fx_recur_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_AND_A_OR_A_LAA_LAA); - sc->rec_stack = recur_make_stack(sc); - opinit_and_a_or_a_laa_laa(sc, arg); - sc->value = oprec_and_a_or_a_laa_laa(sc); - sc->rec_loc = 0; - return(sc->value); -} - -static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc)) -{ - tick_tc(sc, sc->cur_op); - sc->rec_stack = recur_make_stack(sc); - sc->value = recur(sc); - sc->rec_loc = 0; -} - - -/* -------------------------------- */ -static void op_safe_c_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_P_1); - sc->code = T_Pair(cadr(sc->code)); -} - -static void op_safe_c_p_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(sc->value));} - -static void op_safe_c_ssp(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1); - sc->code = opt3_pair(sc->code); -} - -static void op_safe_c_ssp_1(s7_scheme *sc) -{ - set_car(sc->t3_3, sc->value); - set_car(sc->t3_1, lookup(sc, cadr(sc->code))); - set_car(sc->t3_2, lookup(sc, caddr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->t3_1); -} - -static void op_safe_c_ssp_mv(s7_scheme *sc) -{ - sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_s(s7_scheme *sc) -{ - sc->code = lookup(sc, car(sc->code)); - if (!is_applicable(sc->code)) - apply_error_nr(sc, sc->code, sc->nil); - sc->args = sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */ -} - -static bool op_s_g(s7_scheme *sc) -{ - s7_pointer code = sc->code; - sc->code = lookup_checked(sc, car(code)); - if ((is_c_function(sc->code)) && - (c_function_min_args(sc->code) == 1) && - (!needs_copied_args(sc->code))) - { - sc->value = c_function_call(sc->code)(sc, with_list_t1((is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code))); - return(true); /* continue */ - } - if (!is_applicable(sc->code)) - apply_error_nr(sc, sc->code, cdr(code)); - if (dont_eval_args(sc->code)) - sc->args = cdr(code); - else - { - s7_pointer val = (is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code); - sc->args = (needs_copied_args(sc->code)) ? list_1(sc, val) : set_plist_1(sc, val); - } - return(false); -} - -static bool op_x_a(s7_scheme *sc, s7_pointer f) -{ - if ((((type(f) == T_C_FUNCTION) && - (c_function_is_aritable(f, 1))) || - ((type(f) == T_C_RST_NO_REQ_FUNCTION) && - (c_function_max_args(f) >= 1) && - (f != initial_value(sc->hash_table_symbol)) && - (f != initial_value(sc->weak_hash_table_symbol)))) && - (!needs_copied_args(f))) - { - sc->value = c_function_call(f)(sc, with_list_t1(fx_call(sc, cdr(sc->code)))); - return(true); - } - if (is_any_vector(f)) - { - sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); - sc->code = f; - apply_vector(sc); - return(true); - } - if (!is_applicable(f)) - apply_error_nr(sc, f, cdr(sc->code)); - if (dont_eval_args(f)) - sc->args = cdr(sc->code); /* list_1(sc, cadr(sc->code)); */ - else - if (!needs_copied_args(f)) - sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); - else - { - sc->args = fx_call(sc, cdr(sc->code)); - sc->args = list_1(sc, sc->args); - } - sc->code = f; - return(false); /* goto APPLY */ -} - -static void op_x_aa(s7_scheme *sc, s7_pointer f) -{ - s7_pointer code = sc->code; - if (!is_applicable(f)) - apply_error_nr(sc, f, cdr(code)); - if (dont_eval_args(f)) - sc->args = list_2(sc, cadr(code), caddr(code)); - else - { - sc->args = fx_call(sc, cddr(code)); - if (!needs_copied_args(f)) - sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args); - else sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); - } - sc->code = f; -} - -static void op_p_s_1(s7_scheme *sc) -{ - /* we get multiple values here (from op calc = "p" not "s") but don't need to handle it ourselves: - * let v be #(#_abs), so ((v 0) -2), (v 0 -2), ((values v 0) -2), and (((values v 0)) -2) are all 2 - * or: (define (f1) (values vector-ref (vector 1 2 3))) (define arg 1) (define (f2) ((f1) arg)) (f2) (f2) - * so apply calls apply_pair which handles multiple values explicitly. - */ - if (dont_eval_args(sc->value)) - sc->args = cdr(sc->code); - else - { - sc->args = lookup_checked(sc, cadr(sc->code)); - sc->args = (needs_copied_args(sc->value)) ? list_1(sc, sc->args) : set_plist_1(sc, sc->args); - } - sc->code = sc->value; /* goto APPLY */ -} - -static void op_safe_c_star_na(s7_scheme *sc) -{ - sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); - for (s7_pointer args = cdr(sc->code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - sc->code = opt1_cfunc(sc->code); - apply_c_function_star(sc); - clear_list_in_use(sc->args); -} - -static void op_safe_c_star(s7_scheme *sc) -{ - sc->code = opt1_cfunc(sc->code); - apply_c_function_star_fill_defaults(sc, 0); -} - -static void op_safe_c_star_a(s7_scheme *sc) -{ - sc->args = fx_call(sc, cdr(sc->code)); - if (is_symbol_and_keyword(sc->args)) /* (blocks3 (car (list :asdf))) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: keyword ~S, but no value: ~S", 32), car(sc->code), sc->args, sc->code)); - /* scheme-level define* here also gives "not a parameter name" */ - sc->args = list_1(sc, sc->args); - sc->code = opt1_cfunc(sc->code); - /* one arg, so it's not a keyword; all we need to do is fill in the defaults */ - apply_c_function_star_fill_defaults(sc, 1); -} - -static void op_safe_c_star_aa(s7_scheme *sc) -{ - sc->args = fx_call(sc, cdr(sc->code)); - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, sc->args); - sc->args = sc->t2_1; - sc->code = opt1_cfunc(sc->code); - apply_c_function_star(sc); -} - - -static void op_safe_c_ps(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_SAFE_C_PS_1); /* got to wait in this case */ - sc->code = cadr(sc->code); -} - -static void op_safe_c_ps_1(s7_scheme *sc) -{ - set_car(sc->t2_2, lookup(sc, caddr(sc->code))); - set_car(sc->t2_1, sc->value); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static void op_safe_c_ps_mv(s7_scheme *sc) /* (define (hi a) (+ (values 1 2) a)) from safe_c_ps_1 */ -{ - sc->args = pair_append(sc, sc->value, list_1(sc, lookup(sc, caddr(sc->code)))); /* don't assume sc->value can be used as sc->args here! */ - sc->code = c_function_base(opt1_cfunc(sc->code)); - /* we know it's a c function here, but there are 3 choices (c_function, c_function_star, no_rst_no_req_function) - * sc->value = fn_proc(sc->code)(sc, sc->args) might not check argnum - */ -} - -static void op_safe_c_sp(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - check_stack_size(sc); - push_stack(sc, (opcode_t)opt1_any(args), lookup(sc, car(args)), sc->code); - sc->code = cadr(args); -} - -static void op_safe_c_sp_1(s7_scheme *sc) -{ - /* we get here from many places (op_safe_c_sp for example), but all are safe */ - sc->value = fn_proc(sc->code)(sc, with_list_t2(sc->args, sc->value)); -} - -static void op_safe_c_sp_mv(s7_scheme *sc) -{ - sc->args = cons(sc, sc->args, sc->value); /* not ulist */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_add_sp_1(s7_scheme *sc) -{ - if ((is_t_integer(sc->args)) && (is_t_integer(sc->value))) - sc->value = add_if_overflow_to_real_or_big_integer(sc, integer(sc->args), integer(sc->value)); - else sc->value = add_p_pp(sc, sc->args, sc->value); -} - -static void op_safe_multiply_sp_1(s7_scheme *sc) -{ - if ((is_t_real(sc->args)) && (is_t_real(sc->value))) - sc->value = make_real(sc, real(sc->args) * real(sc->value)); - else sc->value = multiply_p_pp(sc, sc->args, sc->value); -} - -static void op_safe_c_pc(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - check_stack_size(sc); /* b dyn */ - push_stack(sc, OP_SAFE_C_PC_1, opt3_con(args), sc->code); - sc->code = car(args); -} - -static void op_safe_c_pc_mv(s7_scheme *sc) -{ - sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); /* not plist! sc->value is not reusable */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_c_pc_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t2(sc->value, sc->args));} - -static void op_safe_c_cp(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - /* it's possible in a case like this to overflow the stack -- s7test has a deeply - * nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cp -- if we're close - * to the stack end at the start, it runs off the end. Normally the stack increase in - * the reader protects us, but a call/cc can replace the original stack with a much smaller one. - */ - check_stack_size(sc); - push_stack(sc, (opcode_t)opt1_any(args), opt3_any(args), sc->code); /* to safe_add_sp_1 for example */ - sc->code = cadr(args); -} - -static Inline void inline_op_safe_c_s(s7_scheme *sc) /* called twice in eval c/cl_s many hits */ -{ - sc->value = fn_proc(sc->code)(sc, with_list_t1(lookup(sc, cadr(sc->code)))); -} -/* if op_safe_c_t added and set in fx_tree_in, we get a few hits, but nothing significant. - * if that had worked, it would be interesting to set opt1(cdr) to the fx_tree fx_proc, (init to fx_c_s), then call that here. - * opt1(cdr) is not used here, opt3_byte happens a few times, but opt2_direct clobbers opt2_fx sometimes - * (also need fx_annotate cdr(expr) in optimize_c_function_one_arg) - */ - -static Inline void inline_op_safe_c_ss(s7_scheme *sc) /* called twice in eval c/cl_ss many hits */ -{ - sc->value = fn_proc(sc->code)(sc, with_list_t2(lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(cdr(sc->code))))); -} - -static void op_safe_c_sc(s7_scheme *sc) -{ - sc->value = fn_proc(sc->code)(sc, with_list_t2(lookup(sc, cadr(sc->code)), opt2_con(cdr(sc->code)))); -} - -static void op_cl_a(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(fx_call(sc, cdr(sc->code))));} - -static inline void op_cl_aa(s7_scheme *sc) -{ - gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, T_Ext(stack_protected1(sc))); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static void op_cl_fa(s7_scheme *sc) -{ - s7_pointer code = cdadr(sc->code); - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, make_closure_gc_checked(sc, car(code), cdr(code), T_CLOSURE | ((is_symbol(car(code))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET)); - /* arg1 lambda can be any arity, but it must be applicable to one arg (the "a" above) */ - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static inline void op_map_for_each_fa(s7_scheme *sc) -{ - s7_pointer f = cddr(sc->code), code = sc->code; - sc->value = fx_call(sc, f); - if (is_null(sc->value)) - sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; - else - { - sc->code = opt3_pair(code); /* cdadr(code); */ - f = make_closure_gc_checked(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 1); /* arity=1 checked in optimizer */ - sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure(sc, f, sc->value) : g_map_closure(sc, f, sc->value); - } -} - -static void op_map_for_each_faa(s7_scheme *sc) -{ - s7_pointer f = cddr(sc->code), code = sc->code; - sc->value = fx_call(sc, f); - sc->args = fx_call(sc, cdr(f)); - if ((is_null(sc->value)) || (is_null(sc->args))) - sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; - else - { - sc->code = opt3_pair(code); /* cdadr(code); */ - f = make_closure_gc_checked(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 2); /* arity=2 checked in optimizer */ - sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure_2(sc, f, sc->value, sc->args) : g_map_closure_2(sc, f, sc->value, sc->args); - } -} - -static void op_cl_na(s7_scheme *sc) -{ - s7_pointer val = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); - if (in_heap(val)) gc_protect_via_stack(sc, val); - for (s7_pointer args = cdr(sc->code), p = val; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - sc->value = fn_proc(sc->code)(sc, val); - if (!in_heap(val)) - clear_list_in_use(val); - else - /* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */ - if (main_stack_op(sc) == OP_GC_PROTECT) - unstack(sc); -} - -static void op_cl_sas(s7_scheme *sc) -{ - set_car(sc->t3_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t3_1, lookup(sc, cadr(sc->code))); - set_car(sc->t3_3, lookup(sc, cadddr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->t3_1); -} - -static inline void op_safe_c_pp(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - check_stack_size(sc); - /* has_fx check here is slower, we assume car(args) below is a pair (else cp/sp/ap?) */ - if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) - { - sc->args = fx_proc_unchecked(args)(sc, car(args)); - push_stack_direct(sc, (opcode_t)opt1_any(args)); /* args = first value, func(args, value) if no mv */ - sc->code = cadr(args); - } - else - { - push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */ - sc->code = car(args); - } -} - -static void op_safe_c_pp_1(s7_scheme *sc) -{ - /* it is much slower to check has_gx here! */ - push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), sc->value, sc->code); /* args[i.e. sc->value] = first value, func(args, value) if no mv */ - sc->code = caddr(sc->code); -} - -static void op_safe_c_pp_3_mv(s7_scheme *sc) -{ - /* we get here if the first arg returned multiple values */ - push_stack(sc, OP_SAFE_C_PP_5, copy_proper_list(sc, sc->value), sc->code); /* copy is needed here */ - sc->code = caddr(sc->code); -} - -static void op_safe_c_pp_5(s7_scheme *sc) -{ - /* 1 mv, 2 normal (else mv->6), sc->args was copied above (and this is a safe c function so its args are in no danger) */ - if (is_null(sc->args)) - sc->args = list_1(sc, sc->value); /* plist here and below, but this is almost never called */ - else - { - s7_pointer p; - for (p = sc->args; is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, list_1(sc, sc->value)); - } - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_c_pp_6_mv(s7_scheme *sc) /* both args mv */ -{ - s7_pointer p; - for (p = cdr(sc->args); is_pair(cdr(p)); p = cdr(p)); /* we used to copy here: sc->args = pair_append(sc, sc->args, sc->value); */ - set_cdr(p, sc->value); - /* fn_proc(sc->code) here is g_add_2, but we have any number of args from a values call - * the original (unoptimized) function is c_function_base(opt1_cfunc(sc->code)) - * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 - */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_c_3p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_3P_1); - sc->code = cadr(sc->code); -} - -static void op_safe_c_3p_1(s7_scheme *sc) -{ - sc->args = sc->value; /* possibly fx/gx? and below */ - push_stack_direct(sc, OP_SAFE_C_3P_2); - sc->code = caddr(sc->code); -} - -static void op_safe_c_3p_1_mv(s7_scheme *sc) /* here only if sc->value is mv */ -{ - sc->args = sc->value; - push_stack_direct(sc, OP_SAFE_C_3P_2_MV); - sc->code = caddr(sc->code); -} - -static void op_safe_c_3p_2(s7_scheme *sc) -{ - gc_protect_via_stack(sc, sc->value); - check_stack_size(sc); - push_stack_direct(sc, OP_SAFE_C_3P_3); - sc->code = cadddr(sc->code); -} - -static void op_safe_c_3p_2_mv(s7_scheme *sc) /* here from 1 + 2mv, or 1_mv with 2 or 2mv */ -{ - gc_protect_via_stack(sc, sc->value); - push_stack_direct(sc, OP_SAFE_C_3P_3_MV); - sc->code = cadddr(sc->code); -} - -static void op_safe_c_3p_3(s7_scheme *sc) -{ - set_car(sc->t3_3, sc->value); - set_car(sc->t3_1, sc->args); - set_car(sc->t3_2, stack_protected1(sc)); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t3_1); -} - -static void op_safe_c_3p_3_mv(s7_scheme *sc) -{ - s7_pointer p; - s7_pointer p1 = ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) ? cdr(sc->args) : list_1(sc, sc->args); - s7_pointer ps1 = stack_protected1(sc); - s7_pointer p2 = ((is_pair(ps1)) && (car(ps1) == sc->unused)) ? cdr(ps1) : list_1(sc, ps1); - s7_pointer p3 = ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) ? cdr(sc->value) : list_1(sc, sc->value); - unstack(sc); - for (p = p1; is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, p2); - for (p = cdr(p); is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, p3); - sc->args = p1; - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static Inline bool inline_collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) /* called (all hits:)op_any_c_np_1/mv and eval, tlet (cb/set) */ -{ - sc->args = args; - for (s7_pointer p = sc->code; is_pair(p); p = cdr(p)) - if (has_fx(p)) - sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ - else - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, sc->value = fx_proc_unchecked(p)(sc, car(p)), sc->args); - else - { - push_stack(sc, op, sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - } - return(false); -} - -static bool collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) {return(inline_collect_np_args(sc, op, args));} - -static /* inline */ bool op_any_c_np(s7_scheme *sc) /* code: (func . args) where at least one arg is not fxable */ -{ - sc->args = sc->nil; - for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) - if (has_fx(p)) - sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ - else - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, sc->value = fx_proc_unchecked(p)(sc, car(p)), sc->args); - else - { - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - push_op_stack(sc, sc->code); - check_stack_size(sc); - push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - } - /* here fx/gx got all the args */ - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->value = fn_proc(sc->code)(sc, sc->args); - return(false); -} - -static Inline bool inline_op_any_c_np_1(s7_scheme *sc) /* called once in eval, tlet (cb/set) */ -{ - /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is on op-stack */ - if (inline_collect_np_args(sc, OP_ANY_C_NP_1, cons(sc, sc->value, sc->args))) - return(true); - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->code = pop_op_stack(sc); - sc->value = fn_proc(sc->code)(sc, sc->args); - return(false); -} - -static void op_any_c_np_2(s7_scheme *sc) -{ - sc->args = proper_list_reverse_in_place(sc, sc->args = cons(sc, sc->value, sc->args)); - sc->code = pop_op_stack(sc); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static bool op_any_c_np_mv(s7_scheme *sc) -{ - /* we're looping through fp cases here, so sc->value can be non-mv after the first */ - if (collect_np_args(sc, OP_ANY_C_NP_MV, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args))) - return(true); - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->code = pop_op_stack(sc); - sc->code = c_function_base(opt1_cfunc(sc->code)); - return(false); -} - -static void op_any_closure_np(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - check_stack_size(sc); - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - push_op_stack(sc, sc->code); - if (has_fx(p)) - { - sc->args = fx_call(sc, p); - sc->args = list_1(sc, sc->args); - for (p = cdr(p); (is_pair(p)) && (has_fx(p)); p = cdr(p)) - sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args); - } - else sc->args = sc->nil; - push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_CLOSURE_NP_1 : OP_ANY_CLOSURE_NP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); -} - -static void op_any_closure_np_end(s7_scheme *sc) -{ - s7_pointer x, z, f; - uint64_t id; - - sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_args(f) is not reversed */ - sc->code = pop_op_stack(sc); - f = opt1_lambda(sc->code); - - if (is_safe_closure(f)) - { - id = ++sc->let_number; - set_curlet(sc, closure_let(f)); - let_set_id(sc->curlet, id); - for (x = let_slots(sc->curlet), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) - { - slot_set_value(x, car(z)); - symbol_set_local_slot(slot_symbol(x), id, x); - /* don't free sc->args -- it might be needed in the error below */ - } - if (tis_slot(x)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - } - else - { - s7_pointer p = closure_args(f), last_slot; - s7_pointer e = inline_make_let(sc, closure_let(f)); - sc->z = e; - id = let_id(e); - last_slot = make_slot(sc, car(p), car(sc->args)); - slot_set_next(last_slot, slot_end(sc)); - let_set_slots(e, last_slot); - symbol_set_local_slot(car(p), id, last_slot); - for (p = cdr(p), z = cdr(sc->args); is_pair(p); p = cdr(p), z = cdr(z)) - last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), car(z)); /* sets last_slot, don't free sc->args -- used below */ - set_curlet(sc, e); - sc->z = sc->unused; - if (is_pair(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - } - if (is_pair(z)) /* these checks are needed because multiple-values might evade earlier arg num checks */ - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); - - sc->code = closure_body(f); - if_pair_set_up_begin(sc); -} - -static bool op_safe_c_ap(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - s7_pointer val = cdr(code); - if ((has_gx(val)) && (symbol_ctr(caar(val)) == 1)) - { - val = fx_proc_unchecked(val)(sc, car(val)); - gc_protect_via_stack(sc, val); - set_car(sc->t2_1, fx_call(sc, code)); - set_car(sc->t2_2, val); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); - return(false); - } - check_stack_size(sc); - sc->args = fx_call(sc, code); - push_stack_direct(sc, (opcode_t)opt1_any(code)); /* safe_c_sp cases, mv->safe_c_sp_mv */ - sc->code = car(val); - return(true); -} - -static bool op_safe_c_pa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) - { - gc_protect_via_stack(sc, fx_proc_unchecked(args)(sc, car(args))); - set_car(sc->t2_2, fx_call(sc, cdr(args))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); - return(false); - } - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_PA_1); - sc->code = car(args); - return(true); -} - -static void op_safe_c_pa_1(s7_scheme *sc) -{ - sc->args = sc->value; /* fx* might change sc->value?? */ - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, sc->args); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static void op_safe_c_pa_mv(s7_scheme *sc) -{ - s7_pointer p, val = copy_proper_list(sc, sc->value); /* this is necessary since the fx_proc below can clobber sc->value */ - gc_protect_via_stack(sc, val); - for (p = val; is_pair(cdr(p)); p = cdr(p)); /* must be more than 1 member of list or it's not mv */ - sc->args = fx_call(sc, cddr(sc->code)); - cdr(p) = set_plist_1(sc, sc->args); /* do we need to copy sc->args if it is immutable (i.e. plist)? */ - sc->args = val; - unstack(sc); - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_c_na(s7_scheme *sc) /* (set-cdr! lst ()) */ -{ - s7_pointer new_args = make_list(sc, opt3_arglen(cdr(sc->code)), sc->unused); - gc_protect_via_stack(sc, new_args); - for (s7_pointer args = cdr(sc->code), p = new_args; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, new_args); -} - -static void op_c_a(s7_scheme *sc) -{ - sc->value = fx_call(sc, cdr(sc->code)); /* gc protect result before list_1 */ - sc->args = list_1(sc, sc->value); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static void op_c_p(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_C_P_1); - sc->code = T_Pair(cadr(sc->code)); -} - -static void op_c_p_mv(s7_scheme *sc) /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2))) */ -{ - sc->code = c_function_base(opt1_cfunc(sc->code)); /* see comment above */ - sc->args = copy_proper_list(sc, sc->value); -} - -static inline void op_c_ss(s7_scheme *sc) -{ - sc->args = list_2(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static void op_c_ap(s7_scheme *sc) -{ - sc->args = fx_call(sc, cdr(sc->code)); - push_stack_direct(sc, OP_C_AP_1); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */ - sc->code = caddr(sc->code); -} - -static void op_c_ap_mv(s7_scheme *sc) -{ - clear_multiple_value(sc->value); - sc->args = cons(sc, sc->args, sc->value); - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_c_aa(s7_scheme *sc) -{ - gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); - set_stack_protected2(sc, fx_call(sc, cddr(sc->code))); - sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc)); - unstack(sc); /* fn_proc here is unsafe so clear stack first */ - sc->value = fn_proc(sc->code)(sc, sc->value); -} - -static inline void op_c_s(s7_scheme *sc) -{ - sc->args = list_1(sc, lookup(sc, cadr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static Inline void inline_op_apply_ss(s7_scheme *sc) /* called once in eval, sg: all time spent in proper_list check */ -{ - sc->args = lookup(sc, opt2_sym(sc->code)); - if (!s7_is_proper_list(sc, sc->args)) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args)); - sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */ - if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); -} - -static void op_apply_sa(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - sc->args = fx_call(sc, cdr(p)); - if (!s7_is_proper_list(sc, sc->args)) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args)); - sc->code = lookup_global(sc, car(p)); - if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); -} - -static void op_apply_sl(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - sc->args = fx_call(sc, cdr(p)); - sc->code = lookup_global(sc, car(p)); -} - -static bool op_pair_pair(s7_scheme *sc) -{ - if (!is_pair(car(sc->code))) - { - clear_optimize_op(sc->code); - return(false); - } - if (sc->stack_end >= (sc->stack_resize_trigger - 8)) - check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ - push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */ - /* don't put check_stack_size here! */ - push_stack_no_args(sc, OP_EVAL_ARGS, car(sc->code)); - sc->code = caar(sc->code); - return(true); -} - -static bool op_pair_sym(s7_scheme *sc) -{ - if (!is_symbol(car(sc->code))) - { - clear_optimize_op(sc->code); - return(false); - } - sc->value = lookup_global(sc, car(sc->code)); - return(true); -} - -static void op_eval_args2(s7_scheme *sc) -{ - sc->code = pop_op_stack(sc); - sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args)); -} - -static void op_eval_args3(s7_scheme *sc) -{ - s7_pointer val = sc->code; - if (is_symbol(val)) - val = lookup_checked(sc, val); - sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, val, cons(sc, sc->value, sc->args))); - sc->code = pop_op_stack(sc); -} - -static void op_eval_args5(s7_scheme *sc) /* sc->value is the last arg, sc->code is the previous */ -{ - sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, sc->value, cons(sc, sc->code, sc->args))); - sc->code = pop_op_stack(sc); -} - -static bool eval_args_no_eval_args(s7_scheme *sc) -{ - if (is_any_macro(sc->value)) - { - if (!s7_is_proper_list(sc, cdr(sc->code))) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "improper list of arguments: ~S", 30), sc->code)); - sc->args = cdr(sc->code); - if (is_symbol(car(sc->code))) /* not ((f p) args...) where (f p) has returned a macro, op_macro_d assumes car is a symbol */ - { - if (is_macro(sc->value)) - set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_D, sc->value)); - else - if (is_macro_star(sc->value)) - set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_STAR_D, sc->value)); - } - sc->code = sc->value; - return(true); - } - if (is_syntactic_pair(sc->code)) /* (define progn begin) (progn (display "hi") (+ 1 23)) */ - sc->cur_op = optimize_op(sc->code); - else - { - sc->cur_op = syntax_opcode(sc->value); - if ((is_symbol(car(sc->code))) && /* don't opt pair to syntax op if sc->value is actually an arg not the op! ((write and)) should not be op_and */ - ((car(sc->code) == syntax_symbol(sc->value)) || (lookup_global(sc, car(sc->code)) == sc->value))) - pair_set_syntax_op(sc->code, sc->cur_op); - /* weird that sc->cur_op setting above seems ok, but OP_PAIR_PAIR hangs?? */ - } - return(false); -} - - -static inline void eval_last_arg(s7_scheme *sc, s7_pointer car_code) -{ - /* here we've reached the last arg (sc->code == nil), it is not a pair */ - if (!is_null(cdr(sc->code))) - improper_arglist_error_nr(sc); - sc->code = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; /* this has to precede the set_type below */ - sc->args = (is_null(sc->args)) ? list_1(sc, sc->code) : proper_list_reverse_in_place(sc, cons(sc, sc->code, sc->args)); - sc->code = pop_op_stack(sc); -} - -static inline void eval_args_pair_car(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ - if (is_null(code)) - push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args); - else - { - if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */ - improper_arglist_error_nr(sc); - if ((is_null(cdr(code))) && - (!is_pair(car(code)))) - push_stack(sc, OP_EVAL_ARGS3, sc->args, car(code)); - else push_stack(sc, OP_EVAL_ARGS4, sc->args, code); - } - sc->code = car(sc->code); -} - -static bool eval_car_pair(s7_scheme *sc) -{ - s7_pointer code = sc->code, carc = car(sc->code); - - /* evaluate the inner list but that list can be circular: carc: #1=(#1# #1#)! and the cycle can be well-hidden -- #1=((#1 2) . 2) and other such stuff */ - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, code); - - if (is_symbol_and_syntactic(car(carc))) - /* was checking for is_syntactic (pair or symbol) here but that can be confused by successive optimizer passes: (define (hi) (((lambda () list)) 1 2 3)) etc */ - { - if (!no_int_opt(code)) - { - if ((car(carc) == sc->lambda_symbol) && /* ((lambda ...) expr) */ - (is_pair(cddr(carc))) && (s7_is_proper_list(sc, cddr(carc)))) /* not dotted! */ - { - set_opt3_pair(code, cddr(carc)); - if ((is_null(cadr(carc))) && (is_null(cdr(code)))) - { - set_optimize_op(code, OP_F); /* ((lambda () ...)) */ - return(false); - } - if (is_pair(cadr(carc))) - { - if ((is_normal_symbol(caadr(carc))) && (!is_constant(sc, caadr(carc))) && - (is_pair(cdr(code))) && (is_fxable(sc, cadr(code)))) - { - set_opt3_sym(cdr(code), caadr(carc)); - if ((is_null(cdadr(carc))) && (is_null(cddr(code)))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); /* ((lambda (x) ...) expr) */ - set_optimize_op(code, OP_F_A); - return(false); - } - if ((is_pair(cdadr(carc))) && (is_pair(cddr(code))) && (is_fxable(sc, caddr(code))) && - (is_null(cddadr(carc))) && (is_null(cdddr(code))) && - (is_normal_symbol(cadadr(carc))) && (!is_constant(sc, cadadr(carc))) && (caadr(carc) != cadadr(carc))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_optimize_op(code, OP_F_AA); /* ((lambda (x y) ...) expr exor) */ - return(false); - }} - set_optimize_op(code, OP_F_NP); - }} - set_no_int_opt(code); - } - /* ((if op1 op2) args...) is another somewhat common case */ - if ((car(carc) == sc->quote_symbol) && /* ('and #f) */ - ((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */ - (is_symbol_and_syntactic(cadr(carc))))) /* ('or #f) but not ('#_or #f) */ - apply_error_nr(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)); - - push_stack_no_args(sc, OP_EVAL_ARGS, code); - sc->code = carc; - if (!no_cell_opt(carc)) - { - if ((car(carc) == sc->if_symbol) && - (is_pair(cdr(code))) && /* check that we got one or two args */ - ((is_null(cddr(code))) || - ((is_pair(cddr(code))) && (is_null(cdddr(code)))))) - { - check_if(sc, carc); - if ((fx_function[optimize_op(carc)]) && - (is_fxable(sc, cadr(code))) && - ((is_null(cddr(code))) || (is_fxable(sc, caddr(code))))) /* checked cdddr above */ - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_fx_direct(code, fx_function[optimize_op(carc)]); - set_optimize_op(code, (is_null(cddr(code))) ? OP_A_A : OP_A_AA); - return(false); /* goto eval in trailers */ - }} - set_no_cell_opt(carc); - } - sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); - return(true); - } - push_stack_no_args(sc, OP_EVAL_ARGS, code); - if ((is_pair(cdr(code))) && (is_optimized(carc))) - { - if ((fx_function[optimize_op(carc)]) && - (is_fxable(sc, cadr(code))) && - ((is_null(cddr(code))) || - ((is_fxable(sc, caddr(code))) && (is_null(cdddr(code)))))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_fx_direct(code, fx_function[optimize_op(carc)]); - set_optimize_op(code, (is_null(cddr(code))) ? OP_A_A : OP_A_AA); - sc->code = carc; - return(false); /* goto eval in trailers */ - } - if ((is_null(cddr(code))) && (is_symbol(cadr(code)))) /* ((x 'f82) x) in tstar for example */ - { - set_optimize_op(code, OP_P_S); - set_opt3_sym(code, cadr(code)); - } - /* possible op OP_P_ALL_A runs into opt2 fx overwrites in a case like ((values set!) x 32) */ - else set_optimize_op(code, OP_PAIR_PAIR); - } - else set_optimize_op(code, OP_PAIR_PAIR); - push_stack_no_args(sc, OP_EVAL_ARGS, carc); - sc->code = car(carc); - return(false); -} - -static inline bool eval_args_last_arg(s7_scheme *sc) -{ - s7_pointer car_code = car(sc->code); /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */ - if (is_pair(car_code)) - { - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, sc->code); - push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value); - sc->code = car_code; - return(true); - } - /* get the last arg */ - sc->code = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; - /* get the current arg, which is not a list */ - sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, sc->code, cons(sc, sc->value, sc->args))); - sc->code = pop_op_stack(sc); - return(false); -} - -static goto_t trailers(s7_scheme *sc) -{ - s7_pointer code = sc->code; - set_current_code(sc, code); - if (is_pair(code)) - { - s7_pointer carc = car(code); - if (is_symbol(carc)) - { - /* car is a symbol, sc->code a list */ - if (is_syntactic_symbol(carc)) - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(sc->code, sc->cur_op); - return(goto_top_no_pop); - } - sc->value = lookup_global(sc, carc); - set_optimize_op(code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ - return(goto_eval_args_top); - } - if (is_pair(carc)) /* ((if x y z) a b) etc */ - return((eval_car_pair(sc)) ? goto_top_no_pop : goto_eval); - - /* here we can get syntax objects like quote */ - if (is_syntax(carc)) - { - sc->cur_op = syntax_opcode(carc); - pair_set_syntax_op(sc->code, sc->cur_op); - return(goto_top_no_pop); - } - /* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */ - set_optimize_op(code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ - sc->value = T_Ext(carc); - return(goto_eval_args_top); - } - if (is_symbol(code)) - { - sc->value = lookup_checked(sc, code); - set_optimize_op(code, (is_keyword(code)) ? OP_CONSTANT : OP_SYMBOL); - } - else - { - sc->value = T_Ext(code); - set_optimize_op(code, OP_CONSTANT); - } - return(goto_start); -} - - -/* ---------------- reader funcs for eval ---------------- */ -static void back_up_stack(s7_scheme *sc) -{ - opcode_t top_op = stack_op(sc->stack, current_stack_top(sc) - 1); - if (top_op == OP_READ_DOT) - { - pop_stack(sc); - top_op = stack_op(sc->stack, current_stack_top(sc) - 1); - } - if ((top_op == OP_READ_VECTOR) || - (top_op == OP_READ_BYTE_VECTOR) || - (top_op == OP_READ_INT_VECTOR) || - (top_op == OP_READ_FLOAT_VECTOR)) - { - pop_stack(sc); - top_op = stack_op(sc->stack, current_stack_top(sc) - 1); - } - if (top_op == OP_READ_QUOTE) - pop_stack(sc); -} - -static token_t read_sharp(s7_scheme *sc, s7_pointer pt) -{ - int32_t c = inchar(pt); /* inchar can return EOF, so it can't be used directly as an index into the digits array */ - switch (c) - { - case EOF: - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "unexpected '#' at end of input", 30))); - break; - - case '(': - sc->w = int_one; - return(TOKEN_VECTOR); - - case 'i': - if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_INT_VECTOR); - backchar('i', pt); - break; - - case 'r': - if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_FLOAT_VECTOR); - backchar('r', pt); - break; - - case 'u': - if (s7_peek_char(sc, pt) == chars[(int32_t)('8')]) /* backwards compatibility: #u8(...) == #u(...) */ - { - int32_t bc = inchar(pt); - if (s7_peek_char(sc, pt) == chars[(int32_t)('(')]) - { - inchar(pt); - sc->w = int_one; - return(TOKEN_BYTE_VECTOR); - } - backchar(bc, pt); - } - if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_BYTE_VECTOR); - backchar('u', pt); - break; - - case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - { - /* here we can get an overflow: #1231231231231232131D() */ - s7_int dims = digits[c]; - int32_t d = 0, loc = 0; - - sc->strbuf[loc++] = (unsigned char)c; - while (true) - { - s7_int dig; - d = inchar(pt); - if (d == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n...", 43))); - dig = digits[d]; - if (dig >= 10) break; - dims = dig + (dims * 10); - if (dims <= 0) - { - sc->strbuf[loc++] = (unsigned char)d; - error_nr(sc, sc->read_error_symbol, - set_elist_3(sc, wrap_string(sc, "reading #~A...: ~A must be a positive integer", 45), - wrap_string(sc, sc->strbuf, loc), - wrap_integer(sc, dims))); - } - if (dims > sc->max_vector_dimensions) - { - sc->strbuf[loc++] = (unsigned char)d; - sc->strbuf[loc + 1] = '\0'; - error_nr(sc, sc->read_error_symbol, - set_elist_4(sc, wrap_string(sc, "reading #~A...: ~A is too large, (*s7* 'max-vector-dimensions): ~A", 66), - wrap_string(sc, sc->strbuf, loc), - wrap_integer(sc, dims), - wrap_integer(sc, sc->max_vector_dimensions))); - } - sc->strbuf[loc++] = (unsigned char)d; - } - sc->strbuf[loc++] = d; - if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u')) - { - int32_t e = inchar(pt); - if (e == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n()", 42))); - sc->strbuf[loc++] = (unsigned char)e; - if (e == '(') - { - sc->w = make_integer(sc, dims); - if (d == 'd') return(TOKEN_VECTOR); - if (d == 'r') return(TOKEN_FLOAT_VECTOR); - return((d == 'u') ? TOKEN_BYTE_VECTOR : TOKEN_INT_VECTOR); - }} - /* try to back out */ - for (d = loc - 1; d > 0; d--) - backchar(sc->strbuf[d], pt); - } - break; - - case ':': /* turn #: into : -- this is for compatibility with Guile, sigh. - * I just noticed that Rick is using this -- I'll just leave it alone. - * but that means : readers need to handle this case specially. - * I don't think #! is special anymore -- maybe remove that code? - */ - sc->strbuf[0] = ':'; - return(TOKEN_ATOM); - - /* block comments in #! ... !# */ - /* this is needed when an input file is treated as a script: - #!/home/bil/cl/snd - !# - (format #t "a test~%") - (exit) - * but very often the closing !# is omitted which is too bad - */ - case '!': - { - char last_char = ' '; - /* make it possible to override #! handling */ - for (s7_pointer reader = slot_value(sc->sharp_readers); is_pair(reader); reader = cdr(reader)) - if (s7_character(caar(reader)) == '!') - { - sc->strbuf[0] = (unsigned char)c; - return(TOKEN_SHARP_CONST); /* next stage notices any errors */ - } - /* not #! as block comment (for Guile I guess) */ - while ((c = inchar(pt)) != EOF) - { - if ((c == '#') && - (last_char == '!')) - break; - last_char = c; - } - if (c == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #!", 40))); - return(token(sc)); - } - - /* block comments in #| ... |# - * since we ignore everything until the |#, internal semicolon comments are ignored, - * meaning that ;|# is as effective as |# - */ - case '|': - { - const char *str, *orig_str, *p, *pend; - if (is_file_port(pt)) - { - char last_char = ' '; - while (true) - { - c = fgetc(port_file(pt)); - if (c == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); - if ((c == '#') && - (last_char == '|')) - break; - last_char = c; - if (c == '\n') - port_line_number(pt)++; - } - return(token(sc)); - } - orig_str = (const char *)(port_data(pt) + port_position(pt)); - pend = (const char *)(port_data(pt) + port_data_size(pt)); - str = orig_str; - while (true) - { - p = strchr(str, (int)'|'); - if ((!p) || (p >= pend)) - { - port_position(pt) = port_data_size(pt); - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); - } - if (p[1] == '#') - break; - str = (const char *)(p + 1); - } - port_position(pt) += (p - orig_str + 2); - /* now count newlines inside the comment */ - str = (const char *)orig_str; - pend = p; - while (true) - { - p = strchr(str, (int)'\n'); - if ((p) && (p < pend)) - { - port_line_number(pt)++; - str = (char *)(p + 1); - } - else break; - } - return(token(sc)); - }} - sc->strbuf[0] = (unsigned char)c; - return(TOKEN_SHARP_CONST); /* next stage notices any errors */ -} - -static token_t read_comma(s7_scheme *sc, s7_pointer pt) -{ - /* here we probably should check for symbol names that start with "@": - (define-macro (hi @foo) `(+ ,@foo 1)) -> hi, (hi 2) -> ;foo: unbound variable - but (define-macro (hi .foo) `(+ ,.foo 1)) -> hi, (hi 2) -> 3 - and ambiguous: - (define-macro (hi @foo . foo) `(list ,@foo)) - what about , @foo -- is the space significant? We accept ,@ foo. - */ - int32_t c = inchar(pt); - if (c == '@') - return(TOKEN_AT_MARK); - if (c == EOF) - { - sc->strbuf[0] = ','; /* was '@' which doesn't make any sense */ - return(TOKEN_COMMA); /* was TOKEN_ATOM, which also doesn't seem sensible */ - } - backchar(c, pt); - return(TOKEN_COMMA); -} - -static token_t read_dot(s7_scheme *sc, s7_pointer pt) -{ - int32_t c = inchar(pt); - if (c != EOF) - { - backchar(c, pt); - if ((!char_ok_in_a_name[c]) && (c != 0)) - return(TOKEN_DOT); - } - else - { - sc->strbuf[0] = '.'; - return(TOKEN_DOT); - } - sc->strbuf[0] = '.'; - return(TOKEN_ATOM); /* i.e. something that can start with a dot like a number */ -} - -static token_t token(s7_scheme *sc) /* inline here is slower */ -{ - int32_t c = port_read_white_space(current_input_port(sc))(sc, current_input_port(sc)); - switch (c) - { - case '(': return(TOKEN_LEFT_PAREN); - case ')': return(TOKEN_RIGHT_PAREN); - case '.': return(read_dot(sc, current_input_port(sc))); - case '\'': return(TOKEN_QUOTE); - case ';': return(port_read_semicolon(current_input_port(sc))(sc, current_input_port(sc))); - case '"': return(TOKEN_DOUBLE_QUOTE); - case '`': return(TOKEN_BACK_QUOTE); - case ',': return(read_comma(sc, current_input_port(sc))); - case '#': return(read_sharp(sc, current_input_port(sc))); - case '\0': - case EOF: return(TOKEN_EOF); - default: - sc->strbuf[0] = (unsigned char)c; /* every TOKEN_ATOM return goes to port_read_name, so we save a backchar/inchar shuffle by starting the read here */ - return(TOKEN_ATOM); - } -} - -static int32_t read_x_char(s7_scheme *sc, int32_t i, s7_pointer pt) -{ - /* possible "\xn...;" char (write creates these things, so we have to read them) - * but we could have crazy input like "\x -- with no trailing double quote - */ - for (int32_t c_ctr = 0; ; c_ctr++) - { - int32_t d1, d2, c = inchar(pt); - if (c == '"') /* "\x" -> error, "\x44" or "\x44;" -> #\D */ - { - if (c_ctr == 0) /* "\x" */ - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); /* "\x44" I think -- not sure about this -- Guile is happy but I think it contradicts r7rs.pdf */ - return(i); - } - if (c == ';') - { - if (c_ctr == 0) /* "\x;" */ - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - return(i); /* "\x44;" */ - } - if (c == EOF) /* "\x */ - { - read_error_nr(sc, "# in midst of hex-char"); - return(i); - } - d1 = digits[c]; - if (d1 >= 16) /* "\x4H", also "\x44H" which Guile thinks is ok -- it apparently reads 2 digits and quits? */ - { - if (c_ctr == 0) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); - return(i); - } - /* perhaps if c_ctr==0 error else backchar + return(i??) */ - - c = inchar(pt); - if (c == '"') /* "\x4" */ - { - sc->strbuf[i++] = (unsigned char)d1; - backchar((char)c, pt); - return(i); - } - if (c == ';') /* "\x4;" */ - { - sc->strbuf[i++] = (unsigned char)d1; - return(i); - } - if (c == EOF) /* "\x4 in midst of hex-char"); - return(i); - } - d2 = digits[c]; - if (d2 >= 16) - { - if (c_ctr == 0) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); - return(i); - } - sc->strbuf[i++] = (unsigned char)(16 * d1 + d2); - } - return(i); -} - -static s7_pointer unknown_string_constant(s7_scheme *sc, int32_t c) -{ - /* check *read-error-hook* */ - if (hook_has_functions(sc->read_error_hook)) - { - s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->F, chars[(uint8_t)c])); - if (is_character(result)) - return(result); - } - return(sc->T); -} - -static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt) -{ - /* sc->F => error, no check needed here for bad input port and so on */ - s7_int i = 0; - - if (is_string_port(pt)) - { - /* try the most common case first */ - char *s, *end, *start = (char *)(port_data(pt) + port_position(pt)); - if (*start == '"') - { - port_position(pt)++; - return(nil_string); - } - end = (char *)(port_data(pt) + port_data_size(pt)); - s = strpbrk(start, "\"\n\\"); - if ((!s) || (s >= end)) /* can this read a huge string constant from a file? */ - { - if (start == end) - sc->strbuf[0] = '\0'; - else memcpy((void *)(sc->strbuf), (void *)start, (end - start > 8) ? 8 : (end - start)); - sc->strbuf[8] = '\0'; - return(sc->F); - } - if (*s == '"') - { - s7_int len = s - start; - port_position(pt) += (len + 1); - return(make_string_with_length(sc, start, len)); - } - for (; s < end; s++) - { - if (*s == '"') /* switch here no faster */ - { - s7_int len = s - start; - port_position(pt) += (len + 1); - return(make_string_with_length(sc, start, len)); - } - if (*s == '\\') - { - /* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */ - s7_int len = (s7_int)(s - start); - if (len > 0) - { - if (len >= sc->strbuf_size) - resize_strbuf(sc, len); - memcpy((void *)(sc->strbuf), (void *)(port_data(pt) + port_position(pt)), len); - port_position(pt) += len; - } - i = len; - break; - } - else - if (*s == '\n') - port_line_number(pt)++; - }} - - while (true) - { - /* splitting this check out and duplicating the loop was slower?!? */ - int32_t c = port_read_character(pt)(sc, pt); - switch (c) - { - case '\n': - port_line_number(pt)++; - sc->strbuf[i++] = (unsigned char)c; - break; - - case EOF: - sc->strbuf[(i > 8) ? 8 : i] = '\0'; - return(sc->F); - - case '"': - return(make_string_with_length(sc, sc->strbuf, i)); - - case '\\': - c = inchar(pt); - switch (c) - { - case EOF: - sc->strbuf[(i > 8) ? 8 : i] = '\0'; - return(sc->F); - - case '\\': case '"': case '|': - sc->strbuf[i++] = (unsigned char)c; - break; - - case 'n': sc->strbuf[i++] = '\n'; break; - case 't': sc->strbuf[i++] = '\t'; break; - case 'r': sc->strbuf[i++] = '\r'; break; - case '/': sc->strbuf[i++] = '/'; break; - case 'b': sc->strbuf[i++] = (unsigned char)8; break; - case 'f': sc->strbuf[i++] = (unsigned char)12; break; - - case 'x': - i = read_x_char(sc, i, pt); - break; - - default: /* if (!is_white_space(c)) */ /* changed 8-Apr-12 */ - if ((c != '\n') && (c != '\r')) /* i.e. line continuation via #\\ at end of line */ - { - s7_pointer result = unknown_string_constant(sc, c); - if (!is_character(result)) return(result); - sc->strbuf[i++] = character(result); - } - /* #f here would give confusing error message "end of input", so return #t=bad backslash. - * this is not optimal. It's easy to forget that backslash needs to be backslashed. - * the white_space business half-implements Scheme's \...... or \...... - * feature -- the characters after \ are flushed if they're all white space and include a newline. - * (string->number "1\ 2") is 12?? Too bizarre. - */ - } - break; - - default: - sc->strbuf[i++] = (unsigned char)c; - break; - } - if (i >= sc->strbuf_size) - resize_strbuf(sc, i); - } -} - -static void read_double_quote(s7_scheme *sc) -{ - sc->value = read_string_constant(sc, current_input_port(sc)); - if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ - string_read_error_nr(sc, "end of input encountered while in a string"); - if (sc->value == sc->T) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); -} - -static inline bool read_sharp_const(s7_scheme *sc) -{ - sc->value = port_read_sharp(current_input_port(sc))(sc, current_input_port(sc)); - if (sc->value == sc->no_value) - { - /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*)) - * (+ 1 #;(* 2 3) 4) - * so we need to get the next token, act on it without any assumptions about read list - */ - sc->tok = token(sc); - return(true); - } - return(false); -} - -static noreturn void read_expression_read_error_nr(s7_scheme *sc) -{ - s7_pointer pt = current_input_port(sc); - pop_stack(sc); - if ((is_input_port(pt)) && - (!port_is_closed(pt)) && - (port_data(pt)) && - (port_position(pt) > 0)) - { - s7_pointer p = make_empty_string(sc, 128, '\0'); - char *msg = string_value(p); - s7_int pos = port_position(pt); - s7_int start = pos - 40; - if (start < 0) start = 0; - memcpy((void *)msg, (void *)"at \"...", 7); - memcpy((void *)(msg + 7), (void *)(port_data(pt) + start), pos - start); - memcpy((void *)(msg + 7 + pos - start), (void *)"...", 3); - string_length(p) = 7 + pos - start + 3; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - read_error_nr(sc, "stray comma before ')'?"); /* '("a" "b",) */ -} - -static s7_pointer read_expression(s7_scheme *sc) -{ - while (true) - { - switch (sc->tok) - { - case TOKEN_EOF: - return(eof_object); - - case TOKEN_BYTE_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_BYTE_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_INT_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_FLOAT_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_VECTOR: /* already read #( -- TOKEN_VECTOR is triggered by #( */ - push_stack_no_let_no_code(sc, OP_READ_VECTOR, sc->w); /* sc->w is the dimensions */ - /* fall through */ - - case TOKEN_LEFT_PAREN: - sc->tok = token(sc); - if (sc->tok == TOKEN_RIGHT_PAREN) - return(sc->nil); - if (sc->tok == TOKEN_DOT) - { - int32_t c; - back_up_stack(sc); - do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF)); - read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == TOKEN_EOF) - missing_close_paren_error_nr(sc); - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); /* here we need to clear args, but code is ignored */ - check_stack_size(sc); /* s7test */ - break; - - case TOKEN_QUOTE: - push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil); - sc->tok = token(sc); - break; - - case TOKEN_BACK_QUOTE: - sc->tok = token(sc); - push_stack_no_let_no_code(sc, OP_READ_QUASIQUOTE, sc->nil); - break; - - case TOKEN_COMMA: - push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil); - sc->tok = token(sc); - switch (sc->tok) - { - case TOKEN_EOF: - pop_stack(sc); - read_error_nr(sc, "stray comma at the end of the input?"); - case TOKEN_RIGHT_PAREN: - read_expression_read_error_nr(sc); - default: - break; - } - break; - - case TOKEN_AT_MARK: - push_stack_no_let_no_code(sc, OP_READ_APPLY_VALUES, sc->nil); - sc->tok = token(sc); - break; - - case TOKEN_ATOM: - return(port_read_name(current_input_port(sc))(sc, current_input_port(sc))); - /* If reading list (from lparen), this will finally get us to op_read_list */ - - case TOKEN_DOUBLE_QUOTE: - read_double_quote(sc); - return(sc->value); - - case TOKEN_SHARP_CONST: - return(port_read_sharp(current_input_port(sc))(sc, current_input_port(sc))); - - case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ - back_up_stack(sc); - {int32_t c; do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF));} - read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ - - case TOKEN_RIGHT_PAREN: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ - back_up_stack(sc); - read_error_nr(sc, "unexpected close paren"); /* (+ 1 2)) or (+ 1 . ) */ - }} - /* we never get here */ - return(sc->nil); -} - -static void read_dot_and_expression(s7_scheme *sc) -{ - push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args); - sc->tok = token(sc); - sc->value = read_expression(sc); -} - -static void read_tok_default(s7_scheme *sc) -{ - /* by far the main case here is TOKEN_LEFT_PAREN, but it doesn't save anything to move it to this level */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - /* check for op_read_list here and explicit pop_stack are slower */ -} - -static int32_t read_atom(s7_scheme *sc, s7_pointer pt) -{ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - /* check_stack_size(sc); */ - sc->value = port_read_name(pt)(sc, pt); - sc->args = list_1(sc, sc->value); - pair_set_current_input_location(sc, sc->args); - return(port_read_white_space(pt)(sc, pt)); -} - -static /* inline */ int32_t read_start_list(s7_scheme *sc, s7_pointer pt, int32_t c) -{ - sc->strbuf[0] = (unsigned char)c; - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - check_stack_size(sc); /* s7test */ - sc->value = port_read_name(pt)(sc, pt); - sc->args = list_1(sc, sc->value); - pair_set_current_input_location(sc, sc->args); - return(port_read_white_space(pt)(sc, pt)); -} - -static void op_read_internal(s7_scheme *sc) -{ - /* if we're loading a file, and in the file we evaluate (at top-level) something like: - * (set-current-input-port (open-input-file "tmp2.r5rs")) - * (close-input-port (current-input-port)) - * ... (with no reset of input port to its original value) - * the load process tries to read the loaded string, but the current-input-port is now closed, - * and the original is inaccessible! So we get a segfault in token. We don't want to put - * a port_is_closed check there because token only rarely is in this danger. I think this - * is the only place where we can be about to call token, and someone has screwed up our port. - */ - if (port_is_closed(current_input_port(sc))) - error_nr(sc, sc->read_error_symbol, /* not read_error here because it paws through the port string which doesn't exist here */ - set_elist_1(sc, wrap_string(sc, (is_loader_port(current_input_port(sc))) ? "load input port is closed!" : "read input port is closed!", 26))); - - sc->tok = token(sc); - switch (sc->tok) - { - case TOKEN_EOF: break; - case TOKEN_RIGHT_PAREN: read_error_nr(sc, "unexpected close paren"); - case TOKEN_COMMA: read_error_nr(sc, "unexpected comma"); - default: - sc->value = read_expression(sc); - sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ - sc->current_file = port_filename(current_input_port(sc)); - break; - } -} - -static void op_read_done(s7_scheme *sc) -{ - pop_input_port(sc); - if (sc->tok == TOKEN_EOF) - sc->value = eof_object; - sc->current_file = NULL; /* this is for error handling */ -} - -static void op_read_s(s7_scheme *sc) -{ - s7_pointer port = lookup(sc, cadr(sc->code)); - if (!is_input_port(port)) /* was also not stdin */ - { - sc->value = g_read(sc, set_plist_1(sc, port)); - return; - } - if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */ - sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_open_input_port_string); - - if (is_function_port(port)) - { - sc->value = (*(port_input_function(port)))(sc, S7_READ, port); - if (is_multiple_value(sc->value)) - { - clear_multiple_value(sc->value); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), sc->value)); - }} - else /* we used to check for string port at end here, but that is rarely true so checking takes up more time than it saves */ - { - push_input_port(sc, port); - push_stack_op(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ - sc->tok = token(sc); - switch (sc->tok) - { - case TOKEN_EOF: return; - case TOKEN_RIGHT_PAREN: read_error_nr(sc, "unexpected close paren"); - case TOKEN_COMMA: read_error_nr(sc, "unexpected comma"); - default: - sc->value = read_expression(sc); - sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ - sc->current_file = port_filename(current_input_port(sc)); - }} -} - -static bool op_read_quasiquote(s7_scheme *sc) -{ - /* this was pushed when the backquote was seen, then eventually we popped back to it */ - sc->value = g_quasiquote_1(sc, sc->value, false); - /* doing quasiquote at read time means there are minor inconsistencies in various combinations or quote/' and quasiquote/`. - * A quoted ` will expand but quoted quasiquote will not (` can't be redefined, but quasiquote can). see s7test.scm for examples. - */ - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool pop_read_list(s7_scheme *sc) -{ - /* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->curlet is apparently not needed here */ - unstack_with(sc, OP_READ_LIST); - sc->args = sc->stack_end[2]; - if (!is_null(sc->args)) return(false); /* fall into read_list where sc->args is placed at end of on-going list, sc->value */ - sc->args = list_1(sc, sc->value); - pair_set_current_input_location(sc, sc->args); /* uses port_location */ - return(true); -} - -static bool op_load_return_if_eof(s7_scheme *sc) -{ - if (sc->tok != TOKEN_EOF) - { - push_stack_op_let(sc, OP_LOAD_RETURN_IF_EOF); - push_stack_op_let(sc, OP_READ_INTERNAL); - sc->code = sc->value; - return(true); /* we read an expression, now evaluate it, and return to read the next */ - } - sc->current_file = NULL; - return(false); -} - -static bool op_load_close_and_pop_if_eof(s7_scheme *sc) -{ - /* (load "file") in scheme: read and evaluate all exprs, then upon EOF, close current and pop input port stack */ - if (sc->tok != TOKEN_EOF) - { - push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was push args, code */ - if ((!is_string_port(current_input_port(sc))) || - (port_position(current_input_port(sc)) < port_data_size(current_input_port(sc)))) - push_stack_op_let(sc, OP_READ_INTERNAL); - else sc->tok = TOKEN_EOF; - sc->code = sc->value; - return(true); /* we read an expression, now evaluate it, and return to read the next */ - } - if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) fprintf(stderr, "%s not loading?\n", display(current_input_port(sc))); - /* if *#readers* func hits error, clear_loader_port might not be undone? */ - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - sc->current_file = NULL; - if (is_multiple_value(sc->value)) /* (load "file") where "file" is (values 1 2 3) */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(false); -} - -static bool op_read_apply_values(s7_scheme *sc) -{ - sc->value = list_2_unchecked(sc, sc->unquote_symbol, list_2(sc, sc->apply_values_symbol, sc->value)); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static goto_t op_read_dot(s7_scheme *sc) -{ - token_t c = token(sc); - if (c != TOKEN_RIGHT_PAREN) /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */ - { - if (is_pair(sc->value)) - { - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p)) - sc->args = cons(sc, car(p), sc->args); - sc->tok = c; - return(goto_read_tok); - } - back_up_stack(sc); - read_error_nr(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */ - } - /* args = previously read stuff, value = thing just after the dot and before the ')': - * (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1) - * but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a) - */ - sc->value = any_list_reverse_in_place(sc, sc->value, sc->args); - return((main_stack_op(sc) == OP_READ_LIST) ? goto_pop_read_list : goto_start); -} - -static bool op_read_quote(s7_scheme *sc) -{ - /* can't check for sc->value = sc->nil here because we want ''() to be different from '() */ - if ((sc->safety > IMMUTABLE_VECTOR_SAFETY) && - ((is_pair(sc->value)) || (is_any_vector(sc->value)) || (is_string(sc->value)))) - set_immutable(sc->value); - sc->value = list_2(sc, sc->quote_symbol, sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_unquote(s7_scheme *sc) -{ - /* here if sc->value is a constant, the unquote is pointless (should we complain?) - * also currently stray "," can be ignored: (abs , 1) -- scanning the stack for quasiquote or quote seems to be unreliable - */ - if ((is_pair(sc->value)) || - (is_symbol(sc->value))) - sc->value = list_2(sc, sc->unquote_symbol, sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -/* safety check is at read time, so (immutable? (let-temporarily (((*s7* 'safety) 2)) #(1 2 3))) is #f - * but (immutable? (let-temporarily (((*s7* 'safety) 2)) (eval-string "#(1 2 3)"))) is #t - */ -static bool op_read_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->w earlier from read_sharp */ - /* here and below all of the sc->value list can be freed, but my tests showed no speed up even in large cases */ - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_int_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_int_vector(sc, sc->value) : g_int_multivector(sc, integer(sc->args), sc->value); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_float_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_float_vector(sc, sc->value) : g_float_multivector(sc, integer(sc->args), sc->value); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_byte_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_byte_vector(sc, sc->value) : g_byte_multivector(sc, integer(sc->args), sc->value); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - - -/* ---------------- unknown ops ---------------- */ -static bool fixup_unknown_op(s7_scheme *sc, s7_pointer code, s7_pointer func, opcode_t op) -{ - set_optimize_op(code, op); - if (is_any_closure(func)) - set_opt1_lambda_add(code, func); /* perhaps set_opt1_lambda_add here and throughout op_unknown* */ - return(true); -} - -static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) -{ - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - set_optimize_op(code, op); - return(true); -} - -static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func) -{ - if (symbol_ctr(func) != 1) /* protect against (define-constant (p) (define-constant (p) ...)) */ - return(false); - if ((is_global(func)) && (is_immutable_slot(global_slot(func)))) - return(true); - for (s7_pointer p = sc->curlet; is_let(p); p = let_outlet(p)) - if ((is_funclet(p)) && (funclet_function(p) != func)) - return(false); - return(is_immutable_slot(lookup_slot_from(func, sc->curlet))); -} - -static bool op_unknown(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - if (!f) /* can be NULL if unbound variable */ - unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s %s\n", __func__, display(f), s7_type_names[type(f)]); - - switch (type(f)) - { - case T_CLOSURE: - case T_CLOSURE_STAR: - if (!has_methods(f)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - if (is_null(closure_args(f))) - { - s7_pointer body = closure_body(f); - bool one_form = is_null(cdr(body)); - bool safe_case = is_safe_closure(f); - set_opt1_lambda_add(code, f); - if (one_form) - { - if ((safe_case) && (is_fxable(sc, car(body)))) - { - set_safe_closure(f); /* safe because no args so no reference to funclet? needed because op_safe_thunk_a will check for it */ - fx_annotate_arg(sc, body, sc->curlet); - set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg(f); - sc->value = fx_safe_thunk_a(sc, sc->code); - return(false); - } - clear_has_fx(code); - } - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); - return(true); - } - if (is_closure_star(f)) - { - set_safe_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(code, f); - return(true); - }} - break; - - case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO)); - case T_ITERATOR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_ITERATE)); - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - } - return(fixup_unknown_op(sc, code, f, OP_S)); -} - -static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer f, s7_pointer code) -{ - if ((!has_methods(f)) && - (closure_star_arity_to_int(sc, f) != 0)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool safe_case = is_safe_closure(f); - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt3_arglen(cdr(code), 1); - if ((safe_case) && (is_null(cdr(closure_args(f))))) - set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); - else - if (lambda_has_simple_defaults(f)) - { - if (arglist_has_rest(sc, closure_args(f))) - fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - else fixup_unknown_op(sc, code, f, hop + ((safe_case) ? - ((is_null(cdr(closure_args(f)))) ? OP_SAFE_CLOSURE_STAR_A1 : OP_SAFE_CLOSURE_STAR_A) : OP_CLOSURE_STAR_A)); - return(true); - } - fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - return(true); - } - return(false); -} - -static bool op_unknown_s(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - if ((S7_DEBUGGING) && (!is_normal_symbol(cadr(code)))) fprintf(stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, display(code)); - if ((!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */ - (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) - return(unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_G)); - - if ((is_unknopt(code)) && (!is_closure(f))) - return(fixup_unknown_op(sc, code, f, OP_S_G)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 1))) break; - case T_C_RST_NO_REQ_FUNCTION: - set_c_function(code, f); - if (is_safe_procedure(f)) - { - set_optimize_op(code, OP_SAFE_C_S); - sc->value = fx_c_s(sc, sc->code); - } - else - { - set_optimize_op(code, OP_C_S); - op_c_s(sc); - } - return(false); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 1)) - { - s7_pointer body = closure_body(f); - bool one_form = is_null(cdr(body)); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - set_opt2_sym(code, cadr(code)); - - /* code here might be (f x) where f is passed elsewhere as a function parameter, - * first time through we look it up, find a safe-closure and optimize as (say) safe_closure_s_a, - * next time it is something else, etc. Rather than keep optimizing it locally, we need to - * back out: safe_closure_s_* -> safe_closure_s -> closure_s -> op_s_g. Ideally we'd know - * this was a parameter or whatever. The tricky case is local letrec(f) calling f which initially - * thinks it is not safe, then later is set safe correctly, now outer func is called again, - * this time f is safe, and we're ok from then on. - */ - if (is_unknopt(code)) - { - switch (op_no_hop(code)) - { - case OP_CLOSURE_S: - set_optimize_op(code, (is_safe_closure(f)) ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : OP_S_G); break; - case OP_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S: - set_optimize_op(code, ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); break; - case OP_SAFE_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S_A: - case OP_SAFE_CLOSURE_S_TO_S: - case OP_SAFE_CLOSURE_S_TO_SC: - set_optimize_op(code, (is_safe_closure(f)) ? - ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : - ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - break; - default: - set_optimize_op(code, OP_S_G); break; - } - set_opt1_lambda_add(code, f); - return(true); - } - if (!is_safe_closure(f)) - set_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - else - if (!is_null(cdr(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S); - else - if (is_fxable(sc, car(body))) - fxify_closure_s(sc, f, code, sc->curlet, hop); - else set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S_O); - /* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm): - * (define (f) (define-constant (f1) ... (f1))...) where each call on f makes a different f1 - */ - set_is_unknopt(code); - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if (fxify_closure_star_g(sc, f, code)) return(true); - break; - - case T_GOTO: - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt3_arglen(cdr(code), 1); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO_A)); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_A)); - - case T_STRING: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_STRING_REF_A)); - - case T_PAIR: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_A)); - - case T_C_OBJECT: - if (s7_is_aritable(sc, f, 1)) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A)); - } - break; - - case T_LET: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); - - case T_HASH_TABLE: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_A)); - - case T_CONTINUATION: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_CONTINUATION_A)); - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - return(fixup_unknown_op(sc, code, f, OP_S_G)); -} - -static bool op_unknown_a(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 1))) break; - case T_C_RST_NO_REQ_FUNCTION: - clear_has_fx(code); - set_c_function(code, f); - if (is_safe_procedure(f)) - { - set_optimize_op(code, OP_SAFE_C_A); - sc->value = fx_c_a(sc, code); - } - else - { - set_optimize_op(code, OP_C_A); - op_c_a(sc); - } - return(false); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 1)) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - - fxify_closure_a(sc, f, one_form, safe_case, hop, code, sc->curlet); - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if (fxify_closure_star_g(sc, f, code)) return(true); - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_A)); - - case T_STRING: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_STRING_REF_A)); - case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_A)); - case T_C_OBJECT: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A)); - case T_HASH_TABLE: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_A)); - case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO_A)); - case T_CONTINUATION: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_CONTINUATION_A)); - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - case T_LET: - { - s7_pointer arg1 = cadr(code); - if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) - { - set_opt3_con(code, cadadr(code)); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_C)); - } - set_opt3_any(code, cadr(code)); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); - } - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - return(fixup_unknown_op(sc, code, f, OP_S_A)); /* closure with methods etc */ -} - -static bool op_unknown_gg(s7_scheme *sc) -{ - bool s1, s2; - s7_pointer code = sc->code, f = sc->last_function; - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - s1 = is_normal_symbol(cadr(code)); - s2 = is_normal_symbol(caddr(code)); - - if ((s1) && - (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); - if ((s2) && - (!is_slot(lookup_slot_from(caddr(code), sc->curlet)))) - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 2))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) - { - if (s1) - { - set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); - if (s2) - set_opt2_sym(cdr(code), caddr(code)); - else set_opt2_con(cdr(code), caddr(code)); - } - else - { - set_optimize_op(code, (s2) ? OP_SAFE_C_CS : OP_SAFE_C_NC); - if (s2) - { - set_opt1_con(cdr(code), (is_pair(cadr(code))) ? cadadr(code) : cadr(code)); - set_opt2_sym(cdr(code), caddr(code)); - }}} - else - { - set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - } - set_opt3_arglen(cdr(code), 2); - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if (has_methods(f)) break; - if (closure_arity_to_int(sc, f) == 2) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - - if ((s1) && (s2)) - { - set_opt2_sym(code, caddr(code)); - if (!one_form) - set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); - else - if (!safe_case) - set_optimize_op(code, hop + OP_CLOSURE_SS_O); - else - if (!is_fxable(sc, car(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_O); - else - { - fx_annotate_arg(sc, body, sc->curlet); - fx_tree(sc, body, car(closure_args(f)), cadr(closure_args(f)), NULL, false); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); - set_closure_one_form_fx_arg(f); - }} - else - if (s1) - { - set_opt2_con(code, caddr(code)); - if (one_form) - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); - else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); - } - else - { - set_opt3_arglen(cdr(code), 2); - fx_annotate_args(sc, cdr(code), sc->curlet); - if (safe_case) - set_safe_optimize_op(code, hop + ((one_form) ? OP_SAFE_CLOSURE_AA_O : OP_SAFE_CLOSURE_AA)); - else set_safe_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_AA_O : OP_CLOSURE_AA)); - } - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if ((closure_star_arity_to_int(sc, f) != 0) && - (closure_star_arity_to_int(sc, f) != 1)) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - if (!has_methods(f)) - { - fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); - set_opt1_lambda_add(code, f); - } - else set_optimize_op(code, OP_S_AA); - return(true); - } - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_PAIR: - set_opt3_arglen(cdr(code), 2); - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((!is_pair(f)) && (vector_rank(f) != 2)) - return(fixup_unknown_op(sc, code, f, OP_S_AA)); - return(fixup_unknown_op(sc, code, f, (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); - - case T_HASH_TABLE: - fx_annotate_args(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_AA)); - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - fx_annotate_args(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_S_AA)); -} - -static bool op_unknown_ns(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - int32_t num_args = opt3_arglen(cdr(code)); - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg)) - if (!is_slot(lookup_slot_from(car(arg), sc->curlet))) - unbound_variable_error_nr(sc, car(arg)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, num_args))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) - { - if (num_args == 3) - { - set_safe_optimize_op(code, OP_SAFE_C_SSS); - set_opt1_sym(cdr(code), caddr(code)); - set_opt2_sym(cdr(code), cadddr(code)); - } - else set_safe_optimize_op(code, OP_SAFE_C_NS); - } - else - { - set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - } - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(closure_body(f))); - fx_annotate_args(sc, cdr(code), sc->curlet); - if (num_args == 3) - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); - if (num_args == 4) - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : OP_CLOSURE_NS))); - } - break; - - case T_CLOSURE_STAR: - if ((!has_methods(f)) && - ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_safe_closure(f)) && (num_args == 3) && (closure_star_arity_to_int(sc, f) == 3)) - return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); - } - break; - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - /* TODO: perhaps vector, but need op_implicit_vector_ns? */ - default: - break; - } - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); -} - -static bool op_unknown_aa(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 2))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) /* why is this different from unknown_a and unknown_na? */ - { - if (!safe_c_aa_to_ag_ga(sc, code, 0)) - { - set_safe_optimize_op(code, OP_SAFE_C_AA); - set_opt3_pair(code, cddr(code)); - }} - else set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 2)) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - if (!one_form) - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); - else - if (!safe_case) - set_optimize_op(code, hop + OP_CLOSURE_AA_O); - else - if (!is_fxable(sc, car(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_O); - else - { - fx_annotate_arg(sc, body, sc->curlet); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A); - set_closure_one_form_fx_arg(f); - } - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if (!has_methods(f)) - { - fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); - set_opt1_lambda_add(code, f); - } - else set_optimize_op(code, OP_S_AA); - return(true); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - if (vector_rank(f) != 2) - return(fixup_unknown_op(sc, code, f, OP_S_AA)); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_AA)); - - case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_AA)); - case T_HASH_TABLE: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_AA)); - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - return(fixup_unknown_op(sc, code, f, OP_S_AA)); -} - -static bool is_normal_happy_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (!is_normal_symbol(sym)) - return(false); - if (!is_slot(lookup_slot_from(sym, sc->curlet))) - unbound_variable_error_nr(sc, sym); - return(true); -} - -static bool op_unknown_na(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(f), display(sc->code)); - if (num_args == 0) return(fixup_unknown_op(sc, code, f, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */ - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, num_args))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) - { - if (num_args == 3) - { - int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ - for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) - { - s7_pointer car_p = car(p); - if (is_normal_happy_symbol(sc, car_p)) - symbols++; - else - if (is_pair(car_p)) - { - pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }} - if (optimize_safe_c_func_three_args(sc, code, f, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == OPT_T) - return(true); - set_opt3_pair(cdr(code), cdddr(code)); - set_opt3_pair(code, cddr(code)); - set_safe_optimize_op(code, OP_SAFE_C_AAA); - } - else set_safe_optimize_op(code, (num_args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA); - } - else set_safe_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - if (is_safe_closure(f)) - { - if (num_args != 3) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_NA); - else - if (is_normal_happy_symbol(sc, cadr(code))) - set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, caddr(code))) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); - else set_safe_optimize_op(code, hop + (((!is_pair(caddr(code))) && (!is_pair(cadddr(code)))) ? OP_SAFE_CLOSURE_AGG : OP_SAFE_CLOSURE_3A)); - } - else - if (num_args != 3) - set_safe_optimize_op(code, hop + ((num_args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA)); - else - if ((is_normal_happy_symbol(sc, caddr(code))) && (is_normal_happy_symbol(sc, cadddr(code)))) - set_safe_optimize_op(code, hop + OP_CLOSURE_ASS); - else - if (is_normal_happy_symbol(sc, cadr(code))) - set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); - else - if (is_normal_happy_symbol(sc, caddr(code))) - set_safe_optimize_op(code, hop + OP_CLOSURE_ASA); - else set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_AAS : OP_CLOSURE_3A)); - set_opt1_lambda_add(code, f); - return(true); - } - if (is_symbol(closure_args(f))) - { - optimize_closure_sym(sc, code, f, 0, num_args, sc->curlet); - if (optimize_op(code) == OP_ANY_CLOSURE_SYM) return(true); - } - break; - - case T_CLOSURE_STAR: - if ((!has_methods(f)) && - ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - if (num_args > 0) - { - set_opt3_arglen(cdr(code), num_args); - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - } - if (is_safe_closure(f)) - switch (num_args) - { - case 0: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_0)); - case 1: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_1)); - case 2: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_2)); - case 3: if (closure_star_arity_to_int(sc, f) == 3) return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); - default: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA)); - } - return(fixup_unknown_op(sc, code, f, hop + OP_CLOSURE_STAR_NA)); - } - break; - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - /* implicit vector doesn't happen */ - - default: - break; - } - /* closure happens if wrong-number-of-args passed -- probably no need for op_s_na */ - /* TODO: perhaps vector? */ - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); -} - -static bool op_unknown_np(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(f), type_name(sc, f, NO_ARTICLE), display(sc->code)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, num_args))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (num_args == 1) - set_any_c_np(sc, f, code, sc->curlet, num_args, (is_safe_procedure(f)) ? OP_SAFE_C_P : OP_C_P); - else - if ((num_args == 2) && (is_safe_procedure(f))) - { - set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP); - opt_sp_1(sc, c_function_call(f), code); - gx_annotate_args(sc, cdr(code), sc->curlet); - } - else - if ((num_args == 3) && - ((is_safe_procedure(f)) || - ((is_semisafe(f)) && - (((car(code) != sc->assoc_symbol) && (car(code) != sc->member_symbol)) || - (unsafe_is_safe(sc, cadddr(code), sc->curlet)))))) - set_any_c_np(sc, f, code, sc->curlet, 3, OP_SAFE_C_3P); - else set_any_c_np(sc, f, code, sc->curlet, num_args, OP_ANY_C_NP); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - switch (num_args) - { - case 1: - if (is_safe_closure(f)) - { - s7_pointer body = closure_body(f); - if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) - { - set_optimize_op(code, hop + OP_SAFE_CLOSURE_P_A); - fx_annotate_arg(sc, body, sc->curlet); - } - else set_optimize_op(code, hop + OP_SAFE_CLOSURE_P); - } - else set_optimize_op(code, hop + OP_CLOSURE_P); - set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ - set_opt3_arglen(cdr(code), 1); - set_unsafely_optimized(code); - break; - - case 2: - if (is_fxable(sc, cadr(code))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - } - else - if (is_fxable(sc, caddr(code))) - { - fx_annotate_arg(sc, cddr(code), sc->curlet); - set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - } - else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); - set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ - set_opt3_arglen(cdr(code), 2); /* for later op_unknown_np */ - set_unsafely_optimized(code); - break; - - case 3: set_any_closure_np(sc, f, code, sc->curlet, 3, hop + OP_ANY_CLOSURE_3P); break; - case 4: set_any_closure_np(sc, f, code, sc->curlet, 4, hop + OP_ANY_CLOSURE_4P); break; - default: set_any_closure_np(sc, f, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_NP); break; - } - return(true); - } - break; - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - } - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); -} - -static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code) -{ - sc->last_function = f; - if (is_null(cdr(code))) return(op_unknown(sc)); - if ((is_null(cddr(code))) && (is_normal_symbol(cadr(code)))) return(op_unknown_s(sc)); - set_opt3_arglen(cdr(code), proper_list_length(cdr(code))); - return(op_unknown_np(sc)); -} - - -/* ---------------- eval type checkers ---------------- */ -#if WITH_GCC -#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_; _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));}) -#else -#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P))) -#endif - -#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P)))) -#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P)))) - -static bool c_function_is_ok_cadr_caddr(s7_scheme *sc, s7_pointer p) -{ - return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, caddr(p)))); -} - -static bool c_function_is_ok_cadr_cadadr(s7_scheme *sc, s7_pointer p) -{ - return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* cadadr(P) */ -} - -static bool c_function_is_ok_cadr_caddadr(s7_scheme *sc, s7_pointer p) -{ - return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* caddadr(p) */ -} - -/* closure_is_ok_1 checks the type and the body length indications - * closure_is_fine_1 just checks the type (safe or unsafe closure) - * closure_is_ok calls _ok_1, closure_is_fine calls _fine_1 - * closure_np_is_ok accepts safe/unsafe etc - */ - -static /* inline */ bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) -{ - s7_pointer f = lookup_unexamined(sc, car(code)); - if ((f == opt1_lambda_unchecked(code)) || - ((f) && /* this fixup check does save time (e.g. cb) */ - (typesflag(f) == type) && - ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */ - (set_opt1_lambda(code, f)))) - return(true); - sc->last_function = f; - return(false); -} - -static /* inline */ bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) -{ - s7_pointer f = lookup_unexamined(sc, car(code)); - if ((f == opt1_lambda_unchecked(code)) || - ((f) && - ((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) && - ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && - (set_opt1_lambda(code, f)))) - return(true); - sc->last_function = f; - return(false); -} - -static bool closure_np_is_ok_1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer f = lookup_unexamined(sc, car(code)); - if ((f == opt1_lambda_unchecked(code)) || - ((f) && - (is_closure(f)) && - (set_opt1_lambda(code, f)))) - return(true); - sc->last_function = f; - return(false); -} - -#define closure_is_ok(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_ok_1(Sc, Code, Type, Args))) -#define closure_np_is_ok(Sc, Code) ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code))) -#define closure_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_fine_1(Sc, Code, Type, Args))) -#define closure_star_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_star_is_fine_1(Sc, Code, Type, Args))) - -static /* inline */ bool closure_is_eq(s7_scheme *sc) -{ - sc->last_function = lookup_unexamined(sc, car(sc->code)); - return(sc->last_function == opt1_lambda_unchecked(sc->code)); -} - -static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args) -{ - int32_t arity = closure_star_arity_to_int(sc, val); - return((arity < 0) || ((arity * 2) >= args)); -} - -static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) -{ - s7_pointer val = lookup_unexamined(sc, car(code)); - if ((val == opt1_lambda_unchecked(code)) || - ((val) && - ((typesflag(val) & (T_SAFE_CLOSURE | TYPE_MASK)) == type) && - (star_arity_is_ok(sc, val, args)) && - (set_opt1_lambda(code, val)))) - return(true); - sc->last_function = val; - return(false); -} - -/* closure_is_fine: */ -#define FINE_UNSAFE_CLOSURE (T_CLOSURE) -#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) - -/* closure_star_is_fine: */ -#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) -#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) - -/* closure_is_ok: */ -#define OK_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM) -#define OK_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM) -#define OK_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM) -#define OK_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM) -#define OK_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM_FX_ARG) -/* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */ - - -/* ---------------- eval ---------------- */ -static s7_pointer eval(s7_scheme *sc, opcode_t first_op) -{ - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args))); - sc->cur_op = first_op; - goto TOP_NO_POP; - - while (true) /* "continue" in this procedure refers to this loop */ - { - pop_stack(sc); - goto TOP_NO_POP; - - BEGIN: - if (is_pair(cdr(sc->code))) - { - set_current_code(sc, sc->code); - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - } - sc->code = car(sc->code); - - EVAL: - sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_choice) */ - - TOP_NO_POP: - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code))); - - /* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm - * callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code, - * macroized so it will work if such gotos aren't available. I think I'll stick with a switch statement. - * Another idea is to put the function in the tree, not an index to it (the optimize_op business above), - * then the switch below is not needed, and we free up 16 type bits. C does not guarantee tail calls (I think) - * so we'd have each function return the next, and eval would be [while (true) f = f(sc)] but would the function - * call overhead be less expensive than the switch? (We get most functions inlined in the current code). - * with some fake fx_calls for the P cases, many of these could be [sc->value = fx_function[sc->cur_op](sc, sc->code); continue;] - * so the switch statement is unnecessary -- maybe a table eval_functions[cur_op] eventually - */ - switch (sc->cur_op) - { - /* safe c_functions */ - case OP_SAFE_C_NC: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */ - case HOP_SAFE_C_NC: sc->value = fc_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ - - case OP_SAFE_C_S: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_s(sc)) goto EVAL; continue;} /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */ - case HOP_SAFE_C_S: inline_op_safe_c_s(sc); continue; - - case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SS: inline_op_safe_c_ss(sc); continue; - - case OP_SAFE_C_NS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_NS: sc->value = fx_c_ns(sc, sc->code); continue; - - case OP_SAFE_C_SC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SC: op_safe_c_sc(sc); continue; - - case OP_SAFE_C_CS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CS: sc->value = fx_c_cs(sc, sc->code); continue; - - case OP_SAFE_C_CQ: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); continue; - - case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_C_FF: sc->value = fx_c_ff(sc, sc->code); continue; - - case OP_SAFE_C_P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_P: op_safe_c_p(sc); goto EVAL; - case OP_SAFE_C_P_1: op_safe_c_p_1(sc); continue; - - case OP_ANY_C_NP: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_C_NP: if (op_any_c_np(sc)) goto EVAL; continue; - case OP_ANY_C_NP_1: if (inline_op_any_c_np_1(sc)) goto EVAL; continue; - case OP_ANY_C_NP_2: op_any_c_np_2(sc); continue; - case OP_ANY_C_NP_MV: if (op_any_c_np_mv(sc)) goto EVAL; goto APPLY; - - case OP_SAFE_C_SSP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSP: op_safe_c_ssp(sc); goto EVAL; - case OP_SAFE_C_SSP_1: op_safe_c_ssp_1(sc); continue; - case OP_SAFE_C_SSP_MV: op_safe_c_ssp_mv(sc); goto APPLY; - - case OP_SAFE_C_A: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_C_A: sc->value = fx_c_a(sc, sc->code); continue; - - case OP_SAFE_C_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); continue; - - case OP_SAFE_C_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); continue; - - case OP_SAFE_C_opAAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); continue; - - case OP_SAFE_C_S_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); continue; - - case OP_SAFE_C_opAq_S: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); continue; - - case OP_SAFE_C_S_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); continue; - - case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; - - case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; - - case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; - - case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; - - case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; - - case OP_SAFE_C_AAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AAA: sc->value = fx_c_aaa(sc, sc->code); continue; - - case OP_SAFE_C_SAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAA: sc->value = fx_c_saa(sc, sc->code); continue; - - case OP_SAFE_C_SSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSA: sc->value = fx_c_ssa(sc, sc->code); continue; - case HOP_HASH_TABLE_INCREMENT: sc->value = fx_hash_table_increment(sc, sc->code); continue; /* a placeholder, almost never called */ - - case OP_SAFE_C_SAS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAS: sc->value = fx_c_sas(sc, sc->code); continue; - - case OP_SAFE_C_ASS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ASS: sc->value = fx_c_ass(sc, sc->code); continue; - - case OP_SAFE_C_AGG: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AGG: sc->value = fx_c_agg(sc, sc->code); continue; - - case OP_SAFE_C_CAC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CAC: sc->value = fx_c_cac(sc, sc->code); continue; - - case OP_SAFE_C_CSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSA: sc->value = fx_c_csa(sc, sc->code); continue; - - case OP_SAFE_C_SCA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCA: sc->value = fx_c_sca(sc, sc->code); continue; - - case OP_SAFE_C_4A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_4A: sc->value = fx_c_4a(sc, sc->code); continue; - - case OP_SAFE_C_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_NA: sc->value = fx_c_na(sc, sc->code); continue; - - case OP_SAFE_C_ALL_CA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ALL_CA: sc->value = fx_c_all_ca(sc, sc->code); continue; - - case OP_SAFE_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCS: sc->value = fx_c_scs(sc, sc->code); continue; - - case OP_SAFE_C_SSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); continue; - - case OP_SAFE_C_SCC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); continue; - - case OP_SAFE_C_CSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); continue; - - case OP_SAFE_C_CCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CCS: sc->value = fx_c_ccs(sc, sc->code); continue; - - case OP_SAFE_C_CSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSS: sc->value = fx_c_css(sc, sc->code); continue; - - case OP_SAFE_C_SSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); continue; - - case OP_SAFE_C_opNCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opNCq: sc->value = fx_c_opncq(sc, sc->code); continue; - - case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq: sc->value = fx_c_opsq(sc, sc->code); continue; - - case OP_SAFE_C_op_opSqq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue; /* lg cb (splits to not) */ - - case OP_SAFE_C_op_S_opSqq: if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) break; - case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; /* tlet sg (splits to not) */ - - case OP_SAFE_C_op_opSq_Sq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; /* lg cb (splits to not etc) */ - - case OP_SAFE_C_PS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PS: op_safe_c_ps(sc); goto EVAL; - case OP_SAFE_C_PS_1: op_safe_c_ps_1(sc); continue; - case OP_SAFE_C_PS_MV: op_safe_c_ps_mv(sc); goto APPLY; - - case OP_SAFE_C_PC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PC: op_safe_c_pc(sc); goto EVAL; - case OP_SAFE_C_PC_1: op_safe_c_pc_1(sc); continue; - case OP_SAFE_C_PC_MV: op_safe_c_pc_mv(sc); goto APPLY; - - case OP_SAFE_C_SP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SP: op_safe_c_sp(sc); goto EVAL; - case OP_SAFE_C_SP_1: op_safe_c_sp_1(sc); continue; - case OP_SAFE_C_SP_MV: op_safe_c_sp_mv(sc); goto APPLY; - - case OP_SAFE_CONS_SP_1: sc->value = cons(sc, sc->args, sc->value); continue; - case OP_SAFE_ADD_SP_1: op_safe_add_sp_1(sc); continue; - case OP_SAFE_MULTIPLY_SP_1: op_safe_multiply_sp_1(sc); continue; - - case OP_SAFE_C_AP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AP: if (op_safe_c_ap(sc)) goto EVAL; continue; - - case OP_SAFE_C_PA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PA: if (op_safe_c_pa(sc)) goto EVAL; continue; - case OP_SAFE_C_PA_1: op_safe_c_pa_1(sc); continue; - case OP_SAFE_C_PA_MV: op_safe_c_pa_mv(sc); goto APPLY; - - case OP_SAFE_C_CP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CP: op_safe_c_cp(sc); goto EVAL; - - case OP_SAFE_C_PP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PP: op_safe_c_pp(sc); goto EVAL; - case OP_SAFE_C_PP_1: op_safe_c_pp_1(sc); goto EVAL; - case OP_SAFE_C_PP_3_MV: op_safe_c_pp_3_mv(sc); goto EVAL; - case OP_SAFE_C_PP_5: op_safe_c_pp_5(sc); goto APPLY; - case OP_SAFE_C_PP_6_MV: op_safe_c_pp_6_mv(sc); goto APPLY; - - case OP_SAFE_C_3P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_3P: op_safe_c_3p(sc); goto EVAL; - case OP_SAFE_C_3P_1: op_safe_c_3p_1(sc); goto EVAL; - case OP_SAFE_C_3P_2: op_safe_c_3p_2(sc); goto EVAL; - case OP_SAFE_C_3P_3: op_safe_c_3p_3(sc); continue; - case OP_SAFE_C_3P_1_MV: op_safe_c_3p_1_mv(sc); goto EVAL; - case OP_SAFE_C_3P_2_MV: op_safe_c_3p_2_mv(sc); goto EVAL; - case OP_SAFE_C_3P_3_MV: op_safe_c_3p_3_mv(sc); goto APPLY; - - case OP_SAFE_C_opSSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); continue; - - case OP_SAFE_C_opSCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); continue; - - case OP_SAFE_C_opCSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); continue; - - case OP_SAFE_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); continue; - - case OP_SAFE_C_C_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); continue; - - case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue; - - case OP_SAFE_C_opCSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); continue; - - case OP_SAFE_C_op_opSSqq_S: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSSqq_S: sc->value = fx_c_op_opssqq_s(sc, sc->code); continue; - - case OP_SAFE_C_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue; - - case OP_SAFE_C_opCSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); continue; - - case OP_SAFE_C_S_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); continue; - - case OP_SAFE_C_C_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); continue; - - case OP_SAFE_C_S_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); continue; - - case OP_SAFE_C_S_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); continue; - - case OP_SAFE_C_opSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); continue; - - case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue; - - case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue; - - case OP_SAFE_C_opSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); continue; - - case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue; - - - /* semisafe c_functions */ - case OP_CL_S: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_S: inline_op_safe_c_s(sc); continue; - - case OP_CL_SS: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_SS: inline_op_safe_c_ss(sc); continue; /* safe_c case has the code we want */ - - case OP_CL_A: if (!cl_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_CL_A: op_cl_a(sc); continue; - - case OP_CL_AA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_AA: op_cl_aa(sc); continue; - - case OP_CL_SAS: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_SAS: op_cl_sas(sc); continue; - - case OP_CL_NA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_NA: op_cl_na(sc); continue; - - case OP_CL_FA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_FA: op_cl_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ - case OP_MAP_FOR_EACH_FA: op_map_for_each_fa(sc); continue; /* here only if for-each or map + one seq */ - case OP_MAP_FOR_EACH_FAA: op_map_for_each_faa(sc); continue; /* here only if for-each or map + twp seqs */ - - - /* unsafe c_functions */ - case OP_C: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S); goto EVAL;} - case HOP_C: sc->value = fn_proc(sc->code)(sc, sc->nil); continue; - - case OP_C_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} - case HOP_C_S: op_c_s(sc); continue; - - case OP_READ_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} - case HOP_READ_S: op_read_s(sc); continue; - - case OP_C_A: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_C_A: op_c_a(sc); continue; - - case OP_C_P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_P: op_c_p(sc); goto EVAL; - case OP_C_P_1: sc->value = fn_proc(sc->code)(sc, list_1(sc, sc->value)); continue; - case OP_C_P_MV: op_c_p_mv(sc); goto APPLY; - - case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_SS: op_c_ss(sc); continue; - - case OP_C_AP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AP: op_c_ap(sc); goto EVAL; - case OP_C_AP_1: sc->value = fn_proc(sc->code)(sc, sc->args = list_2(sc, sc->args, sc->value)); continue; - case OP_C_AP_MV: op_c_ap_mv(sc); goto APPLY; - - case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AA: op_c_aa(sc); continue; - - case OP_C_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_NA: op_c_na(sc); continue; - - case OP_APPLY_SS: inline_op_apply_ss(sc); goto APPLY; - case OP_APPLY_SA: op_apply_sa(sc); goto APPLY; - case OP_APPLY_SL: op_apply_sl(sc); goto APPLY; - - case OP_CALL_WITH_EXIT: op_call_with_exit(sc); goto BEGIN; - case OP_CALL_CC: op_call_cc(sc); goto BEGIN; - case OP_CALL_WITH_EXIT_O: op_call_with_exit_o(sc); goto EVAL; - case OP_C_CATCH: op_c_catch(sc); goto BEGIN; - case OP_C_CATCH_ALL: op_c_catch_all(sc); goto BEGIN; - case OP_C_CATCH_ALL_O: op_c_catch_all(sc); goto EVAL; - case OP_C_CATCH_ALL_A: op_c_catch_all_a(sc); continue; - - case OP_WITH_IO: if (op_with_io_op(sc)) goto EVAL; goto BEGIN; - case OP_WITH_IO_1: - if (!is_string(sc->value)) {op_with_io_1_method(sc); continue;} - sc->code = op_with_io_1(sc); - goto BEGIN; - - case OP_WITH_IO_C: sc->value = cadr(sc->code); sc->code = op_with_io_1(sc); goto BEGIN; - case OP_WITH_OUTPUT_TO_STRING: op_with_output_to_string(sc); goto BEGIN; - case OP_CALL_WITH_OUTPUT_STRING: op_call_with_output_string(sc); goto BEGIN; - - - case OP_F: op_f(sc); goto BEGIN; - case OP_F_A: op_f_a(sc); goto BEGIN; - case OP_F_AA: op_f_aa(sc); goto BEGIN; - case OP_F_NP: op_f_np(sc); goto EVAL; - case OP_F_NP_1: if (op_f_np_1(sc)) goto EVAL; goto BEGIN; - - case OP_S: op_s(sc); goto APPLY; - case OP_S_G: if (op_s_g(sc)) continue; goto APPLY; - case OP_S_A: if (op_x_a(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; - case OP_A_A: if (op_x_a(sc, fx_call(sc, sc->code))) continue; goto APPLY; - case OP_S_AA: op_x_aa(sc, lookup_checked(sc, car(sc->code))); goto APPLY; - case OP_A_AA: op_x_aa(sc, fx_call(sc, sc->code)); goto APPLY; - case OP_P_S: push_stack_no_args_direct(sc, OP_P_S_1); sc->code = car(sc->code); goto EVAL; - case OP_P_S_1: op_p_s_1(sc); goto APPLY; - - case OP_SAFE_C_STAR: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR: op_safe_c_star(sc); continue; - - case OP_SAFE_C_STAR_A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_A: op_safe_c_star_a(sc); continue; - - case OP_SAFE_C_STAR_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_AA: op_safe_c_star_aa(sc); continue; - - case OP_SAFE_C_STAR_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_NA: op_safe_c_star_na(sc); continue; - - - case OP_THUNK: if (!closure_is_ok(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_THUNK: op_thunk(sc); goto EVAL; - - case OP_THUNK_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_THUNK_O: op_thunk_o(sc); goto EVAL; - - case OP_SAFE_THUNK: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_THUNK: op_safe_thunk(sc); goto EVAL; - - case OP_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; /* symbol as arglist */ - case HOP_THUNK_ANY: op_thunk_any(sc); goto BEGIN; - - case OP_SAFE_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; /* symbol as arglist */ - case HOP_SAFE_THUNK_ANY: op_safe_thunk_any(sc); goto EVAL; - - case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_THUNK_A: sc->value = op_safe_thunk_a(sc, sc->code); continue; - - case OP_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_CLOSURE_S: op_closure_s(sc); goto EVAL; - - case OP_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_CLOSURE_S_O: op_closure_s_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto EVAL; - - case OP_SAFE_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_O: op_safe_closure_s_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_A: sc->value = op_safe_closure_s_a(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_S_TO_S: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_TO_S: sc->value = fx_safe_closure_s_to_s(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_S_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_proc(cdr(sc->code))(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_A_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_proc(sc->code)(sc, sc->code); continue; - - case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL; - case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_P: op_safe_closure_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_P_1: op_safe_closure_p_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_P_A: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_P_A: op_safe_closure_p_a(sc); goto EVAL; - case OP_SAFE_CLOSURE_P_A_1: op_safe_closure_p_a_1(sc); continue; - - case OP_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_A: inline_op_closure_a(sc); push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); sc->code = car(sc->code); goto EVAL; - - case OP_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_A_O: inline_op_closure_a(sc); sc->code = car(sc->code); goto EVAL; - - case OP_SAFE_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A: op_safe_closure_a(sc); goto EVAL; - - case OP_SAFE_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_O: op_safe_closure_a_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_A_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_A: sc->value = op_safe_closure_a_a(sc, sc->code); continue; - - case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AP: op_closure_ap(sc); goto EVAL; - case OP_CLOSURE_AP_1: op_closure_ap_1(sc); goto BEGIN; - - case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_PA: op_closure_pa(sc); goto EVAL; - case OP_CLOSURE_PA_1: op_closure_pa_1(sc); goto BEGIN; - - case OP_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL; - case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AP: op_safe_closure_ap(sc); goto EVAL; - case OP_SAFE_CLOSURE_AP_1: op_safe_closure_ap_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_PA: op_safe_closure_pa(sc); goto EVAL; - case OP_SAFE_CLOSURE_PA_1: op_safe_closure_pa_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_PP: op_safe_closure_pp(sc); goto EVAL; - case OP_SAFE_CLOSURE_PP_1: op_safe_closure_pp_1(sc); goto EVAL; - - case OP_ANY_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_3P: op_any_closure_3p(sc); goto EVAL; - case OP_ANY_CLOSURE_3P_1: if (!op_any_closure_3p_1(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_3P_2: if (!op_any_closure_3p_2(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_3P_3: op_any_closure_3p_3(sc); goto BEGIN; - - case OP_ANY_CLOSURE_4P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_4P: op_any_closure_4p(sc); goto EVAL; - case OP_ANY_CLOSURE_4P_1: if (!op_any_closure_4p_1(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_2: if (!op_any_closure_4p_2(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_3: if (!op_any_closure_4p_3(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_4: op_any_closure_4p_4(sc); goto BEGIN; - - case OP_CLOSURE_FA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; - case HOP_CLOSURE_FA: op_closure_fa(sc); goto EVAL; - - case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; - - case OP_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SS_O: op_closure_ss_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS_O: op_safe_closure_ss_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS_A: sc->value = op_safe_closure_ss_a(sc, sc->code); continue; - - case OP_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3S: op_closure_3s(sc); goto EVAL; /* "fine" here means changing func (as arg) does not constantly call op_unknown_ns */ - - case OP_CLOSURE_3S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3S_O: op_closure_3s_o(sc); goto EVAL; - - case OP_CLOSURE_4S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4S: op_closure_4s(sc); goto EVAL; - - case OP_CLOSURE_4S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4S_O: op_closure_4s_o(sc); goto EVAL; - - case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; - - case OP_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SC_O: op_closure_sc_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SC_O: op_safe_closure_sc_o(sc); goto EVAL; - - case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; - - case OP_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AA_O: inline_op_closure_aa_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA_O: op_safe_closure_aa_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_SSA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SSA: op_safe_closure_ssa(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AGG: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AGG: op_safe_closure_agg(sc); goto EVAL; - - case OP_SAFE_CLOSURE_3A: if (!closure_is_ok(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3A: op_safe_closure_3a(sc); goto EVAL; - - case OP_SAFE_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_NS: op_safe_closure_ns(sc); goto EVAL; - - case OP_SAFE_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_NA: op_safe_closure_na(sc); goto EVAL; - - case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto EVAL; - - case OP_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3S_A: sc->value = op_safe_closure_3s_a(sc, sc->code); continue; - - case OP_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_NS: op_closure_ns(sc); goto EVAL; - - case OP_CLOSURE_ASS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_ASS: op_closure_ass(sc); goto EVAL; - - case OP_CLOSURE_AAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AAS: op_closure_aas(sc); goto EVAL; - - case OP_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SAA: op_closure_saa(sc); goto EVAL; - - case OP_CLOSURE_ASA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_ASA: op_closure_asa(sc); goto EVAL; - - case OP_CLOSURE_SAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SAS: op_closure_sas(sc); goto EVAL; - - case OP_CLOSURE_3A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3A: op_closure_3a(sc); goto EVAL; - - case OP_CLOSURE_4A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4A: op_closure_4a(sc); goto EVAL; - - case OP_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_NA: op_closure_na(sc); goto EVAL; - - case OP_ANY_CLOSURE_NP: if (!closure_np_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_NP: op_any_closure_np(sc); goto EVAL; - case OP_ANY_CLOSURE_NP_1: - if (!(inline_collect_np_args(sc, OP_ANY_CLOSURE_NP_1, cons(sc, sc->value, sc->args)))) - op_any_closure_np_end(sc); - goto EVAL; - case OP_ANY_CLOSURE_NP_2: - sc->args = cons(sc, sc->value, sc->args); - op_any_closure_np_end(sc); - goto EVAL; - case OP_ANY_CLOSURE_NP_MV: /* this is an error -- a values call confusing the optimizer's arg count */ - if (!(collect_np_args(sc, OP_ANY_CLOSURE_NP_MV, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args)))) - op_any_closure_np_end(sc); - goto EVAL; - - case OP_ANY_CLOSURE_SYM: if (!check_closure_sym(sc, 1)) break; /* (lambda args ...) */ - case HOP_ANY_CLOSURE_SYM: op_any_closure_sym(sc); goto BEGIN; - case OP_ANY_CLOSURE_A_SYM: if (!check_closure_sym(sc, 2)) break; /* (lambda (a . args) ...) */ - case HOP_ANY_CLOSURE_A_SYM: op_any_closure_a_sym(sc); goto BEGIN; - - - case OP_TC_AND_A_OR_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_la(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_LAA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_laa(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LAA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_laa(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_L3A: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_l3a(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_l3a(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; - - case OP_TC_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_COND_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_COND_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, true)) continue; goto EVAL; - - case OP_TC_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND)) continue; goto EVAL; - case OP_TC_WHEN_LA: tick_tc(sc, sc->cur_op); op_tc_when_la(sc, sc->code); continue; - case OP_TC_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_when_laa(sc, sc->code); continue; - case OP_TC_WHEN_L3A: tick_tc(sc, sc->cur_op); op_tc_when_l3a(sc, sc->code); continue; - - case OP_TC_IF_A_Z_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_IF_A_L3A_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))continue; goto EVAL; - case OP_TC_AND_A_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) continue; goto EVAL; - case OP_TC_AND_A_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) continue; goto EVAL; - - case OP_TC_LET_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, true, sc->code); continue; - case OP_TC_LET_UNLESS_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, false, sc->code); continue; - - case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc(sc, sc->cur_op); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_CASE_LA: tick_tc(sc, sc->cur_op); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; - case OP_TC_LET_COND: tick_tc(sc, sc->cur_op); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; - - case OP_RECUR_IF_A_A_opA_LAq: wrap_recur_if_a_a_opa_laq(sc, true, true); continue; - case OP_RECUR_IF_A_A_opLA_Aq: wrap_recur_if_a_a_opa_laq(sc, true, false); continue; - case OP_RECUR_IF_A_opA_LAq_A: wrap_recur_if_a_a_opa_laq(sc, false, true); continue; - case OP_RECUR_IF_A_opLA_Aq_A: wrap_recur_if_a_a_opa_laq(sc, false, false); continue; - case OP_RECUR_IF_A_A_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_opa_laaq); continue; - case OP_RECUR_IF_A_A_opA_L3Aq: wrap_recur(sc, op_recur_if_a_a_opa_l3aq); continue; - case OP_RECUR_IF_A_opA_LAAq_A: wrap_recur(sc, op_recur_if_a_opa_laaq_a); continue; - case OP_RECUR_IF_A_A_opLA_LAq: wrap_recur_if_a_a_opla_laq(sc, true); continue; - case OP_RECUR_IF_A_opLA_LAq_A: wrap_recur_if_a_a_opla_laq(sc, false); continue; - case OP_RECUR_IF_A_A_opA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_la_laq); continue; - case OP_RECUR_IF_A_opA_LA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_la_laq_a); continue; - case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq: wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq); continue; - case OP_RECUR_IF_A_A_AND_A_LAA_LAA: wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa); continue; - case OP_RECUR_IF_A_A_opLA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opla_la_laq); continue; - case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); continue; - case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_opla_laq); continue; - case OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_oplaa_laaq); continue; - case OP_RECUR_COND_A_A_opA_LAq: wrap_recur(sc, op_recur_cond_a_a_opa_laq); continue; - case OP_RECUR_COND_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_A_opLA_LAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); continue; - case OP_RECUR_COND_A_A_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); continue; - case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); continue; - case OP_RECUR_AND_A_OR_A_LAA_LAA: wrap_recur(sc, op_recur_and_a_or_a_laa_laa); continue; - - - case OP_SAFE_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_A: op_safe_closure_star_a(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_A1: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_A1: op_safe_closure_star_a1(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_KA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_KA: op_safe_closure_star_ka(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_AA: op_safe_closure_star_aa(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_AA_O: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_AA_O: op_safe_closure_star_aa(sc, sc->code); sc->code = car(sc->code); goto EVAL; - - case OP_SAFE_CLOSURE_STAR_3A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_3A: if (op_safe_closure_star_aaa(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA: - if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) - {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA: if (op_safe_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_0: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_0: if (op_safe_closure_star_na_0(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_1: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_1: if (op_safe_closure_star_na_1(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_2: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_2: if (op_safe_closure_star_na_2(sc, sc->code)) goto EVAL; goto BEGIN; - - - case OP_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_A: op_closure_star_a(sc, sc->code); goto BEGIN; - - case OP_CLOSURE_STAR_KA: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_KA: op_closure_star_ka(sc, sc->code); goto BEGIN; - - case OP_CLOSURE_STAR_NA: - if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) - {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_NA: if (op_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - - - case OP_UNKNOWN: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown(sc)) goto EVAL; continue; - case OP_UNKNOWN_NS: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_ns(sc)) goto EVAL; continue; - case OP_UNKNOWN_S: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_s(sc)) goto EVAL; continue; - case OP_UNKNOWN_GG: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_gg(sc)) goto EVAL; continue; - case OP_UNKNOWN_A: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_a(sc)) goto EVAL; continue; - case OP_UNKNOWN_AA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_aa(sc)) goto EVAL; continue; - case OP_UNKNOWN_NA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_na(sc)) goto EVAL; continue; - case OP_UNKNOWN_NP: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_np(sc)) goto EVAL; continue; - - - case OP_IMPLICIT_VECTOR_REF_A: if (!inline_op_implicit_vector_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_VECTOR_REF_AA: if (!op_implicit_vector_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; - case OP_IMPLICIT_STRING_REF_A: if (!op_implicit_string_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_HASH_TABLE_REF_A: if (!op_implicit_hash_table_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_HASH_TABLE_REF_AA: if (!op_implicit_hash_table_ref_aa(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_CONTINUATION_A: if (!op_implicit_continuation_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_ITERATE: if (!op_implicit_iterate(sc)) {if (op_unknown(sc)) goto EVAL;} continue; - case OP_IMPLICIT_LET_REF_C: if (!op_implicit_let_ref_c(sc)) {if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc))) goto EVAL;} continue; - case OP_IMPLICIT_LET_REF_A: if (!op_implicit_let_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_PAIR_REF_A: if (!op_implicit_pair_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_PAIR_REF_AA: if (!op_implicit_pair_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; - case OP_IMPLICIT_C_OBJECT_REF_A: if (!op_implicit_c_object_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_GOTO: if (!op_implicit_goto(sc)) {if (op_unknown(sc)) goto EVAL;} continue; - case OP_IMPLICIT_GOTO_A: if (!op_implicit_goto_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_VECTOR_SET_3: if (op_implicit_vector_set_3(sc)) goto EVAL; continue; - case OP_IMPLICIT_VECTOR_SET_4: if (op_implicit_vector_set_4(sc)) goto EVAL; continue; - case OP_IMPLICIT_S7_STARLET_REF_S: sc->value = s7_starlet(sc, opt3_int(sc->code)); continue; - case OP_IMPLICIT_S7_STARLET_SET: - sc->value = s7_starlet_set_1(sc, opt3_sym(sc->code), fx_call(sc, cddr(sc->code))); - continue; - - case OP_UNOPT: goto UNOPT; - case OP_SYMBOL: sc->value = lookup_checked(sc, sc->code); continue; - case OP_CONSTANT: sc->value = sc->code; continue; - case OP_PAIR_PAIR: if (op_pair_pair(sc)) goto EVAL; continue; /* car is pair ((if x car cadr) ...) */ - case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; - case OP_PAIR_SYM: if (op_pair_sym(sc)) goto EVAL_ARGS_TOP; continue; - - case OP_EVAL_ARGS1: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS; - case OP_EVAL_ARGS2: op_eval_args2(sc); goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ - case OP_EVAL_ARGS3: op_eval_args3(sc); goto APPLY; /* sc->value is the next-to-last arg, and the last arg is not a list (so values can't mess us up!) */ - case OP_EVAL_ARGS4: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS_PAIR; - case OP_EVAL_ARGS5: op_eval_args5(sc); goto APPLY; - - EVAL_ARGS_TOP: - case OP_EVAL_ARGS: - if (dont_eval_args(sc->value)) - { - if (eval_args_no_eval_args(sc)) goto APPLY; - goto TOP_NO_POP; - } - sc->code = cdr(sc->code); - /* sc->value is the func (but can be anything if the code is messed up: (#\a 3)) - * we don't have to delay lookup of the func because arg evaluation order is not specified, so - * (let ((func +)) (func (let () (set! func -) 3) 2)) - * can return 5. - */ - push_op_stack(sc, sc->value); - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - sc->args = sc->nil; - - EVAL_ARGS: /* first time, value = op, args = nil, code is args */ - if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */ - { - if ((sc->safety > NO_SAFETY) && - (!is_safety_checked(sc->code))) - { - if (tree_is_cyclic(sc, sc->code)) - syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, sc->code); - set_safety_checked(sc->code); - } - EVAL_ARGS_PAIR: - if (is_pair(car(sc->code))) - { - eval_args_pair_car(sc); - goto EVAL; - } - if (is_pair(cdr(sc->code))) - { - s7_pointer car_code = car(sc->code); /* not a pair */ - sc->code = cdr(sc->code); - sc->value = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : T_Ext(car_code); - /* sc->value is the current arg's value, sc->code is pointing to the next */ - - /* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ - if (is_null(cdr(sc->code))) - { - if (eval_args_last_arg(sc)) goto EVAL; - /* drop into APPLY */ - } - else - { - /* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */ - sc->args = cons(sc, sc->value, sc->args); - goto EVAL_ARGS_PAIR; - }} - else eval_last_arg(sc, car(sc->code)); - /* drop into APPLY */ - } - else /* got all args -- go to apply */ - { - /* *(--sc->op_stack_now) is the "function" (sc->value perhaps), sc->code is the arglist end, sc->args might be the preceding args reversed? */ - if (is_not_null(sc->code)) - improper_arglist_error_nr(sc); - sc->code = pop_op_stack(sc); - sc->args = proper_list_reverse_in_place(sc, sc->args); - } - /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower. - * the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead, - * and the function-local overhead currently otherwise 0 if inlined. - */ - APPLY: - case OP_APPLY: - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s[%d]: op_apply %s (%s) to %s\n", __func__, __LINE__, - display_80(sc->code), s7_type_names[type(sc->code)], display_80(sc->args))); - switch (type(sc->code)) - { - case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue; - case T_C_RST_NO_REQ_FUNCTION: apply_c_rst_no_req_function(sc); continue; - case T_C_FUNCTION_STAR: apply_c_function_star(sc); continue; - case T_CONTINUATION: call_with_current_continuation(sc); continue; - case T_GOTO: call_with_exit(sc); continue; - case T_C_OBJECT: apply_c_object(sc); continue; - case T_STRING: apply_string(sc); continue; - case T_HASH_TABLE: apply_hash_table(sc); continue; - case T_ITERATOR: apply_iterator(sc); continue; - case T_LET: apply_let(sc); continue; - case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: apply_vector(sc); continue; - case T_SYNTAX: apply_syntax(sc); goto TOP_NO_POP; - case T_PAIR: if (apply_pair(sc)) continue; goto APPLY; - case T_CLOSURE: apply_closure(sc); goto APPLY_LAMBDA; - case T_CLOSURE_STAR: if (apply_closure_star(sc)) goto EVAL; goto BEGIN; - case T_C_MACRO: apply_c_macro(sc); goto EVAL; - case T_MACRO: apply_macro(sc); goto APPLY_LAMBDA; - case T_BACRO: apply_bacro(sc); goto APPLY_LAMBDA; - case T_MACRO_STAR: apply_macro_star(sc); goto BEGIN; - case T_BACRO_STAR: apply_bacro_star(sc); goto BEGIN; - default: apply_error_nr(sc, sc->code, sc->args); - } - - case OP_MACRO_STAR_D: if (op_macro_star_d(sc)) goto EVAL_ARGS_TOP; goto BEGIN; - case OP_MACRO_D: if (op_macro_d(sc, T_MACRO)) goto EVAL_ARGS_TOP; /* fall through presumably */ - - APPLY_LAMBDA: - case OP_APPLY_LAMBDA: - inline_apply_lambda(sc); - goto BEGIN; - - case OP_LAMBDA_STAR_DEFAULT: if (op_lambda_star_default(sc)) goto EVAL; goto BEGIN; - - case OP_MACROEXPAND_1: - switch (op_macroexpand_1(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - case OP_MACROEXPAND: - switch (op_macroexpand(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - - - HEAPSORT: if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto APPLY; - case OP_SORT1: op_sort1(sc); goto APPLY; - case OP_SORT2: if (op_sort2(sc)) continue; goto HEAPSORT; - case OP_SORT: if (!op_sort(sc)) goto HEAPSORT; - case OP_SORT3: if (op_sort3(sc)) continue; goto HEAPSORT; - case OP_SORT_PAIR_END: sc->value = vector_into_list(sc, sc->value, car(sc->args)); continue; - case OP_SORT_VECTOR_END: sc->value = vector_into_fi_vector(sc->value, car(sc->args)); continue; - case OP_SORT_STRING_END: sc->value = vector_into_string(sc->value, car(sc->args)); continue; - -#if S7_DEBUGGING - case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if opt succeeds then func called */ - fprintf(stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - sc->map_call_ctr--; - if (sc->map_call_ctr < 0) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - continue; -#endif - case OP_MAP_GATHER: inline_op_map_gather(sc); - case OP_MAP: if (op_map(sc)) continue; goto APPLY; - - case OP_MAP_GATHER_1: inline_op_map_gather(sc); - case OP_MAP_1: if (op_map_1(sc)) continue; goto BEGIN; - - case OP_MAP_GATHER_2: - case OP_MAP_GATHER_3: inline_op_map_gather(sc); - case OP_MAP_2: if (op_map_2(sc)) continue; goto EVAL; - - case OP_FOR_EACH: if (op_for_each(sc)) continue; goto APPLY; - case OP_FOR_EACH_1: if (inline_op_for_each_1(sc)) continue; goto BEGIN; - - case OP_FOR_EACH_2: - case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; goto EVAL; - - case OP_MEMBER_IF: - case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; - - case OP_ASSOC_IF: - case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; - - - case OP_SAFE_DOTIMES: /* gen form */ - SAFE_DOTIMES: /* check_do */ - switch (op_safe_dotimes(sc)) - { - case goto_safe_do_end_clauses: if (is_null(sc->code)) continue; goto DO_END_CODE; - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_eval: goto EVAL; - case goto_top_no_pop: goto TOP_NO_POP; - default: goto BEGIN; - } - - case OP_SAFE_DO: - SAFE_DO: /* from check_do */ - switch (op_safe_do(sc)) /* mat */ - { - case goto_safe_do_end_clauses: - if (is_null(sc->code)) continue; /* multiple values (as test result) can't happen -- safe do loops involve counters by 1 to some integer end */ - goto DO_END_CODE; - case goto_do_unchecked: goto DO_UNCHECKED; - default: goto BEGIN; - } - - case OP_DOTIMES_P: - DOTIMES_P: /* from check_do */ - switch (op_dotimes_p(sc)) - { - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_do_unchecked: goto DO_UNCHECKED; - default: goto EVAL; - } - - case OP_DOX: - DOX: /* from check_do */ - switch (op_dox(sc)) /* lg fft exit */ - { - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_start: continue; - case goto_top_no_pop: goto TOP_NO_POP; /* includes dox_step_o */ - default: goto BEGIN; - } - - DO_NO_BODY: - case OP_DO_NO_BODY_NA_VARS: op_do_no_body_na_vars(sc); goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP: if (op_do_no_body_na_vars_step(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP_1: if (op_do_no_body_na_vars_step_1(sc)) goto DO_END_CLAUSES; goto EVAL; - - case OP_DO_NO_VARS_NO_OPT: op_do_no_vars_no_opt(sc); /* fall through */ - case OP_DO_NO_VARS_NO_OPT_1: if (op_do_no_vars_no_opt_1(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SAFE_DOTIMES_STEP_O: if (op_safe_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_SAFE_DOTIMES_STEP: if (op_safe_dotimes_step(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_SAFE_DO_STEP: if (op_safe_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SIMPLE_DO: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SIMPLE_DO_STEP: if (op_simple_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOTIMES_STEP_O: if (op_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_DOX_INIT: if (op_dox_init(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOX_STEP: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step(sc); goto BEGIN; - case OP_DOX_STEP_O: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step_o(sc); goto EVAL; - case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; - case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - - case OP_DO_INIT: if (op_do_init(sc)) goto DO_END; goto EVAL; - - case OP_DO: - if (is_null(check_do(sc))) - switch (optimize_op(sc->code)) - { - case OP_DOX: goto DOX; - case OP_SAFE_DOTIMES: goto SAFE_DOTIMES; - case OP_DOTIMES_P: goto DOTIMES_P; - case OP_SAFE_DO: goto SAFE_DO; - case OP_DO_NO_BODY_NA_VARS: goto DO_NO_BODY; - case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; - case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - default: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; - } - - case OP_DO_UNCHECKED: - op_do_unchecked(sc); - DO_UNCHECKED: - if (do_unchecked(sc)) goto EVAL; - - DO_END: - case OP_DO_END: - if (op_do_end(sc)) goto EVAL; - - case OP_DO_END1: - if (is_true(sc, sc->value)) - { - goto_t next = op_do_end_true(sc); - if (next == goto_start) continue; - if (next == goto_eval) goto EVAL; - goto FEED_TO; - } - else - { - goto_t next = op_do_end_false(sc); - if (next == goto_begin) goto BEGIN; - if (next == goto_do_end) goto DO_END; - /* fall through */ - } - - case OP_DO_STEP: if (op_do_step(sc)) goto DO_END; goto EVAL; - case OP_DO_STEP2: if (op_do_step2(sc)) goto DO_END; goto EVAL; - - DO_END_CLAUSES: - if (do_end_clauses(sc)) continue; - DO_END_CODE: - { - goto_t next = do_end_code(sc); - if (next == goto_eval) goto EVAL; - if (next == goto_start) continue; - goto FEED_TO; - } - - - case OP_BEGIN_UNCHECKED: - set_current_code(sc, sc->code); - sc->code = T_Pair(cdr(sc->code)); - goto BEGIN; - - case OP_BEGIN: - if (op_begin(sc, sc->code)) continue; - sc->code = T_Pair(cdr(sc->code)); - - case OP_BEGIN_HOOK: - if (sc->begin_hook) - { - /* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */ - set_current_code(sc, sc->code); - if (call_begin_hook(sc)) - return(sc->F); - } - case OP_BEGIN_NO_HOOK: - goto BEGIN; - - case OP_BEGIN_2_UNCHECKED: - push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); - sc->code = cadr(sc->code); - goto EVAL; - - case OP_BEGIN_AA: sc->value = fx_begin_aa(sc, sc->code); continue; - case OP_BEGIN_NA: sc->value = fx_begin_na(sc, sc->code); continue; - - - case OP_EVAL: goto EVAL; - case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; - - case OP_QUOTE: sc->value = check_quote(sc, sc->code); continue; - case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); continue; - - case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; - case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; - - case OP_DEFINE_CONSTANT_UNCHECKED: - push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code)); - goto DEFCONS; - - case OP_DEFINE_CONSTANT: - if (op_define_constant(sc)) continue; - - case OP_DEFINE_STAR: case OP_DEFINE: - check_define(sc); - - DEFCONS: - case OP_DEFINE_STAR_UNCHECKED: - case OP_DEFINE_UNCHECKED: - if (op_define_unchecked(sc)) goto TOP_NO_POP; - - case OP_DEFINE1: if (op_define1(sc)) goto APPLY; - case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue; - - case OP_SET_opSq_A: if (op_set_opsq_a(sc)) goto APPLY; continue; - case OP_SET_opSAq_A: if (op_set_opsaq_a(sc)) goto APPLY; continue; - case OP_SET_opSAq_P: if (op_set_opsaq_p(sc)) goto APPLY; goto EVAL; - case OP_SET_opSAq_P_1: if (op_set_opsaq_p_1(sc)) goto APPLY; continue; - case OP_SET_opSAAq_A: if (op_set_opsaaq_a(sc)) goto APPLY; continue; - case OP_SET_opSAAq_P: if (op_set_opsaaq_p(sc)) goto APPLY; goto EVAL; - case OP_SET_opSAAq_P_1: if (op_set_opsaaq_p_1(sc)) goto APPLY; continue; - - case OP_INCREMENT_BY_1: inline_op_increment_by_1(sc); continue; - case OP_DECREMENT_BY_1: op_decrement_by_1(sc); continue; - case OP_INCREMENT_SA: op_increment_sa(sc); continue; - case OP_INCREMENT_SAA: op_increment_saa(sc); continue; - - case OP_SET_S_C: op_set_s_c(sc); continue; - case OP_SET_S_S: op_set_s_s(sc); continue; - case OP_SET_S_A: op_set_s_a(sc); continue; - case OP_SET_S_P: op_set_s_p(sc); goto EVAL; - case OP_SET_CONS: op_set_cons(sc); continue; - case OP_SET_SAFE: op_set_safe(sc); continue; - - case OP_SET_FROM_SETTER: slot_set_value(sc->code, sc->value); continue; /* mv caught in splice_in_values */ - case OP_SET_FROM_LET_TEMP: op_set_from_let_temp(sc); continue; - - case OP_SET2: - switch (op_set2(sc)) /* imp */ - { - case goto_eval: goto EVAL; - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* goto_eval_args in funcs called by op_set2, unopt */ - } - - case OP_SET: check_set(sc); - case OP_SET_UNCHECKED: - SET_UNCHECKED: - if (is_pair(cadr(sc->code))) /* has setter */ - switch (set_implicit(sc)) - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* very common, op_unopt at this point */ - } - case OP_SET_NORMAL: if (op_set_normal(sc)) goto EVAL; - case OP_SET1: if (op_set1(sc)) continue; goto APPLY; - - case OP_SET_WITH_LET_1: if (op_set_with_let_1(sc)) goto TOP_NO_POP; goto SET_WITH_LET; - case OP_SET_WITH_LET_2: if (op_set_with_let_2(sc)) continue; - SET_WITH_LET: - activate_with_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */ - if (is_pair(cadr(sc->code))) - switch (set_implicit(sc)) /* imp misc */ - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* unopt */ - } - error_nr(sc, sc->no_setter_symbol, - set_elist_3(sc, wrap_string(sc, "can't set ~A in ~S", 18), cadr(sc->code), - list_3(sc, sc->set_symbol, - (is_pair(cadr(sc->code))) ? copy_proper_list(sc, cadr(sc->code)) : cadr(sc->code), - (is_pair(caddr(sc->code))) ? copy_proper_list(sc, caddr(sc->code)) : caddr(sc->code)))); - - - case OP_IF: op_if(sc); goto EVAL; - case OP_IF_UNCHECKED: op_if_unchecked(sc); goto EVAL; - case OP_IF1: if (op_if1(sc)) goto EVAL; continue; - - #define if_a_p(sc) if (is_true(sc, fx_call(sc, cdr(sc->code)))) - #define if_not_a_p(sc) if (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) /* cdadr(sc->code) */ - - case OP_IF_A_C_C: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code); continue; - case OP_IF_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_S_A_A: sc->value = (is_true(sc, lookup(sc, cadr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_A_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_A_A_P: if_a_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_A_P_A: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_NOT_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_NOT_A_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : fx_call(sc, opt3_pair(sc->code)); continue; - case OP_IF_AND2_S_A: sc->value = fx_if_and2_s_a(sc, sc->code); continue; - - #define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr) - case OP_IF_B_A: sc->value = (call_bfunc(sc, cadr(sc->code))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_B_A_P: if (call_bfunc(sc, cadr(sc->code))) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_B_P_A: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_B_P_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code)))) - #define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */ - - case OP_IF_S_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_S_R: if_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_S_P_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_S_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_S_N_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_S_P_A: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_S_A_P: if_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - - case OP_IF_A_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_A_R: if_a_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_A_P_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_A_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_A_N_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - case OP_IF_B_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_B_R: if (call_bfunc(sc, cadr(sc->code))) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_B_N_N: if (call_bfunc(sc, car(opt3_pair(sc->code)))) {sc->code = opt2_any(sc->code); goto EVAL;} sc->code = opt1_any(sc->code); goto EVAL; - - #define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) - #define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) - - case OP_IF_IS_TYPE_S_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_IS_TYPE_S_R: if_is_type_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_P_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_IS_TYPE_S_N_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_A_A: if_is_type_s_p(sc) sc->value = fx_call(sc, opt1_pair(sc->code)); else sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_IS_TYPE_S_P_A: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_IS_TYPE_S_A_P: if_is_type_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, fn_proc(cadr(sc->code))(sc, sc->t1_1))) - #define if_not_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, fn_proc(opt1_pair(cdr(sc->code)))(sc, sc->t1_1))) /* cadadr */ - - case OP_IF_opSq_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_opSq_R: if_opsq_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_opSq_P_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_opSq_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_opSq_N_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_and2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - #define if_not_and2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - - case OP_IF_AND2_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND2_R: if_and2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_AND2_P_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_AND2_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND2_N_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_or2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - #define if_not_or2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - - case OP_IF_OR2_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_OR2_R: if_or2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_OR2_P_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_OR2_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_OR2_N_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_and3_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && \ - (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) - #define if_not_and3_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || \ - (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) - - case OP_IF_AND3_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND3_R: if_and3_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_AND3_P_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_AND3_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND3_N_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_p_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code));} while (0) - case OP_IF_P_P: if_p_push(OP_IF_PP); goto EVAL; - case OP_IF_P_N: if_p_push(OP_IF_PN); goto EVAL; - case OP_IF_P_P_P: if_p_push(OP_IF_PPP); goto EVAL; - case OP_IF_P_R: if_p_push(OP_IF_PR); goto EVAL; - case OP_IF_P_N_N: if_p_push(OP_IF_PRR); goto EVAL; - - #define if_bp_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code));} while (0) - case OP_IF_ANDP_P: if_bp_push(OP_IF_PP); goto AND_P; - case OP_IF_ANDP_R: if_bp_push(OP_IF_PR); goto AND_P; - case OP_IF_ANDP_P_P: if_bp_push(OP_IF_PPP); goto AND_P; - case OP_IF_ANDP_N: if_bp_push(OP_IF_PR); goto AND_P; - case OP_IF_ANDP_N_N: if_bp_push(OP_IF_PRR); goto AND_P; - - case OP_IF_ORP_P: if_bp_push(OP_IF_PP); goto OR_P; - case OP_IF_ORP_R: if_bp_push(OP_IF_PR); goto OR_P; - case OP_IF_ORP_P_P: if_bp_push(OP_IF_PPP); goto OR_P; - case OP_IF_ORP_N: if_bp_push(OP_IF_PR); goto OR_P; - case OP_IF_ORP_N_N: if_bp_push(OP_IF_PRR); goto OR_P; - - case OP_IF_PP: if (sc->value != sc->F) goto EVAL; sc->value = sc->unspecified; continue; - case OP_IF_PN: - case OP_IF_PR: if (sc->value == sc->F) goto EVAL; sc->value = sc->unspecified; continue; - case OP_IF_PPP: sc->code = (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; - case OP_IF_PRR: sc->code = (sc->value == sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; - - case OP_WHEN: check_when(sc); goto EVAL; - case OP_WHEN_S: if (op_when_s(sc)) continue; goto EVAL; - case OP_WHEN_A: if (op_when_a(sc)) continue; goto EVAL; - case OP_WHEN_P: op_when_p(sc); goto EVAL; - case OP_WHEN_AND_2A: if (op_when_and_2a(sc)) continue; goto EVAL; - case OP_WHEN_AND_3A: if (op_when_and_3a(sc)) continue; goto EVAL; - case OP_WHEN_AND_AP: if (op_when_and_ap(sc)) continue; goto EVAL; - case OP_WHEN_PP: if (op_when_pp(sc)) continue; goto EVAL; - - case OP_UNLESS: check_unless(sc); goto EVAL; - case OP_UNLESS_S: if (op_unless_s(sc)) continue; goto EVAL; - case OP_UNLESS_A: if (op_unless_a(sc)) continue; goto EVAL; - case OP_UNLESS_P: op_unless_p(sc); goto EVAL; - case OP_UNLESS_PP: if (op_unless_pp(sc)) continue; goto EVAL; - - - case OP_COND_FEED: if (op_cond_feed(sc)) goto EVAL; /* else fall through */ - case OP_COND_FEED_1: if (is_true(sc, sc->value)) {op_cond_feed_1(sc); goto EVAL;} sc->value = sc->unspecified; continue; - - case OP_COND: check_cond(sc); - case OP_COND_UNCHECKED: if (op_cond_unchecked(sc)) goto EVAL; - case OP_COND1: if (op_cond1(sc)) goto TOP_NO_POP; /* else fall through */ - FEED_TO: - if (feed_to(sc)) goto APPLY; - goto EVAL; - case OP_FEED_TO_1: sc->code = sc->value; goto APPLY; /* sc->args saved in feed_to via push_stack */ - - case OP_COND_SIMPLE: if (op_cond_simple(sc)) goto EVAL; - case OP_COND1_SIMPLE: if (op_cond1_simple(sc)) goto TOP_NO_POP; goto BEGIN; - case OP_COND_SIMPLE_O: if (op_cond_simple_o(sc)) goto EVAL; - case OP_COND1_SIMPLE_O: if (op_cond1_simple_o(sc)) continue; goto EVAL; - - case OP_COND_NA_NA: sc->value = fx_cond_na_na(sc, sc->code); continue; - case OP_COND_NA_NP: if (op_cond_na_np(sc)) continue; goto EVAL; - case OP_COND_NA_NP_1: if (op_cond_na_np_1(sc)) continue; goto EVAL; - case OP_COND_NA_NP_O: if (inline_op_cond_na_np_o(sc)) continue; goto EVAL; - case OP_COND_NA_2E: if (op_cond_na_2e(sc)) continue; goto EVAL; - case OP_COND_NA_3E: if (op_cond_na_3e(sc)) continue; goto EVAL; - - - case OP_AND: - if (check_and(sc, sc->code)) continue; - case OP_AND_P: - sc->code = cdr(sc->code); - AND_P: /* this code (and OR_P below) is ugly, but the pretty version (procedurized) is much slower */ - if (has_fx(sc->code)) /* all fx_proc's are set via fx_choose which can return nil, but it is not cleared when type is */ - { /* so, if (fx_proc(sc->code)) here and in OR_P is not safe */ - sc->value = fx_call(sc, sc->code); - if (is_false(sc, sc->value)) continue; - sc->code = cdr(sc->code); - if (is_null(sc->code)) continue; /* this order of checks appears to be faster than any of the alternatives */ - goto AND_P; - } - if (is_pair(cdr(sc->code))) /* apparently exactly as fast as is_not_null */ - push_stack_no_args(sc, OP_AND_P1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_AND_P1: - if ((is_false(sc, sc->value)) || - (is_null(sc->code))) - continue; - goto AND_P; - - case OP_AND_AP: if (op_and_ap(sc)) continue; goto EVAL; - case OP_AND_2A: sc->value = fx_and_2a(sc, sc->code); continue; - case OP_AND_3A: sc->value = fx_and_3a(sc, sc->code); continue; - case OP_AND_N: sc->value = fx_and_n(sc, sc->code); continue; - case OP_AND_S_2: sc->value = fx_and_s_2(sc, sc->code); continue; - case OP_AND_PAIR_P: if (op_and_pair_p(sc)) continue; goto EVAL; - case OP_AND_SAFE_P1: op_and_safe_p1(sc); goto EVAL; - case OP_AND_SAFE_P2: if (op_and_safe_p2(sc)) continue; goto EVAL; - case OP_AND_SAFE_P3: if (op_and_safe_p3(sc)) continue; goto EVAL; - case OP_AND_SAFE_P_REST: if (is_true(sc, sc->value)) sc->value = fx_and_n(sc, sc->code); continue; - - - case OP_OR: - if (check_or(sc, sc->code)) continue; - case OP_OR_P: - sc->code = cdr(sc->code); - OR_P: - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - if (is_true(sc, sc->value)) continue; - sc->code = cdr(sc->code); - if (is_null(sc->code)) continue; - goto OR_P; - } - if (is_pair(cdr(sc->code))) - push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_OR_P1: - if ((is_true(sc, sc->value)) || - (is_null(sc->code))) - continue; - goto OR_P; - - case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL; - case OP_OR_2A: sc->value = fx_or_2a(sc, sc->code); continue; - case OP_OR_S_2: sc->value = fx_or_s_2(sc, sc->code); continue; - case OP_OR_S_TYPE_2: sc->value = fx_or_s_type_2(sc, sc->code); continue; - case OP_OR_3A: sc->value = fx_or_3a(sc, sc->code); continue; - case OP_OR_N: sc->value = fx_or_n(sc, sc->code); continue; - - - case OP_NAMED_LET_NO_VARS: op_named_let_no_vars(sc); goto BEGIN; - case OP_NAMED_LET: if (op_named_let(sc)) goto BEGIN; goto EVAL; - case OP_NAMED_LET_A: op_named_let_a(sc); goto BEGIN; - case OP_NAMED_LET_AA: op_named_let_aa(sc); goto BEGIN; - case OP_NAMED_LET_NA: if (op_named_let_na(sc)) goto BEGIN; goto EVAL; - - case OP_LET: if (op_let(sc)) goto BEGIN; goto EVAL; - case OP_LET_UNCHECKED: if (op_let_unchecked(sc)) goto BEGIN; goto EVAL; - case OP_LET1: if (op_let1(sc)) goto BEGIN; goto EVAL; - case OP_LET_NO_VARS: op_let_no_vars(sc); goto BEGIN; - - case OP_LET_A_A_OLD: op_let_a_a_old(sc); continue; - case OP_LET_A_A_NEW: op_let_a_a_new(sc); continue; - case OP_LET_A_NA_OLD: op_let_a_na_old(sc); continue; - case OP_LET_A_NA_NEW: op_let_a_na_new(sc); continue; - case OP_LET_NA_OLD: op_let_na_old(sc); goto BEGIN; - case OP_LET_NA_NEW: inline_op_let_na_new(sc); goto BEGIN; - case OP_LET_2A_OLD: op_let_2a_old(sc); goto EVAL; - case OP_LET_2A_NEW: op_let_2a_new(sc); goto EVAL; - case OP_LET_3A_OLD: op_let_3a_old(sc); goto EVAL; - case OP_LET_3A_NEW: op_let_3a_new(sc); goto EVAL; - case OP_LET_ONE_OLD: op_let_one_old(sc); goto EVAL; - case OP_LET_ONE_NEW: op_let_one_new(sc); goto EVAL; - case OP_LET_ONE_P_OLD: op_let_one_p_old(sc); goto EVAL; - case OP_LET_ONE_P_NEW: op_let_one_p_new(sc); goto EVAL; - - case OP_LET_A_OLD: op_let_a_old(sc); sc->code = cdr(sc->code); goto BEGIN; - case OP_LET_A_NEW: inline_op_let_a_new(sc); sc->code = cdr(sc->code); goto BEGIN; - case OP_LET_A_OLD_2: inline_op_let_a_old(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_NEW_2: inline_op_let_a_new(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_P_OLD: inline_op_let_a_old(sc); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_P_NEW: inline_op_let_a_new(sc); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_ONE_OLD_1: op_let_one_old_1(sc); goto BEGIN; - case OP_LET_ONE_P_OLD_1: op_let_one_p_old_1(sc); goto EVAL; - case OP_LET_ONE_NEW_1: sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value); goto BEGIN; - case OP_LET_ONE_P_NEW_1: sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value); sc->code = car(sc->code); goto EVAL; - case OP_LET_opaSSq_OLD: op_let_opassq_old(sc); goto BEGIN; - case OP_LET_opaSSq_NEW: op_let_opassq_new(sc); goto BEGIN; - - case OP_LET_STAR_NA: op_let_star_na(sc); goto BEGIN; - case OP_LET_STAR_NA_A: op_let_star_na_a(sc); continue; - - case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL; - case OP_LET_STAR2: op_let_star2(sc); goto EVAL; - case OP_LET_STAR: if (check_let_star(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR1: if (op_let_star1(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR_SHADOWED: if (op_let_star_shadowed(sc)) goto EVAL; goto BEGIN; - - case OP_LETREC: check_letrec(sc, true); - case OP_LETREC_UNCHECKED: if (op_letrec_unchecked(sc)) goto EVAL; goto BEGIN; - case OP_LETREC1: if (op_letrec1(sc)) goto EVAL; goto BEGIN; - - case OP_LETREC_STAR: check_letrec(sc, false); - case OP_LETREC_STAR_UNCHECKED: if (op_letrec_star_unchecked(sc)) goto EVAL; goto BEGIN; - case OP_LETREC_STAR1: if (op_letrec_star1(sc)) goto EVAL; goto BEGIN; - - - case OP_LET_TEMPORARILY: check_let_temporarily(sc); - case OP_LET_TEMP_UNCHECKED: op_let_temp_unchecked(sc); goto LET_TEMP_INIT1; - - case OP_LET_TEMP_INIT1: - op_let_temp_init1_1(sc); - LET_TEMP_INIT1: - if (op_let_temp_init1(sc)) goto EVAL; - case OP_LET_TEMP_INIT2: - switch (op_let_temp_init2(sc)) /* let misc obj */ - { - case goto_begin: goto BEGIN; - case goto_eval: goto EVAL; - case goto_set_unchecked: goto SET_UNCHECKED; - case fall_through: - default: break; - } - - case OP_LET_TEMP_DONE: - sc->code = sc->value; - push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* save let-temp body val as sc->code */ - case OP_LET_TEMP_DONE1: - if (op_let_temp_done1(sc)) continue; - goto SET_UNCHECKED; - - - case OP_LET_TEMP_S7: if(op_let_temp_s7(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_S7_DIRECT: if (op_let_temp_s7_direct(sc)) goto BEGIN; sc->value = sc->nil; continue; - - case OP_LET_TEMP_NA: if (op_let_temp_na(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_A: if (op_let_temp_a(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_SETTER: if (op_let_temp_setter(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_A_A: sc->value = fx_let_temp_a_a(sc, sc->code); continue; - - case OP_LET_TEMP_UNWIND: op_let_temp_unwind(sc); continue; - case OP_LET_TEMP_S7_UNWIND: op_let_temp_s7_unwind(sc); continue; - case OP_LET_TEMP_S7_DIRECT_UNWIND: op_let_temp_s7_direct_unwind(sc); continue; - case OP_LET_TEMP_SETTER_UNWIND: op_let_temp_setter_unwind(sc); continue; - - - case OP_EVAL_MACRO: op_eval_macro(sc); goto EVAL; - case OP_EVAL_MACRO_MV: if (op_eval_macro_mv(sc)) continue; goto EVAL; - case OP_EXPANSION: op_finish_expansion(sc); continue; - - case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: - case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: - case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: - op_define_macro(sc); - continue; - - case OP_MACRO: case OP_BACRO: case OP_MACRO_STAR: case OP_BACRO_STAR: - op_macro(sc); - continue; - - case OP_LAMBDA: sc->value = op_lambda(sc, sc->code); continue; - case OP_LAMBDA_UNCHECKED: sc->value = op_lambda_unchecked(sc, sc->code); continue; - case OP_LAMBDA_STAR: op_lambda_star(sc); continue; - case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; - - - case OP_CASE: /* car(sc->code) is the selector */ - /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */ - if (check_case(sc)) goto EVAL; else goto G_G; /* selector is a symbol or constant, stupid "else" to shut up the compiler */ - - case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); - G_G: case OP_CASE_G_G: if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_E_S: op_case_e_s(sc); goto EVAL; -#if (!WITH_GMP) - case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_A_I_S: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_I_S: if (op_case_i_s(sc)) continue; goto EVAL; -#endif - case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */ - case OP_CASE_G_S: op_case_g_s(sc); goto EVAL; - - case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_E_G: if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_A_S_G: /* splitting this case out matters in lint */ - sc->value = fx_call(sc, cdr(sc->code)); - if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; else goto FEED_TO; - - case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_E_S: push_stack_no_args_direct(sc, OP_CASE_E_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_E_G: push_stack_no_args_direct(sc, OP_CASE_E_G); sc->code = cadr(sc->code); goto EVAL; -#if (!WITH_GMP) - case OP_CASE_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue; -#endif - case OP_CASE_A_E_S_A: sc->value = fx_case_a_e_s_a(sc, sc->code); continue; - case OP_CASE_A_G_S_A: sc->value = fx_case_a_g_s_a(sc, sc->code); continue; - case OP_CASE_A_S_G_A: sc->value = fx_case_a_s_g_a(sc, sc->code); continue; - - - case OP_ERROR_QUIT: - if (sc->stack_end <= sc->stack_start) stack_reset(sc); /* sets stack_end to stack_start, then pushes op_eval_done */ - return(sc->F); - - case OP_ERROR_HOOK_QUIT: - op_error_hook_quit(sc); - - case OP_EVAL_DONE: - return(sc->F); - - case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */ - sc->value = splice_in_values(sc, sc->args); - continue; - - case OP_GC_PROTECT: case OP_BARRIER: case OP_NO_VALUES: - case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: - continue; - - case OP_GET_OUTPUT_STRING: op_get_output_string(sc); /* from call-with-output-string|with-output-to-string; return the port string directly *//* fall through */ - case OP_UNWIND_OUTPUT: op_unwind_output(sc); continue; - case OP_UNWIND_INPUT: op_unwind_input(sc); continue; - case OP_DYNAMIC_UNWIND: dynamic_unwind(sc, sc->code, sc->args); continue; - case OP_PROFILE_IN: g_profile_in(sc, set_plist_2(sc, cadr(sc->code), sc->curlet)); continue; - case OP_DYNAMIC_UNWIND_PROFILE: g_profile_out(sc, set_plist_1(sc, sc->args)); continue; - case OP_DYNAMIC_WIND: if (op_dynamic_wind(sc)) goto APPLY; continue; - case OP_DEACTIVATE_GOTO: call_exit_active(sc->args) = false; continue; /* deactivate the exiter */ - - case OP_WITH_LET_S: sc->value = fx_with_let_s(sc, sc->code); continue; - case OP_WITH_LET: check_with_let(sc); - case OP_WITH_LET_UNCHECKED: if (op_with_let_unchecked(sc)) goto EVAL; - case OP_WITH_LET1: if (sc->value != sc->curlet) activate_with_let(sc, sc->value); goto BEGIN; - - case OP_WITH_BAFFLE: check_with_baffle(sc); - case OP_WITH_BAFFLE_UNCHECKED: if (op_with_baffle_unchecked(sc)) continue; goto BEGIN; - - - case OP_READ_INTERNAL: op_read_internal(sc); continue; - case OP_READ_DONE: op_read_done(sc); continue; - case OP_LOAD_RETURN_IF_EOF: if (op_load_return_if_eof(sc)) goto EVAL; return(sc->F); - case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; continue; - - POP_READ_LIST: - if (pop_read_list(sc)) goto READ_NEXT; - - READ_LIST: - case OP_READ_LIST: /* sc->args is sc->nil at first */ - sc->args = cons(sc, sc->value, sc->args); - - READ_NEXT: - case OP_READ_NEXT: /* this is 75% of the token calls, so expanding it saves lots of time */ - { - int32_t c; - s7_pointer pt = current_input_port(sc); - c = port_read_white_space(pt)(sc, pt); - - READ_C: - switch (c) - { - case '(': - c = port_read_white_space(pt)(sc, pt); /* sc->tok = token(sc) */ - switch (c) - { - case '(': sc->tok = TOKEN_LEFT_PAREN; break; - case ')': sc->value = sc->nil; goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */ - case '.': sc->tok = read_dot(sc, pt); break; - case '\'': sc->tok = TOKEN_QUOTE; break; - case ';': sc->tok = port_read_semicolon(pt)(sc, pt); break; - case '"': sc->tok = TOKEN_DOUBLE_QUOTE; break; - case '`': sc->tok = TOKEN_BACK_QUOTE; break; - case ',': sc->tok = read_comma(sc, pt); break; - case '#': sc->tok = read_sharp(sc, pt); break; - case '\0': case EOF: sc->tok = TOKEN_EOF; break; - - default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */ - c = read_start_list(sc, pt, c); - goto READ_C; - } - if (sc->tok == TOKEN_ATOM) - { - c = read_atom(sc, pt); - goto READ_C; - } - if (sc->tok == TOKEN_RIGHT_PAREN) - { - sc->value = sc->nil; - goto READ_LIST; - } - if (sc->tok == TOKEN_DOT) - { - do {c = inchar(pt);} while ((c != ')') && (c != EOF)); - read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == TOKEN_EOF) - missing_close_paren_error_nr(sc); - - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); - /* check_stack_size(sc); */ - sc->value = read_expression(sc); - if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ')': - sc->tok = TOKEN_RIGHT_PAREN; - break; - - case '.': - sc->tok = read_dot(sc, pt); /* dot or atom */ - break; - - case '\'': - sc->tok = TOKEN_QUOTE; - /* might need check_stack_size(sc) here */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - continue; - - case ';': - sc->tok = port_read_semicolon(pt)(sc, pt); - break; - - case '"': - sc->tok = TOKEN_DOUBLE_QUOTE; - read_double_quote(sc); - goto READ_LIST; - - case '`': - sc->tok = TOKEN_BACK_QUOTE; - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ',': - sc->tok = read_comma(sc, pt); /* at_mark or comma */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - continue; - - case '#': - sc->tok = read_sharp(sc, pt); - break; - - case '\0': - case EOF: - missing_close_paren_error_nr(sc); - - default: - sc->strbuf[0] = (unsigned char)c; - sc->value = port_read_name(pt)(sc, pt); - goto READ_LIST; - }} - - READ_TOK: - switch (sc->tok) - { - case TOKEN_RIGHT_PAREN: /* sc->args can't be null here */ - sc->value = proper_list_reverse_in_place(sc, sc->args); - if ((is_expansion(car(sc->value))) && - (sc->is_expanding)) - switch (op_expansion(sc)) - { - case goto_begin: goto BEGIN; - case goto_apply_lambda: goto APPLY_LAMBDA; - default: break; - } - break; - - case TOKEN_EOF: missing_close_paren_error_nr(sc); /* can't happen, I believe */ - case TOKEN_ATOM: sc->value = port_read_name(current_input_port(sc))(sc, current_input_port(sc)); goto READ_LIST; - case TOKEN_SHARP_CONST: if (read_sharp_const(sc)) goto READ_TOK; goto READ_LIST; - case TOKEN_DOUBLE_QUOTE: read_double_quote(sc); goto READ_LIST; - case TOKEN_DOT: read_dot_and_expression(sc); break; - default: read_tok_default(sc); break; - } - if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case OP_READ_DOT: - switch (op_read_dot(sc)) - { - case goto_start: continue; - case goto_pop_read_list: goto POP_READ_LIST; - default: goto READ_TOK; - } - case OP_READ_QUOTE: if (op_read_quote(sc)) continue; goto POP_READ_LIST; - case OP_READ_QUASIQUOTE: if (op_read_quasiquote(sc)) continue; goto POP_READ_LIST; - case OP_READ_UNQUOTE: if (op_read_unquote(sc)) continue; goto POP_READ_LIST; - case OP_READ_APPLY_VALUES: if (op_read_apply_values(sc)) continue; goto POP_READ_LIST; - case OP_READ_VECTOR: if (op_read_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_INT_VECTOR: if (op_read_int_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_FLOAT_VECTOR: if (op_read_float_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) continue; goto POP_READ_LIST; - - case OP_CLEAR_OPTS: - break; - - default: - return(sc->F); - } - - /* this code is reached from OP_CLEAR_OPTS and many others where the optimization has turned out to be incorrect, OP_CLOSURE_SYM for example; search for break */ - if (!tree_is_cyclic(sc, sc->code)) - clear_all_optimizations(sc, sc->code); - UNOPT: - switch (trailers(sc)) - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_eval_args_top: goto EVAL_ARGS_TOP; - case goto_eval: goto EVAL; - case goto_start: continue; /* sc->value has been set, this is OP_SYMBOL|CONSTANT on the next pass */ - default: - if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: unexpected switch default: %s\n", __func__, __LINE__, display(sc->code)); - break; - }} - return(sc->F); /* this never happens (make the compiler happy) */ -} - - -/* -------------------------------- s7_heap_scan -------------------------------- */ -#if S7_DEBUGGING -static void mark_holdee(s7_pointer holder, s7_pointer holdee, const char *root) -{ - holdee->holders++; - holdee->holder = holder; - holdee->root = root; -} - -static void mark_stack_holdees(s7_scheme *sc, s7_pointer p, s7_int top) -{ - if (stack_elements(p)) - { - s7_pointer heap0 = *(sc->heap); - s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); - for (s7_pointer *tp = (s7_pointer *)(stack_elements(p)), *tend = (s7_pointer *)(tp + top); (tp < tend); tp++) - { - s7_pointer x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - }} -} - -static void save_holder_data(s7_scheme *sc, s7_pointer p) -{ - switch (unchecked_type(p)) - { - case T_PAIR: mark_holdee(p, car(p), NULL); mark_holdee(p, cdr(p), NULL); break; - case T_CATCH: mark_holdee(p, catch_tag(p), NULL); mark_holdee(p, catch_handler(p), NULL); break; - case T_DYNAMIC_WIND: mark_holdee(p, dynamic_wind_in(p), NULL); mark_holdee(p, dynamic_wind_out(p), NULL); mark_holdee(p, dynamic_wind_body(p), NULL); break; - case T_INPUT_PORT: mark_holdee(p, port_string_or_function(p), NULL); break; - case T_C_POINTER: mark_holdee(p, c_pointer_type(p), NULL); mark_holdee(p, c_pointer_info(p), NULL); break; - case T_COUNTER: mark_holdee(p, counter_result(p), NULL); mark_holdee(p, counter_list(p), NULL); mark_holdee(p, counter_let(p), NULL); break; - case T_STACK: mark_stack_holdees(sc, p, (p == sc->stack) ? current_stack_top(sc) : temp_stack_top(p)); break; - case T_OUTPUT_PORT: if (is_function_port(p)) mark_holdee(p, port_string_or_function(p), NULL); break; - - case T_ITERATOR: - mark_holdee(p, iterator_sequence(p), NULL); - if (is_mark_seq(p)) mark_holdee(p, iterator_current(p), NULL); - break; - - case T_SLOT: - mark_holdee(p, slot_value(p), NULL); - mark_holdee(p, slot_symbol(p), NULL); - if (slot_has_setter(p)) mark_holdee(p, slot_setter(p), NULL); - if (slot_has_pending_value(p)) mark_holdee(p, slot_pending_value(p), NULL); - break; - - case T_VECTOR: - if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); - for (s7_int i = 0, len = vector_length(p); i < len; i++) - if (vector_element(p, i)) mark_holdee(p, vector_element(p, i), NULL); - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); - break; - - case T_LET: - if (p != sc->rootlet) /* do rootlet later? */ - { - for (s7_pointer slot = let_slots(p); tis_slot(slot); slot = next_slot(slot)) mark_holdee(p, slot, NULL); - if (has_dox_slot1(p)) mark_holdee(p, let_dox_slot1(p), NULL); - if ((has_dox_slot2(p)) && (is_slot(let_dox_slot2(p)))) mark_holdee(p, let_dox_slot2(p), NULL); - } - break; - - case T_C_FUNCTION_STAR: - if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p))) - for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) - mark_holdee(p, car(arg), NULL); - break; - - case T_CLOSURE: case T_CLOSURE_STAR: - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - mark_holdee(p, closure_args(p), NULL); - mark_holdee(p, closure_body(p), NULL); - mark_holdee(p, closure_let(p), NULL); - mark_holdee(p, closure_setter_or_map_list(p), NULL); - break; - - case T_HASH_TABLE: - mark_holdee(p, hash_table_procedures(p), NULL); - if (is_pair(hash_table_procedures(p))) - { - mark_holdee(p, hash_table_key_typer_unchecked(p), NULL); - mark_holdee(p, hash_table_value_typer_unchecked(p), NULL); - } - if (hash_table_entries(p) > 0) - { - s7_int len = hash_table_mask(p) + 1; - hash_entry_t **entries = hash_table_elements(p); - hash_entry_t **last = (hash_entry_t **)(entries + len); - if ((is_weak_hash_table(p)) && (weak_hash_iters(p) == 0)) - while (entries < last) - { - for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) - mark_holdee(p, hash_entry_value(xp), NULL); - } - else - while (entries < last) - for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) - { - mark_holdee(p, hash_entry_key(xp), NULL); - mark_holdee(p, hash_entry_value(xp), NULL); - }} - break; - - case T_CONTINUATION: - mark_holdee(p, continuation_op_stack(p), NULL); - mark_stack_holdees(sc, continuation_stack(p), continuation_stack_top(p)); - break; - - default: /* includes T_C_OBJECT */ - break; - } -} - -void s7_heap_analyze(s7_scheme *sc) -{ - /* clear possible previous data */ - for (s7_int k = 0; k < sc->heap_size; k++) - { - s7_pointer obj = sc->heap[k]; - obj->root = NULL; - obj->holders = 0; - obj->holder = NULL; - } - /* now parcel out all the holdings */ - for (s7_int k = 0; k < sc->heap_size; k++) - save_holder_data(sc, sc->heap[k]); - - { - s7_pointer *tmps = sc->free_heap_top; - s7_pointer *tmps_top = tmps + sc->gc_temps_size; - if (tmps_top > sc->previous_free_heap_top) tmps_top = sc->previous_free_heap_top; - while (tmps < tmps_top) - { - s7_pointer p = *tmps++; - mark_holdee(NULL, p, "gc temp"); - }} - - mark_holdee(NULL, sc->w, "sc->w"); - mark_holdee(NULL, sc->x, "sc->x"); - mark_holdee(NULL, sc->y, "sc->y"); - mark_holdee(NULL, sc->z, "sc->z"); - mark_holdee(NULL, sc->temp1, "sc->temp1"); - mark_holdee(NULL, sc->temp2, "sc->temp2"); - mark_holdee(NULL, sc->temp3, "sc->temp3"); - mark_holdee(NULL, sc->temp4, "sc->temp4"); - mark_holdee(NULL, sc->temp5, "sc->temp5"); - mark_holdee(NULL, sc->temp7, "sc->temp7"); - mark_holdee(NULL, sc->temp8, "sc->temp8"); - mark_holdee(NULL, sc->temp9, "sc->temp9"); - mark_holdee(NULL, sc->temp10, "sc->temp10"); - mark_holdee(NULL, sc->rec_p1, "sc->rec_p1"); - mark_holdee(NULL, sc->rec_p2, "sc->rec_p2"); - - mark_holdee(NULL, car(sc->t1_1), "car(sc->t1_1)"); - mark_holdee(NULL, car(sc->t2_1), "car(sc->t2_1)"); - mark_holdee(NULL, car(sc->t2_2), "car(sc->t2_2)"); - mark_holdee(NULL, car(sc->t3_1), "car(sc->t3_1)"); - mark_holdee(NULL, car(sc->t3_2), "car(sc->t3_2)"); - mark_holdee(NULL, car(sc->t3_3), "car(sc->t3_3)"); - mark_holdee(NULL, car(sc->t4_1), "car(sc->t4_1)"); - mark_holdee(NULL, car(sc->u1_1), "car(sc->u1_1)"); - mark_holdee(NULL, car(sc->plist_1), "car(sc->plist_1)"); - mark_holdee(NULL, car(sc->plist_2), "car(sc->plist_2)"); - mark_holdee(NULL, car(sc->plist_3), "car(sc->plist_3)"); - mark_holdee(NULL, car(sc->qlist_2), "car(sc->qlist_2)"); - mark_holdee(NULL, car(sc->qlist_3), "car(sc->qlist_3)"); - mark_holdee(NULL, car(sc->elist_1), "car(sc->elist_1)"); - mark_holdee(NULL, car(sc->elist_2), "car(sc->elist_2)"); - mark_holdee(NULL, car(sc->elist_3), "car(sc->elist_3)"); - mark_holdee(NULL, car(sc->elist_4), "car(sc->elist_4)"); - mark_holdee(NULL, car(sc->elist_5), "car(sc->elist_5)"); - mark_holdee(NULL, car(sc->elist_6), "car(sc->elist_6)"); - mark_holdee(NULL, car(sc->elist_7), "car(sc->elist_7)"); - mark_holdee(NULL, cadr(sc->plist_2), "cadr(sc->plist_2)"); - mark_holdee(NULL, cadr(sc->plist_3), "cadr(sc->plist_3)"); - mark_holdee(NULL, cadr(sc->elist_2), "cadr(sc->elist_2)"); - mark_holdee(NULL, cadr(sc->elist_3), "cadr(sc->elist_3)"); - mark_holdee(NULL, cadr(sc->qlist_2), "cadr(sc->qlist_2)"); - mark_holdee(NULL, caddr(sc->plist_3), "caddr(sc->plist_3)"); - mark_holdee(NULL, caddr(sc->elist_3), "caddr(sc->elist_3)"); - - mark_holdee(NULL, sc->code, "sc->code"); - mark_holdee(NULL, sc->value, "sc->value"); - mark_holdee(NULL, sc->args, "sc->args"); - mark_holdee(NULL, sc->curlet, "sc->curlet"); - mark_holdee(NULL, sc->stack, "sc->stack"); - mark_holdee(NULL, sc->default_random_state, "sc->default_random_state"); - mark_holdee(NULL, sc->let_temp_hook, "sc->let_temp_hook"); - mark_holdee(NULL, sc->stacktrace_defaults, "sc->stacktrace_defaults"); - mark_holdee(NULL, sc->protected_objects, "sc->protected_objects"); - mark_holdee(NULL, sc->protected_setters, "sc->protected_setters"); - mark_holdee(NULL, sc->protected_setter_symbols, "sc->protected_setter_symbols"); - mark_holdee(NULL, sc->error_type, "sc->error_type"); - mark_holdee(NULL, sc->error_data, "sc->error_data"); - mark_holdee(NULL, sc->error_code, "sc->error_code"); - mark_holdee(NULL, sc->error_line, "sc->error_line"); - mark_holdee(NULL, sc->error_file, "sc->error_file"); - mark_holdee(NULL, sc->error_position, "sc->error_position"); -#if WITH_HISTORY - mark_holdee(NULL, sc->error_history, "sc->error_history"); -#endif - - for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) - mark_holdee(NULL, g->p, "permanent object"); - - for (s7_int i = 0; i < sc->protected_objects_size; i++) - mark_holdee(NULL, vector_element(sc->protected_objects, i), "gc protected object"); - - for (s7_int i = 0; i < sc->protected_setters_loc; i++) - mark_holdee(NULL, vector_element(sc->protected_setters, i), "gc protected setter"); - - for (s7_int i = 0; i < sc->setters_loc; i++) - mark_holdee(NULL, cdr(sc->setters[i]), "setter"); - - for (s7_int i = 0; i <= sc->format_depth; i++) - if (sc->fdats[i]) - mark_holdee(NULL, sc->fdats[i]->curly_arg, "fdat curly_arg"); - - { - s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc); - for (s7_pointer *p = sc->input_port_stack; p < tp; p++) - mark_holdee(NULL, *p, "input stack"); - } - { - s7_pointer *p = sc->op_stack; - s7_pointer *tp = sc->op_stack_now; - while (p < tp) {s7_pointer x = *p++; mark_holdee(NULL, x, "op stack");} - } - - if (sc->rec_stack) - for (s7_int i = 0; i < sc->rec_loc; i++) - mark_holdee(NULL, sc->rec_els[i], "sc->rec_els"); - - { - gc_list_t *gp = sc->opt1_funcs; - for (s7_int i = 0; i < gp->loc; i++) - { - s7_pointer s1 = T_Pair(gp->list[i]); - mark_holdee(NULL, opt1_any(s1), "opt1_funcs"); - }} - - for (int32_t i = 1; i < NUM_SAFE_LISTS; i++) - if ((is_pair(sc->safe_lists[i])) && - (list_is_in_use(sc->safe_lists[i]))) - for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) - mark_holdee(NULL, car(p), "safe_lists"); - - for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "wrong-type-arg"); - for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple wrong-type-arg"); - for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "out-of-range"); - for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple out-of-range"); - - { - s7_pointer *tmp = rootlet_elements(sc->rootlet); - s7_pointer *top = (s7_pointer *)(tmp + sc->rootlet_entries); - while (tmp < top) {s7_pointer slot = *tmp++; mark_holdee(NULL, slot_value(slot), "rootlet");} - } -#if WITH_HISTORY - for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) - { - mark_holdee(NULL, car(p1), "eval history1"); - mark_holdee(NULL, car(p2), "eval history2"); - mark_holdee(NULL, car(p3), "eval history3"); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; - } -#else - mark_holdee(NULL, sc->cur_code, "current code"); -#endif -} - -void s7_heap_scan(s7_scheme *sc, int32_t typ) -{ - bool found_one = false; - for (s7_int k = 0; k < sc->heap_size; k++) - { - s7_pointer obj = sc->heap[k]; - if (unchecked_type(obj) == typ) - { - found_one = true; - if (obj->holders == 0) - fprintf(stderr, "%s has no holder (alloc: %d)\n", display_80(obj), obj->alloc_line); - else - if (obj->root) - fprintf(stderr, "%s from %s (%d holder%s)\n", display_80(obj), obj->root, - obj->holders, (obj->holders != 1) ? "s" : ""); - else fprintf(stderr, "%s from %s (%s, %p, alloc: %d, holder%s: %d)\n", - display_80(obj), display_80(obj->holder), - s7_type_names[unchecked_type(obj->holder)], obj->holder, obj->alloc_line, - (obj->holders != 1) ? "s" : "", obj->holders); - }} - if (!found_one) - fprintf(stderr, "heap-scan: no %s found\n", s7_type_names[typ]); -} - -static s7_pointer g_heap_scan(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_scan "(heap-scan type) scans the heap for objects of type and reports info about them" - #define Q_heap_scan s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol) - s7_pointer p = car(args); - if (!s7_is_integer(p)) - sole_arg_wrong_type_error_nr(sc, make_symbol(sc, "heap-scan", 9), p, sc->type_names[T_INTEGER]); - if ((s7_integer(p) <= 0) || (s7_integer(p) >= NUM_TYPES)) - sole_arg_out_of_range_error_nr(sc, make_symbol(sc, "heap-scan", 9), p, wrap_string(sc, "0 < type < 48", 13)); - s7_heap_scan(sc, (int32_t)s7_integer(p)); /* 0..48 currently */ - return(sc->F); -} - -static s7_pointer g_heap_analyze(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_analyze "(heap-analyze type) gets heap data for subsequent heap-scan" - #define Q_heap_analyze s7_make_signature(sc, 1, sc->not_symbol) - s7_heap_analyze(sc); - return(sc->F); -} - -static s7_pointer g_heap_holder(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_holder "(heap-holder obj) returns the object pointing to obj" - #define Q_heap_holder s7_make_signature(sc, 2, sc->T, sc->T) - s7_pointer p = car(args); - if ((p->holders == 0) || ((!(p->holder)) && (!(p->root)))) return(sc->F); - return((p->holder) ? p->holder : s7_make_string(sc, p->root)); -} - -static s7_pointer g_heap_holders(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_holders "(heap-holders obj) returns the number of objects pointing to obj" - #define Q_heap_holders s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T) - return(make_integer(sc, car(args)->holders)); -} - -/* random debugging stuff */ -static s7_pointer g_show_stack(s7_scheme *sc, s7_pointer args) -{ - #define H_show_stack "no help" - #define Q_show_stack s7_make_signature(sc, 1, sc->not_symbol) - s7_show_stack(sc); - return(sc->F); -} - -void s7_show_op_stack(s7_scheme *sc) -{ - fprintf(stderr, "op_stack:\n"); - for (s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now; (p < tp); p++) - fprintf(stderr, " %s\n", display(*p)); -} - -static s7_pointer g_show_op_stack(s7_scheme *sc, s7_pointer args) -{ - #define H_show_op_stack "no help" - #define Q_show_op_stack s7_make_signature(sc, 1, sc->not_symbol) - s7_show_op_stack(sc); - return(sc->F); -} - -static s7_pointer g_is_op_stack(s7_scheme *sc, s7_pointer args) -{ - #define H_is_op_stack "no help" - #define Q_is_op_stack s7_make_signature(sc, 1, sc->is_boolean_symbol) - return(make_boolean(sc, (sc->op_stack < sc->op_stack_now))); -} -#endif - - -/* -------------------------------- *s7* let -------------------------------- */ -/* maybe *features* field in *s7*, others are *libraries*, *load-path*, *cload-directory*, *autoload*, *#readers* */ - -static noreturn void s7_starlet_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) -{ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be ~A", 54), - caller, arg, object_type_name(sc, arg), typ)); -} - -static noreturn void sl_stacktrace_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer arg, s7_pointer typ, s7_pointer val) -{ - set_elist_7(sc, wrap_string(sc, "(set! (*s7* '~A) '~S): the ~:D list element ~S is ~A but should be ~A", 69), - caller, val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_7); -} - -static noreturn void s7_starlet_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) -{ - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is out of range (~A)", 52), caller, arg, descr)); -} - -static s7_int s7_starlet_length(void) {return(SL_NUM_FIELDS - 1);} - -static s7_pointer g_s7_starlet_set_fallback(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = cadr(args); - if (!is_symbol(sym)) - sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]); - return(s7_starlet_set_1(sc, sym, caddr(args))); -} - -static s7_pointer g_s7_starlet_ref_fallback(s7_scheme *sc, s7_pointer args); - -static s7_pointer make_s7_starlet(s7_scheme *sc) /* *s7* is semipermanent -- 20-May-21 */ -{ - s7_pointer slot1 = make_semipermanent_slot(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "s7-let-set", g_s7_starlet_set_fallback, 3, 0, false, "*s7* writer")); - s7_pointer slot2 = make_semipermanent_slot(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "s7-let-ref", g_s7_starlet_ref_fallback, 2, 0, false, "*s7* reader")); - s7_pointer x = alloc_pointer(sc); - set_full_type(x, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); - let_set_id(x, ++sc->let_number); - let_set_outlet(x, sc->nil); - symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, slot1); - slot_set_next(slot1, slot_end(sc)); - symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, slot2); - slot_set_next(slot2, slot1); - let_set_slots(x, slot2); - set_immutable_slot(slot1); /* make the *s7* let-ref|set! fallbacks immutable */ - set_immutable_slot(slot2); - set_immutable_let(x); - sc->s7_starlet_symbol = s7_define_constant(sc, "*s7*", s7_openlet(sc, x)); /* define_constant returns the symbol */ - for (int32_t i = SL_STACK_TOP; i < SL_NUM_FIELDS; i++) - { - s7_pointer sym = make_symbol_with_strlen(sc, s7_starlet_names[i]); - s7_starlet_symbol_set(sym, (s7_starlet_t)i); /* evaluates sym twice */ - } - return(x); -} - -/* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids - * using ca 100 cells for the let slots/values. We would need the fallbacks anyway for 'files et al. - * Since most of the fields need special setters, it's actually less code this way. See old/s7-let-s7.c. - */ - -#if (!_WIN32) /* (!MS_WINDOWS) */ - #include -#endif - -static s7_pointer kmg(s7_scheme *sc, s7_int bytes) -{ - block_t *b = mallocate(sc, 128); - int32_t len = 0; - if (bytes < 1000) - len = snprintf((char *)block_data(b), 128, "%" ld64, bytes); - else - if (bytes < 1000000) - len = snprintf((char *)block_data(b), 128, "%.1fk", bytes / 1000.0); - else - if (bytes < 1000000000) - len = snprintf((char *)block_data(b), 128, "%.1fM", bytes / 1000000.0); - else len = snprintf((char *)block_data(b), 128, "%.1fG", bytes / 1000000000.0); - return(cons(sc, make_integer(sc, bytes), block_to_string(sc, b, len))); -} - -static s7_pointer memory_usage(s7_scheme *sc) -{ - s7_int i, k, len, in_use = 0, vlen = 0, flen = 0, ilen = 0, blen = 0, hlen = 0; - gc_list_t *gp; - s7_int ts[NUM_TYPES]; - -#if (!_WIN32) /* (!MS_WINDOWS) */ - struct rusage info; - struct timeval ut; -#endif - - s7_pointer mu_let = s7_inlet(sc, sc->nil); - s7_int gc_loc = gc_protect_1(sc, mu_let); - -#if (!_WIN32) /* (!MS_WINDOWS) */ - getrusage(RUSAGE_SELF, &info); - ut = info.ru_utime; - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time", 12), make_real(sc, ut.tv_sec + (floor(ut.tv_usec / 1000.0) / 1000.0))); -#ifdef __APPLE__ - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss)); - /* apple docs say this is in kilobytes, but apparently that is an error */ -#else - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss * 1024)); - /* why does this number sometimes have no relation to RES in top? */ -#endif - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO", 2), cons(sc, make_integer(sc, info.ru_inblock), make_integer(sc, info.ru_oublock))); -#endif - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, sc->rootlet_entries)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size", 9), - cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * (sizeof(s7_cell) + 2 * sizeof(s7_pointer))))); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size", 9), make_integer(sc, sizeof(s7_cell))); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-freed", 14), make_integer(sc, sc->gc_total_freed)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-time", 13), make_real(sc, (double)(sc->gc_total_time) / ticks_per_second())); - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small_ints", 10), - cons(sc, make_integer(sc, NUM_SMALL_INTS), kmg(sc, NUM_SMALL_INTS * sizeof(s7_cell)))); - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-cells", 15), - cons(sc, make_integer(sc, sc->semipermanent_cells), kmg(sc, sc->semipermanent_cells * sizeof(s7_cell)))); - i = 0; - for (gc_obj_t *g = sc->semipermanent_objects; g; i++, g = (gc_obj_t *)(g->nxt)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent_objects", 17), make_integer(sc, i)); - i = 0; - for (gc_obj_t *g = sc->semipermanent_lets; g; i++, g = (gc_obj_t *)(g->nxt)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent_lets", 14), make_integer(sc, i)); - - /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */ - for (i = 0; i < NUM_TYPES; i++) ts[i] = 0; - for (k = 0; k < sc->heap_size; k++) - ts[unchecked_type(sc->heap[k])]++; - sc->w = sc->nil; - for (i = 0; i < NUM_TYPES; i++) - { - if (i > 0) in_use += ts[i]; - if (ts[i] > 50) - sc->w = cons_unchecked(sc, cons(sc, make_symbol_with_strlen(sc, (i == 0) ? "free" : type_name_from_type(i, NO_ARTICLE)), - make_integer(sc, ts[i])), sc->w); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cells-in-use/free", 17), - cons(sc, make_integer(sc, in_use), make_integer(sc, sc->free_heap_top - sc->free_heap))); - if (is_pair(sc->w)) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "types", 5), proper_list_reverse_in_place(sc, sc->w)); - sc->w = sc->unused; - /* same for semipermanent cells requires traversing saved_pointers and the alloc and big_alloc blocks up to alloc_k, or keeping explicit counts */ - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-protected-objects", 20), - cons(sc, make_integer(sc, sc->protected_objects_size - sc->protected_objects_free_list_loc), - make_integer(sc, sc->protected_objects_size))); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "setters", 7), make_integer(sc, sc->protected_setters_loc)); - - /* check the symbol table, counting gensyms etc */ - { - s7_int syms = 0, gens = 0, keys = 0, mx_list = 0; - s7_pointer *els = vector_elements(sc->symbol_table); - for (i = 0; i < SYMBOL_TABLE_SIZE; i++) - { - s7_pointer x; - for (k = 0, x = els[i]; is_not_null(x); x = cdr(x), k++) - { - syms++; - if (is_gensym(car(x))) gens++; - if (is_keyword(car(x))) keys++; - } - if (k > mx_list) mx_list = k; - } - add_slot_unchecked_with_id(sc, mu_let, sc->symbol_table_symbol, - s7_list(sc, 9, - make_integer(sc, SYMBOL_TABLE_SIZE), - make_symbol(sc, "max-bin", 7), make_integer(sc, mx_list), - make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, syms), make_integer(sc, syms - gens - keys)), - make_symbol(sc, "gensyms", 7), make_integer(sc, gens), - make_symbol(sc, "keys", 4), make_integer(sc, keys))); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "stack", 5), cons(sc, make_integer(sc, current_stack_top(sc)), make_integer(sc, sc->stack_size))); - - len = sc->autoload_names_top * (sizeof(const char **) + sizeof(s7_int) + sizeof(bool)); - for (i = 0; i < sc->autoload_names_loc; i++) len += sc->autoload_names_sizes[i]; - add_slot_unchecked_with_id(sc, mu_let, sc->autoload_symbol, make_integer(sc, len)); - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "circle_info", 11), - make_integer(sc, sc->circle_info->size * (sizeof(s7_pointer) + sizeof(int32_t) + sizeof(bool)))); - - /* check the gc lists (finalizations), at startup there are strings/input-strings from the s7_eval_c_string calls for make-polar et el */ - len = sc->strings->size + sc->vectors->size + sc->input_ports->size + sc->output_ports->size + sc->input_string_ports->size + - sc->continuations->size + sc->c_objects->size + sc->hash_tables->size + sc->gensyms->size + sc->undefineds->size + - sc->multivectors->size + sc->weak_refs->size + sc->weak_hash_iterators->size + sc->opt1_funcs->size; - { - int32_t loc = sc->strings->loc + sc->vectors->loc + sc->input_ports->loc + sc->output_ports->loc + sc->input_string_ports->loc + - sc->continuations->loc + sc->c_objects->loc + sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc + - sc->multivectors->loc + sc->weak_refs->loc + sc->weak_hash_iterators->loc + sc->opt1_funcs->loc; - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists", 8), - s7_list(sc, 4, make_integer(sc, loc), make_integer(sc, len), kmg(sc, len * sizeof(s7_pointer)), /* active, total, space allocated */ - s7_list(sc, 14, - list_3(sc, sc->string_symbol, make_integer(sc, sc->strings->loc), make_integer(sc, sc->strings->size)), - list_3(sc, sc->vector_symbol, make_integer(sc, sc->vectors->loc), make_integer(sc, sc->vectors->size)), - list_3(sc, sc->hash_table_symbol, make_integer(sc, sc->hash_tables->loc), make_integer(sc, sc->hash_tables->size)), - list_3(sc, make_symbol(sc, "multivector", 11), make_integer(sc, sc->multivectors->loc), make_integer(sc, sc->multivectors->size)), - list_3(sc, make_symbol(sc, "input", 5), make_integer(sc, sc->input_ports->loc), make_integer(sc, sc->input_ports->size)), - list_3(sc, make_symbol(sc, "output", 6), make_integer(sc, sc->output_ports->loc), make_integer(sc, sc->output_ports->size)), - list_3(sc, make_symbol(sc, "input-string", 12), make_integer(sc, sc->input_string_ports->loc), make_integer(sc, sc->input_string_ports->size)), - list_3(sc, make_symbol(sc, "continuation", 12), make_integer(sc, sc->continuations->loc), make_integer(sc, sc->continuations->size)), - list_3(sc, make_symbol(sc, "c-object", 8), make_integer(sc, sc->c_objects->loc), make_integer(sc, sc->c_objects->size)), - list_3(sc, make_symbol(sc, "gensym", 6), make_integer(sc, sc->gensyms->loc), make_integer(sc, sc->gensyms->size)), - list_3(sc, make_symbol(sc, "undefined", 9), make_integer(sc, sc->undefineds->loc), make_integer(sc, sc->undefineds->size)), - list_3(sc, make_symbol(sc, "weak-ref", 8), make_integer(sc, sc->weak_refs->loc), make_integer(sc, sc->weak_refs->size)), - list_3(sc, make_symbol(sc, "weak-hash-iter", 14),make_integer(sc, sc->weak_hash_iterators->loc), make_integer(sc, sc->weak_hash_iterators->size)), - list_3(sc, make_symbol(sc, "opt1-func", 9), make_integer(sc, sc->opt1_funcs->loc), make_integer(sc, sc->opt1_funcs->size))))); - } - - /* strings */ - gp = sc->strings; - for (len = 0, i = 0; i < (int32_t)(gp->loc); i++) - len += string_length(gp->list[i]); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "strings", 7), cons(sc, make_integer(sc, gp->loc), make_integer(sc, len))); - - /* vectors */ - for (k = 0, gp = sc->vectors; k < 2; k++, gp = sc->multivectors) - for (i = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (is_float_vector(v)) - flen += vector_length(v); - else - if (is_int_vector(v)) - ilen += vector_length(v); - else - if (is_byte_vector(v)) - blen += vector_length(v); - else vlen += vector_length(v); - } - add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "vectors", 7), - s7_list(sc, 9, - make_integer(sc, sc->vectors->loc + sc->multivectors->loc), - make_symbol(sc, "vlen", 4), make_integer(sc, vlen), - make_symbol(sc, "fvlen", 5), make_integer(sc, flen), - make_symbol(sc, "ivlen", 5), make_integer(sc, ilen), - make_symbol(sc, "bvlen", 5), make_integer(sc, blen))); - /* hash-tables */ - for (i = 0, gp = sc->hash_tables; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - hlen += ((hash_table_mask(v) + 1) * sizeof(hash_entry_t *)); - hlen += (hash_table_entries(v) * sizeof(hash_entry_t)); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "hash-tables", 11), - cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen))); - - /* ports */ - gp = sc->input_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - gp = sc->input_string_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports", 11), - cons(sc, make_integer(sc, sc->input_ports->loc + sc->input_string_ports->loc), make_integer(sc, len))); - gp = sc->output_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports", 12), - cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len))); - - i = 0; - for (s7_pointer p = sc->format_ports; p; i++, p = (s7_pointer)port_next(p)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "format-ports", 12), make_integer(sc, i)); - - /* continuations (sketchy!) */ - gp = sc->continuations; - for (i = 0, len = 0; i < gp->loc; i++) - if (is_continuation(gp->list[i])) - len += continuation_stack_size(gp->list[i]); - if (len > 0) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "continuations", 13), - cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len * sizeof(s7_pointer)))); - /* c-objects */ - if (sc->c_objects->loc > 0) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-objects", 9), make_integer(sc, sc->c_objects->loc)); - if (sc->num_c_object_types > 0) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-types", 7), - cons(sc, make_integer(sc, sc->num_c_object_types), - make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t))))); - /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */ -#if WITH_GMP - add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "bignums", 7), - s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc), - make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc), - make_integer(sc, sc->big_random_states->loc))); -#endif - /* free-lists (mallocate) */ - { - block_t *b; - for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) - { - for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); - sc->w = cons(sc, make_integer(sc, k), sc->w); - len += ((sizeof(block_t) + (1LL << i)) * k); - } - for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; b = block_next(b), k++) - len += (sizeof(block_t) + block_size(b)); - sc->w = cons(sc, make_integer(sc, k), sc->w); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10), - list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), - cons(sc, make_symbol(sc, "bins", 4), proper_list_reverse_in_place(sc, sc->w)))); - sc->w = sc->unused; - add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "approximate-s7-size", 19), - kmg(sc, ((sc->semipermanent_cells + NUM_SMALL_INTS + sc->heap_size) * sizeof(s7_cell)) + - ((2 * sc->heap_size + SYMBOL_TABLE_SIZE + sc->stack_size) * sizeof(s7_pointer)) + - len + hlen + (vlen * sizeof(s7_pointer)) + (flen * sizeof(s7_double)) + (ilen * sizeof(s7_int)) + blen)); - } - s7_gc_unprotect_at(sc, gc_loc); - return(mu_let); -} - -static s7_pointer sl_c_types(s7_scheme *sc) -{ - s7_pointer res; - sc->w = sc->nil; - for (int32_t i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */ - sc->w = cons(sc, sc->c_object_types[i]->scheme_name, sc->w); - res = proper_list_reverse_in_place(sc, sc->w); /* so car(types) has tag 0 */ - sc->w = sc->unused; - return(res); -} - -static s7_pointer sl_file_names(s7_scheme *sc) -{ - s7_pointer p; - sc->w = sc->nil; - for (int32_t i = 0; i <= sc->file_names_top; i++) - sc->w = cons(sc, sc->file_names[i], sc->w); - p = proper_list_reverse_in_place(sc, sc->w); - sc->w = sc->unused; - return(p); -} - -static s7_pointer sl_int_fixup(s7_scheme *sc, s7_pointer val) -{ -#if WITH_GMP - return(s7_int_to_big_integer(sc, s7_integer_clamped_if_gmp(sc, val))); -#else - return(val); -#endif -} - -static s7_pointer sl_history(s7_scheme *sc) -{ -#if WITH_HISTORY - return(cull_history(sc, (sc->cur_code == sc->history_sink) ? sc->old_cur_code : sc->cur_code)); -#else - return(sc->cur_code); -#endif -} - -static s7_pointer sl_active_catches(s7_scheme *sc) -{ - s7_pointer lst = sc->nil; - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - switch (stack_op(sc->stack, i)) - { - case OP_CATCH_ALL: - lst = cons(sc, sc->T, lst); - break; - case OP_CATCH_2: case OP_CATCH_1: case OP_CATCH: - lst = cons(sc, catch_tag(T_Cat(stack_code(sc->stack, i))), lst); - break; - } - return(reverse_in_place_unchecked(sc, sc->nil, lst)); -} - -static s7_pointer sl_stack_entries(s7_scheme *sc, s7_pointer stack, int64_t top) -{ - s7_pointer lst = sc->nil; - for (int64_t i = top - 1; i >= 3; i -= 4) - { - s7_pointer func = stack_code(stack, i), args = stack_args(stack, i), e = stack_let(stack, i); - opcode_t op = stack_op(stack, i); - s7_pointer entry = sc->nil; - if (s7_is_valid(sc, e)) entry = cons(sc, e, entry); - if (s7_is_valid(sc, args)) entry = cons_unchecked(sc, args, entry); - if (s7_is_valid(sc, func)) entry = cons_unchecked(sc, func, entry); - if ((op >= 0) && (op < NUM_OPS)) entry = cons_unchecked(sc, make_symbol_with_strlen(sc, op_names[op]), entry); - lst = cons_unchecked(sc, entry, lst); - sc->w = lst; - } - sc->w = sc->unused; - return(reverse_in_place_unchecked(sc, sc->nil, lst)); -} - -static s7_pointer sl_protected_objects(s7_scheme *sc) -{ - s7_pointer nv = s7_vector_copy(sc, sc->protected_objects); - s7_pointer *vals = vector_elements(nv); - s7_int len = vector_length(nv); - for (s7_int i = 0; i < len; i++) - if (vals[i] == sc->unused) - vals[i] = sc->F; - return(nv); -} - -static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice) -{ - switch (choice) - { - case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: return(make_boolean(sc, sc->accept_all_keyword_arguments)); - case SL_AUTOLOADING: return(s7_make_boolean(sc, sc->is_autoloading)); - case SL_BIGNUM_PRECISION: return(make_integer(sc, sc->bignum_precision)); - case SL_CATCHES: return(sl_active_catches(sc)); - case SL_CPU_TIME: return(s7_make_real(sc, (double)clock() / (double)CLOCKS_PER_SEC)); /* cpu, not wall-clock time */ - case SL_C_TYPES: return(sl_c_types(sc)); - case SL_DEBUG: return(make_integer(sc, sc->debug)); - case SL_DEFAULT_HASH_TABLE_LENGTH: return(make_integer(sc, sc->default_hash_table_length)); - case SL_DEFAULT_RANDOM_STATE: return(sc->default_random_state); - case SL_DEFAULT_RATIONALIZE_ERROR: return(make_real(sc, sc->default_rationalize_error)); - case SL_EQUIVALENT_FLOAT_EPSILON: return(s7_make_real(sc, sc->equivalent_float_epsilon)); - case SL_EXPANSIONS: return(s7_make_boolean(sc, sc->is_expanding)); - case SL_FILE_NAMES: case SL_FILENAMES: return(sl_file_names(sc)); - case SL_FLOAT_FORMAT_PRECISION: return(make_integer(sc, sc->float_format_precision)); - case SL_FREE_HEAP_SIZE: return(make_integer(sc, sc->free_heap_top - sc->free_heap)); - case SL_GC_FREED: return(make_integer(sc, sc->gc_freed)); - case SL_GC_INFO: return(list_3(sc, make_integer(sc, sc->gc_calls), make_integer(sc, sc->gc_total_time), make_integer(sc, ticks_per_second()))); - case SL_GC_PROTECTED_OBJECTS: return(sl_protected_objects(sc)); - case SL_GC_RESIZE_HEAP_BY_4_FRACTION: return(make_real(sc, sc->gc_resize_heap_by_4_fraction)); - case SL_GC_RESIZE_HEAP_FRACTION: return(make_real(sc, sc->gc_resize_heap_fraction)); - case SL_GC_STATS: return(make_integer(sc, sc->gc_stats)); - case SL_GC_TEMPS_SIZE: return(make_integer(sc, sc->gc_temps_size)); - case SL_GC_TOTAL_FREED: return(make_integer(sc, sc->gc_total_freed)); - case SL_HASH_TABLE_FLOAT_EPSILON: return(s7_make_real(sc, sc->hash_table_float_epsilon)); - case SL_HEAP_SIZE: return(make_integer(sc, sc->heap_size)); - case SL_HISTORY: return(sl_history(sc)); - case SL_HISTORY_ENABLED: return(s7_make_boolean(sc, s7_history_enabled(sc))); - case SL_HISTORY_SIZE: return(make_integer(sc, sc->history_size)); - case SL_INITIAL_STRING_PORT_LENGTH: return(make_integer(sc, sc->initial_string_port_length)); - case SL_MAJOR_VERSION: return(make_integer(sc, S7_MAJOR_VERSION)); - case SL_MINOR_VERSION: return(make_integer(sc, S7_MINOR_VERSION)); - case SL_MAX_FORMAT_LENGTH: return(make_integer(sc, sc->max_format_length)); - case SL_MAX_HEAP_SIZE: return(make_integer(sc, sc->max_heap_size)); - case SL_MAX_LIST_LENGTH: return(make_integer(sc, sc->max_list_length)); - case SL_MAX_PORT_DATA_SIZE: return(make_integer(sc, sc->max_port_data_size)); - case SL_MAX_STACK_SIZE: return(make_integer(sc, sc->max_stack_size)); - case SL_MAX_STRING_LENGTH: return(make_integer(sc, sc->max_string_length)); - case SL_MAX_VECTOR_DIMENSIONS: return(make_integer(sc, sc->max_vector_dimensions)); - case SL_MAX_VECTOR_LENGTH: return(make_integer(sc, sc->max_vector_length)); - case SL_MEMORY_USAGE: return(memory_usage(sc)); - case SL_MOST_NEGATIVE_FIXNUM: return(sl_int_fixup(sc, leastfix)); - case SL_MOST_POSITIVE_FIXNUM: return(sl_int_fixup(sc, mostfix)); - case SL_MUFFLE_WARNINGS: return(s7_make_boolean(sc, sc->muffle_warnings)); - case SL_NUMBER_SEPARATOR: return(chars[(int)(sc->number_separator)]); - case SL_OPENLETS: return(s7_make_boolean(sc, sc->has_openlets)); - case SL_OUTPUT_PORT_DATA_SIZE: return(make_integer(sc, sc->output_port_data_size)); - case SL_PRINT_LENGTH: return(make_integer(sc, sc->print_length)); - case SL_PROFILE: return(make_integer(sc, sc->profile)); - case SL_PROFILE_INFO: return(profile_info_out(sc)); - case SL_PROFILE_PREFIX: return(sc->profile_prefix); - case SL_ROOTLET_SIZE: return(make_integer(sc, sc->rootlet_entries)); - case SL_SAFETY: return(make_integer(sc, sc->safety)); - case SL_STACK: return(sl_stack_entries(sc, sc->stack, current_stack_top(sc))); - case SL_STACKTRACE_DEFAULTS: return(sc->stacktrace_defaults); - case SL_STACK_SIZE: return(make_integer(sc, sc->stack_size)); - case SL_STACK_TOP: return(make_integer(sc, (sc->stack_end - sc->stack_start) / 4)); - case SL_UNDEFINED_CONSTANT_WARNINGS: return(s7_make_boolean(sc, sc->undefined_constant_warnings)); - case SL_UNDEFINED_IDENTIFIER_WARNINGS: return(s7_make_boolean(sc, sc->undefined_identifier_warnings)); - case SL_VERSION: return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE)); - } - return(sc->undefined); -} - -s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym) /* s7.h, not used here */ -{ - if (is_symbol(sym)) - { - if (is_keyword(sym)) - sym = keyword_symbol(sym); - if (s7_starlet_symbol(sym) != SL_NO_FIELD) - return(s7_starlet(sc, s7_starlet_symbol(sym))); - } - return(sc->undefined); -} - -s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym) {return(s7_starlet_ref(sc, sym));} - -static s7_pointer g_s7_starlet_ref_fallback(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = cadr(args); - if (!is_symbol(sym)) - sole_arg_wrong_type_error_nr(sc, sc->let_ref_symbol, sym, sc->type_names[T_SYMBOL]); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - return(s7_starlet(sc, s7_starlet_symbol(sym))); -} - -static s7_pointer s7_starlet_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer symbol, value; - iterator_position(iterator)++; - if (iterator_position(iterator) >= SL_NUM_FIELDS) - return(iterator_quit(iterator)); - symbol = make_symbol_with_strlen(sc, s7_starlet_names[iterator_position(iterator)]); - - if ((iterator_position(iterator) == SL_STACK) || - (iterator_position(iterator) == SL_GC_PROTECTED_OBJECTS) || - (iterator_position(iterator) == SL_MEMORY_USAGE)) - value = sc->F; /* (format #f "~W" (inlet *s7*)) or (let->list *s7*) etc */ - else - { - s7_pointer osw = sc->w; /* protect against s7_starlet list making */ - value = s7_starlet(sc, s7_starlet_symbol(symbol)); - sc->w = osw; - } - if (iterator_let_cons(iterator)) - { - s7_pointer p = iterator_let_cons(iterator); - set_car(p, symbol); - set_cdr(p, value); - return(p); - } - return(cons(sc, symbol, value)); -} - -static s7_pointer s7_starlet_make_iterator(s7_scheme *sc, s7_pointer iter) -{ - iterator_position(iter) = SL_NO_FIELD; - iterator_next(iter) = s7_starlet_iterate; - iterator_let_cons(iter) = NULL; - return(iter); -} - -static s7_pointer sl_real_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - if (!is_real(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]); - if (s7_real(val) < 0.0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); - return(val); -} - -static s7_pointer sl_integer_gt_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - if (s7_integer_clamped_if_gmp(sc, val) <= 0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be positive", 21)); - return(val); -} - -static s7_pointer sl_integer_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - if (s7_integer_clamped_if_gmp(sc, val) < 0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); - return(val); -} - -#if WITH_HISTORY -static void sl_set_history_size(s7_scheme *sc, s7_int iv) -{ - s7_pointer p1, p2; - if (iv > MAX_HISTORY_SIZE) iv = MAX_HISTORY_SIZE; - if (iv > sc->true_history_size) - { - /* splice in the new cells, reattach the circles */ - s7_pointer p3; - s7_pointer next1 = cdr(sc->eval_history1); - s7_pointer next2 = cdr(sc->eval_history2); - s7_pointer next3 = cdr(sc->history_pairs); - set_cdr(sc->eval_history1, semipermanent_list(sc, iv - sc->true_history_size)); - set_cdr(sc->eval_history2, semipermanent_list(sc, iv - sc->true_history_size)); - set_cdr(sc->history_pairs, semipermanent_list(sc, iv - sc->true_history_size)); - for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); - set_car(p3, semipermanent_list(sc, 1)); - set_cdr(p3, next3); - for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); - set_cdr(p1, next1); - set_cdr(p2, next2); - sc->true_history_size = iv; - } - sc->history_size = iv; - /* clear out both buffers to avoid GC confusion */ - for (p1 = sc->eval_history1, p2 = sc->eval_history2; ; p2 = cdr(p2)) - { - set_car(p1, sc->nil); - set_car(p2, sc->nil); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; - } -} -#endif - -#if WITH_GMP -static s7_pointer set_bignum_precision(s7_scheme *sc, int32_t precision) -{ - mp_prec_t bits = (mp_prec_t)precision; - s7_pointer bpi; - if (precision <= 1) /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */ - sole_arg_out_of_range_error_nr(sc, wrap_string(sc, "set! (*s7* 'bignum-precision)", 29), wrap_integer(sc, precision), wrap_string(sc, "has to be greater than 1", 24)); - mpfr_set_default_prec(bits); - mpc_set_default_precision(bits); - bpi = big_pi(sc); - s7_symbol_set_value(sc, sc->pi_symbol, bpi); - slot_set_value(initial_slot(sc->pi_symbol), bpi); /* if #_pi occurs after precision set, make sure #_pi is still legit (not a free cell) */ - return(sc->F); -} -#endif - -static noreturn void sl_unsettable_error_nr(s7_scheme *sc, s7_pointer sym) -{ - error_nr(sc, sc->immutable_error_symbol, set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S)", 20), sym)); -} - -static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - s7_int iv; - - if ((S7_DEBUGGING) && (!is_symbol(sym))) - { - fprintf(stderr, "%s: %s\n", __func__, display(sym)); - sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]); - } - if (is_keyword(sym)) - sym = keyword_symbol(sym); - - switch (s7_starlet_symbol(sym)) - { - case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: - if (is_boolean(val)) {sc->accept_all_keyword_arguments = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_AUTOLOADING: - if (is_boolean(val)) {sc->is_autoloading = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_BIGNUM_PRECISION: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); - sc->bignum_precision = iv; -#if WITH_GMP - set_bignum_precision(sc, sc->bignum_precision); - mpfr_set_prec(sc->mpfr_1, sc->bignum_precision); - mpfr_set_prec(sc->mpfr_2, sc->bignum_precision); - mpc_set_prec(sc->mpc_1, sc->bignum_precision); - mpc_set_prec(sc->mpc_2, sc->bignum_precision); -#endif - return(val); - - case SL_CATCHES: - case SL_CPU_TIME: - case SL_C_TYPES: - sl_unsettable_error_nr(sc, sym); - - case SL_DEBUG: - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - sc->debug = s7_integer_clamped_if_gmp(sc, val); - sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); - if ((sc->debug > 0) && - (!is_memq(make_symbol(sc, "debug.scm", 9), s7_symbol_value(sc, sc->features_symbol)))) - s7_load(sc, "debug.scm"); - return(val); - - case SL_DEFAULT_HASH_TABLE_LENGTH: - sc->default_hash_table_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); - return(val); - - case SL_DEFAULT_RANDOM_STATE: - if (is_random_state(val)) - { -#if (!WITH_GMP) - random_seed(sc->default_random_state) = random_seed(val); - random_carry(sc->default_random_state) = random_carry(val); -#endif - return(val); - } - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_RANDOM_STATE]); - - case SL_DEFAULT_RATIONALIZE_ERROR: - sc->default_rationalize_error = s7_real(sl_real_geq_0(sc, sym, val)); - return(val); - - case SL_EQUIVALENT_FLOAT_EPSILON: - sc->equivalent_float_epsilon = s7_real(sl_real_geq_0(sc, sym, val)); - return(val); - - case SL_EXPANSIONS: - if (is_boolean(val)) {sc->is_expanding = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_FILE_NAMES: case SL_FILENAMES: sl_unsettable_error_nr(sc, sym); - - case SL_FLOAT_FORMAT_PRECISION: /* float-format-precision should not be huge => hangs in snprintf -- what's a reasonable limit here? */ - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); - sc->float_format_precision = (iv < MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION; - return(val); - - case SL_FREE_HEAP_SIZE: - case SL_GC_FREED: - case SL_GC_TOTAL_FREED: - case SL_GC_PROTECTED_OBJECTS: sl_unsettable_error_nr(sc, sym); - - case SL_GC_TEMPS_SIZE: sc->gc_temps_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_GC_RESIZE_HEAP_FRACTION: sc->gc_resize_heap_fraction = s7_real(sl_real_geq_0(sc, sym, val)); return(val); - case SL_GC_RESIZE_HEAP_BY_4_FRACTION: sc->gc_resize_heap_by_4_fraction = s7_real(sl_real_geq_0(sc, sym, val)); return(val); - - case SL_GC_STATS: - if (is_boolean(val)) - { - sc->gc_stats = ((val == sc->T) ? GC_STATS : 0); - return(val); - } - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->gc_stats = s7_integer_clamped_if_gmp(sc, val); - if (sc->gc_stats < 16) /* gc_stats is uint32_t */ - return(val); - sc->gc_stats = 0; - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29)); - - case SL_GC_INFO: /* ticks_per_second is not settable */ - if (val == sc->F) - { - sc->gc_total_time = 0; - sc->gc_calls = 0; - } - else - if ((is_pair(val)) && (s7_is_integer(car(val))) && - (is_pair(cdr(val))) && (s7_is_integer(cadr(val))) && - (is_pair(cddr(val))) && (s7_is_integer(caddr(val)))) - { - sc->gc_total_time = s7_integer(car(val)); - sc->gc_calls = s7_integer(cadr(val)); - } - else s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of three integers", 30)); - return(sc->F); - - case SL_HASH_TABLE_FLOAT_EPSILON: - sc->hash_table_float_epsilon = s7_real(sl_real_geq_0(sc, sym, val)); - return(val); - - case SL_HEAP_SIZE: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); - if (iv > sc->heap_size) - resize_heap_to(sc, iv); - return(val); - - case SL_HISTORY: /* (set! (*s7* 'history) val) */ - replace_current_code(sc, val); - return(val); - - case SL_HISTORY_ENABLED: /* (set! (*s7* 'history-enabled) #f|#t) */ - if (is_boolean(val)) - return(s7_make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val)))); - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_HISTORY_SIZE: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); -#if WITH_HISTORY - sl_set_history_size(sc, iv); -#else - sc->history_size = iv; -#endif - return(val); - - case SL_INITIAL_STRING_PORT_LENGTH: sc->initial_string_port_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_FORMAT_LENGTH: sc->max_format_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_HEAP_SIZE: sc->max_heap_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_LIST_LENGTH: sc->max_list_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_PORT_DATA_SIZE: sc->max_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - - case SL_MAX_STACK_SIZE: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); - if (iv < INITIAL_STACK_SIZE) - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than the initial stack size", 48)); - sc->max_stack_size = (uint32_t)iv; - return(val); - - case SL_MAX_STRING_LENGTH: sc->max_string_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_VECTOR_DIMENSIONS: sc->max_vector_dimensions = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_VECTOR_LENGTH: sc->max_vector_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - - case SL_MEMORY_USAGE: - case SL_MOST_NEGATIVE_FIXNUM: - case SL_MOST_POSITIVE_FIXNUM: sl_unsettable_error_nr(sc, sym); - - case SL_MUFFLE_WARNINGS: - if (is_boolean(val)) {sc->muffle_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_NUMBER_SEPARATOR: /* I think no PL uses the separator in output */ -#if (!WITH_NUMBER_SEPARATOR) - s7_warn(sc, 128, "(set! (*s7* 'number-separator) ...) but number-separator is not included in this s7"); -#endif - if (!is_character(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_CHARACTER]); - if ((is_char_numeric(val)) || (is_char_whitespace(val)) || (!t_number_separator_p[character(val)]) || - (character(val) == 'i') || (character(val) == 'e') || (character(val) == 'E')) - /* I guess +nan.0 and +inf.0 are not numeric literals, so we don't need to catch +n_a_n.0 */ - s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a printing, non-numeric character", 33)); - sc->number_separator = character(val); - return(val); - - case SL_OPENLETS: - if (is_boolean(val)) {sc->has_openlets = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_OUTPUT_PORT_DATA_SIZE: sc->output_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_PRINT_LENGTH: sc->print_length = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); return(val); - - case SL_PROFILE: - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - sc->profile = s7_integer_clamped_if_gmp(sc, val); - sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); - if (sc->profile > 0) - { - if (!is_memq(make_symbol(sc, "profile.scm", 11), s7_symbol_value(sc, sc->features_symbol))) - s7_load(sc, "profile.scm"); - if (!sc->profile_data) - make_profile_info(sc); - if (!sc->profile_out) - sc->profile_out = s7_make_function(sc, "profile-out", g_profile_out, 2, 0, false, NULL); - } - return(val); - - case SL_PROFILE_INFO: - if (val != sc->F) s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f (to clear the table)", 23)); - clear_profile_info(sc); - - case SL_PROFILE_PREFIX: - if ((is_symbol(val)) || val == sc->F) {sc->profile_prefix = val; return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a symbol or #f", 14)); - - case SL_ROOTLET_SIZE: sl_unsettable_error_nr(sc, sym); - - case SL_SAFETY: - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - if ((s7_integer_clamped_if_gmp(sc, val) > 2) || (s7_integer_clamped_if_gmp(sc, val) < -1)) - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between -1 (no safety) and 2 (max safety)", 54)); - sc->safety = s7_integer_clamped_if_gmp(sc, val); - return(val); - - case SL_STACKTRACE_DEFAULTS: - if (!is_pair(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_PAIR]); - if (s7_list_length(sc, val) != 5) - s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a list with 5 entries", 21)); - if (!is_t_integer(car(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 1, car(val), wrap_string(sc, "an integer (stack frames)", 25), val); - if (!is_t_integer(cadr(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 2, cadr(val), wrap_string(sc, "an integer (cols-for-data)", 26), val); - if (!is_t_integer(caddr(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 3, caddr(val), wrap_string(sc, "an integer (line length)", 24), val); - if (!is_t_integer(cadddr(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 4, cadddr(val), wrap_string(sc, "an integer (comment position)", 29), val); - if (!is_boolean(s7_list_ref(sc, val, 4))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 5, s7_list_ref(sc, val, 4), wrap_string(sc, "a boolean (treat-data-as-comment)", 33), val); - sc->stacktrace_defaults = copy_proper_list(sc, val); - return(val); - - case SL_STACK: - case SL_STACK_SIZE: - case SL_STACK_TOP: sl_unsettable_error_nr(sc, sym); - - case SL_UNDEFINED_CONSTANT_WARNINGS: - if (is_boolean(val)) {sc->undefined_constant_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_UNDEFINED_IDENTIFIER_WARNINGS: - if (is_boolean(val)) {sc->undefined_identifier_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_VERSION: sl_unsettable_error_nr(sc, sym); - - default: - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S); no such field in *s7*", 43), sym)); - } - return(sc->undefined); -} - -s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) -{ - if (is_symbol(sym)) - { - if (is_keyword(sym)) - sym = keyword_symbol(sym); - if (s7_starlet_symbol(sym) != SL_NO_FIELD) - return(s7_starlet_set_1(sc, sym, new_value)); - } - return(sc->undefined); -} - -s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) {return(s7_starlet_set(sc, sym, new_value));} - -static void init_s7_starlet_immutable_field(void) -{ - s7_starlet_immutable_field = (bool *)Calloc(SL_NUM_FIELDS, sizeof(bool)); - s7_starlet_immutable_field[SL_CATCHES] = true; - s7_starlet_immutable_field[SL_CPU_TIME] = true; - s7_starlet_immutable_field[SL_C_TYPES] = true; - s7_starlet_immutable_field[SL_FILE_NAMES] = true; - s7_starlet_immutable_field[SL_FILENAMES] = true; - s7_starlet_immutable_field[SL_FREE_HEAP_SIZE] = true; - s7_starlet_immutable_field[SL_GC_FREED] = true; - s7_starlet_immutable_field[SL_GC_TOTAL_FREED] = true; - s7_starlet_immutable_field[SL_GC_PROTECTED_OBJECTS] = true; - s7_starlet_immutable_field[SL_MEMORY_USAGE] = true; - s7_starlet_immutable_field[SL_MOST_NEGATIVE_FIXNUM] = true; - s7_starlet_immutable_field[SL_MOST_POSITIVE_FIXNUM] = true; - s7_starlet_immutable_field[SL_ROOTLET_SIZE] = true; - s7_starlet_immutable_field[SL_STACK] = true; - s7_starlet_immutable_field[SL_STACK_SIZE] = true; - s7_starlet_immutable_field[SL_STACK_TOP] = true; - s7_starlet_immutable_field[SL_VERSION] = true; - s7_starlet_immutable_field[SL_MAJOR_VERSION] = true; - s7_starlet_immutable_field[SL_MINOR_VERSION] = true; -} - - -/* ---------------- gdbinit annotated stacktrace ---------------- */ -#if (!MS_WINDOWS) -/* s7bt, s7btfull: gdb stacktrace decoding */ - -static const char *decoded_name(s7_scheme *sc, const s7_pointer p) -{ - if (p == sc->value) return("sc->value"); - if (p == sc->args) return("sc->args"); - if (p == sc->code) return("sc->code"); - if (p == sc->cur_code) return("sc->cur_code"); - if (p == sc->curlet) return("sc->curlet"); - if (p == sc->nil) return("()"); - if (p == sc->T) return("#t"); - if (p == sc->F) return("#f"); - if (p == eof_object) return("eof_object"); - if (p == sc->undefined) return("undefined"); - if (p == sc->unspecified) return("unspecified"); - if (p == sc->no_value) return("no_value"); - if (p == sc->unused) return("#"); - if (p == sc->symbol_table) return("symbol_table"); - if (p == sc->rootlet) return("rootlet"); - if (p == sc->s7_starlet) return("*s7*"); /* this is the function */ - if (p == sc->unlet) return("unlet"); - if (p == sc->error_port) return("error_port"); - if (p == sc->owlet) return("owlet"); - if (p == sc->standard_input) return("*stdin*"); - if (p == sc->standard_output) return("*stdout*"); - if (p == sc->standard_error) return("*stderr*"); - if (p == sc->else_symbol) return("else_symbol"); - if (p == current_input_port(sc)) return("current-input-port"); - if (p == current_output_port(sc)) return("current-output-port"); - return((p == sc->stack) ? "stack" : NULL); -} - -static bool is_decodable(s7_scheme *sc, const s7_pointer p) -{ - int32_t i; - s7_pointer *tp = sc->heap; - s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); - - /* check symbol-table */ - for (i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) - { - s7_pointer sym = car(x); - if ((sym == p) || - ((is_global(sym)) && (is_slot(global_slot(sym))) && (p == global_value(sym)))) - return(true); - } - - for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true); - for (i = 0; i < NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true); - - /* check the heap */ - while (tp < heap_top) - if (p == (*tp++)) - return(true); - return(false); -} - -char *s7_decode_bt(s7_scheme *sc) -{ - FILE *fp = fopen("gdb.txt", "r"); - if (fp) - { - int64_t size; - size_t bytes; - bool in_quotes = false, old_stop = sc->stop_at_error; - uint8_t *bt; - block_t *bt_block; - - sc->stop_at_error = false; - fseek(fp, 0, SEEK_END); - size = ftell(fp); - rewind(fp); - - bt_block = mallocate(sc, (size + 1) * sizeof(uint8_t)); - bt = (uint8_t *)block_data(bt_block); - bytes = fread(bt, sizeof(uint8_t), size, fp); - if (bytes != (size_t)size) - { - fclose(fp); - liberate(sc, bt_block); - return((char *)" oops "); - } - bt[size] = '\0'; - fclose(fp); - - for (int64_t i = 0; i < size; i++) - { - fputc(bt[i], stdout); - if ((bt[i] == '"') && ((i == 0) || (bt[i - 1] != '\\'))) - in_quotes = (!in_quotes); - else - if ((!in_quotes) && (i < size - 8) && - ((bt[i] == '=') && - (((bt[i + 1] == '0') && (bt[i + 2] == 'x')) || - ((bt[i + 1] == ' ') && (bt[i + 2] == '0') && (bt[i + 3] == 'x'))))) - { - void *vp; - int32_t vals = sscanf((const char *)(bt + i + 1), "%p", &vp); - if ((vp) && (vals == 1)) - { - int32_t k; - for (k = i + ((bt[i + 2] == 'x') ? 3 : 4); (k < size) && (is_digit(bt[k], 16)); k++); - if ((bt[k] != ' ') || (bt[k + 1] != '"')) - { - if (vp == (void *)sc) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - fprintf(stdout, "%s[s7]%s", BOLD_TEXT, UNBOLD_TEXT); - i = k - 1; - } - else - { - s7_pointer p = (s7_pointer)vp; - const char *dname = decoded_name(sc, p); - if (dname) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - fprintf(stdout, "%s[%s]%s", BOLD_TEXT, dname, UNBOLD_TEXT); - } - if ((dname) || (is_decodable(sc, p))) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - i = k - 1; - if (s7_is_valid(sc, p)) - { - s7_pointer strp = object_to_truncated_string(sc, p, 80); - if (dname) fprintf(stdout, " "); - fprintf(stdout, "%s%s%s", BOLD_TEXT, string_value(strp), UNBOLD_TEXT); - if ((is_pair(p)) && - (has_location(p))) - { - uint32_t line = pair_line_number(p), file = pair_file_number(p); - if (line > 0) - fprintf(stdout, " %s(%s[%u])%s", BOLD_TEXT, string_value(sc->file_names[file]), line, UNBOLD_TEXT); - }}}}}}}} - liberate(sc, bt_block); - sc->stop_at_error = old_stop; - } - return((char *)""); -} -#endif - - -/* -------------------------------- initialization -------------------------------- */ -static void init_fx_function(void) -{ - fx_function = (s7_function *)Calloc(NUM_OPS, sizeof(s7_function)); - - fx_function[HOP_SAFE_C_NC] = fx_c_nc; - fx_function[HOP_SAFE_C_S] = fx_c_s; - fx_function[HOP_SAFE_C_SC] = fx_c_sc; - fx_function[HOP_SAFE_C_CS] = fx_c_cs; - fx_function[HOP_SAFE_C_CQ] = fx_c_cq; - fx_function[HOP_SAFE_C_FF] = fx_c_ff; - fx_function[HOP_SAFE_C_SS] = fx_c_ss; - fx_function[HOP_SAFE_C_opNCq] = fx_c_opncq; - fx_function[HOP_SAFE_C_opSq] = fx_c_opsq; - fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq; - fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq; - fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq; - fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s; - fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c; - fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs; - fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq; - fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq; - fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c; - fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s; - fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq; - fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c; - fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c; - fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s; - fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq; - fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq; - fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq; - fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq; - fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq; - fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq; - fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq; - fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq; - fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq; - fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq; - fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq; - fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s; - - fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; - fx_function[HOP_SAFE_C_SSS] = fx_c_sss; - fx_function[HOP_SAFE_C_SCS] = fx_c_scs; - fx_function[HOP_SAFE_C_SCC] = fx_c_scc; - fx_function[HOP_SAFE_C_CSS] = fx_c_css; - fx_function[HOP_SAFE_C_CSC] = fx_c_csc; - fx_function[HOP_SAFE_C_CCS] = fx_c_ccs; - fx_function[HOP_SAFE_C_NS] = fx_c_ns; - - fx_function[HOP_SAFE_C_A] = fx_c_a; - fx_function[HOP_SAFE_C_AA] = fx_c_aa; - fx_function[HOP_SAFE_C_SA] = fx_c_sa; - fx_function[HOP_SAFE_C_AS] = fx_c_as; - fx_function[HOP_SAFE_C_CA] = fx_c_ca; - fx_function[HOP_SAFE_C_AC] = fx_c_ac; - fx_function[HOP_SAFE_C_AAA] = fx_c_aaa; - fx_function[HOP_SAFE_C_CAC] = fx_c_cac; - fx_function[HOP_SAFE_C_CSA] = fx_c_csa; - fx_function[HOP_SAFE_C_SCA] = fx_c_sca; - fx_function[HOP_SAFE_C_SAS] = fx_c_sas; - fx_function[HOP_SAFE_C_SAA] = fx_c_saa; - fx_function[HOP_SAFE_C_SSA] = fx_c_ssa; - fx_function[HOP_SAFE_C_ASS] = fx_c_ass; - fx_function[HOP_SAFE_C_AGG] = fx_c_agg; - fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca; - fx_function[HOP_SAFE_C_NA] = fx_c_na; - fx_function[HOP_SAFE_C_4A] = fx_c_4a; - fx_function[HOP_SAFE_C_opAq] = fx_c_opaq; - fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq; - fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq; - fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s; - fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq; - fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq; - - fx_function[HOP_HASH_TABLE_INCREMENT] = fx_hash_table_increment; - - fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a; - fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a; - fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a; - fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a; - fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a; - fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a; - fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s; - fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc; - fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc; - - fx_function[OP_COND_NA_NA] = fx_cond_na_na; -#if (!WITH_GMP) - fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a; -#endif - fx_function[OP_CASE_A_E_S_A] = fx_case_a_e_s_a; - fx_function[OP_CASE_A_G_S_A] = fx_case_a_g_s_a; - fx_function[OP_CASE_A_S_G_A] = fx_case_a_s_g_a; - fx_function[OP_IF_A_C_C] = fx_if_a_c_c; - fx_function[OP_IF_A_A] = fx_if_a_a; - fx_function[OP_IF_S_A_A] = fx_if_s_a_a; - fx_function[OP_IF_A_A_A] = fx_if_a_a_a; - fx_function[OP_IF_AND2_S_A] = fx_if_and2_s_a; - fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a; - fx_function[OP_IF_NOT_A_A_A] = fx_if_not_a_a_a; - fx_function[OP_IF_IS_TYPE_S_A_A] = fx_if_is_type_s_a_a; - fx_function[OP_OR_2A] = fx_or_2a; - fx_function[OP_OR_S_2] = fx_or_s_2; - fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2; - fx_function[OP_OR_3A] = fx_or_3a; - fx_function[OP_OR_N] = fx_or_n; - fx_function[OP_AND_2A] = fx_and_2a; - fx_function[OP_AND_S_2] = fx_and_s_2; - fx_function[OP_AND_3A] = fx_and_3a; - fx_function[OP_AND_N] = fx_and_n; - fx_function[OP_BEGIN_NA] = fx_begin_na; - fx_function[OP_BEGIN_AA] = fx_begin_aa; - fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a; - fx_function[OP_IMPLICIT_S7_STARLET_REF_S] = fx_implicit_s7_starlet_ref_s; - fx_function[OP_WITH_LET_S] = fx_with_let_s; - - /* these are ok even if a "z" branch is taken -- in that case the body does not have the is_optimized bit, so is_fxable returns false */ - fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la; - fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la; - fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la; - fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa; - fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa; - fx_function[OP_TC_AND_A_OR_A_L3A] = fx_tc_and_a_or_a_l3a; - fx_function[OP_TC_OR_A_AND_A_L3A] = fx_tc_or_a_and_a_l3a; - fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la; - fx_function[OP_TC_OR_A_AND_A_A_LA] = fx_tc_or_a_and_a_a_la; - fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la; - fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z; - fx_function[OP_TC_COND_A_Z_LA] = fx_tc_cond_a_z_la; - fx_function[OP_TC_COND_A_LA_Z] = fx_tc_cond_a_la_z; - fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa; - fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z; - fx_function[OP_TC_COND_A_Z_LAA] = fx_tc_cond_a_z_laa; - fx_function[OP_TC_COND_A_LAA_Z] = fx_tc_cond_a_laa_z; - fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; - fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la; - fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; - fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la; - fx_function[OP_TC_COND_A_Z_A_LA_Z] = fx_tc_cond_a_z_a_la_z; - fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la; - fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z; - fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa; - fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa; - fx_function[OP_TC_COND_A_Z_A_LAA_Z] = fx_tc_cond_a_z_a_laa_z; - fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; - fx_function[OP_TC_CASE_LA] = fx_tc_case_la; - fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a; - fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la; - fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa; - fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa; - fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa; - fx_function[OP_TC_LET_COND] = fx_tc_let_cond; - fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa; - - fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq; - fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a; - fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa; - fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq; /* very few calls (only s7test) */ - fx_function[OP_RECUR_AND_A_OR_A_LAA_LAA] = fx_recur_and_a_or_a_laa_laa; /* very few calls (lint) */ -} - -static void init_opt_functions(s7_scheme *sc) -{ -#if (!WITH_PURE_S7) - s7_set_b_7pp_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_7pp); - - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_unchecked); - - s7_set_p_pp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_ppp); - s7_set_i_i_function(sc, global_value(sc->integer_length_symbol), integer_length_i_i); - s7_set_i_7p_function(sc, global_value(sc->string_length_symbol), string_length_i_7p); - s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol), vector_length_i_7p); - s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol), vector_to_list_p_p); - s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol), string_to_list_p_p); - s7_set_p_p_function(sc, global_value(sc->vector_length_symbol), vector_length_p_p); - s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol), is_exact_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), is_inexact_b_7p); - s7_set_p_p_function(sc, global_value(sc->exact_to_inexact_symbol), exact_to_inexact_p_p); - s7_set_p_p_function(sc, global_value(sc->inexact_to_exact_symbol), inexact_to_exact_p_p); -#endif - - s7_set_p_pp_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_p_pp); - s7_set_d_7pi_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pi); - s7_set_d_7pii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pii); - s7_set_d_7piii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7piii); - s7_set_d_7pid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7pid); - s7_set_d_7piid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piid); - s7_set_d_7piiid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piiid); - - s7_set_p_pp_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_p_pp); - s7_set_i_7pi_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pi); - s7_set_i_7pii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pii); - s7_set_i_7piii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7piii); - s7_set_i_7pii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7pii); - s7_set_i_7piii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7piii); - - s7_set_i_7pi_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pi); - s7_set_i_7pii_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pii); - s7_set_i_7pii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7pii); - s7_set_i_7piii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7piii); - - s7_set_p_pp_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pp); - s7_set_p_pi_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi); - s7_set_p_pii_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pii); - s7_set_p_pip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip); - s7_set_p_piip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_piip); - s7_set_p_pi_unchecked_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi_unchecked); - s7_set_p_pip_unchecked_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip_unchecked); - s7_set_p_ppp_function(sc, global_value(sc->vector_set_symbol), vector_set_p_ppp); - s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_ppp); - - s7_set_p_pp_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pp); - s7_set_p_pi_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi); - s7_set_p_pip_function(sc, global_value(sc->list_set_symbol), list_set_p_pip); - s7_set_p_pi_unchecked_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi_unchecked); - s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol), list_set_p_pip_unchecked); - s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol), cyclic_sequences_p_p); - s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), let_ref); - s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set); - s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi); - s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pp); - s7_set_p_pip_function(sc, global_value(sc->string_set_symbol), string_set_p_pip); - s7_set_p_pi_unchecked_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi_unchecked); - s7_set_p_pip_unchecked_function(sc, global_value(sc->string_set_symbol), string_set_p_pip_unchecked); - s7_set_p_pp_function(sc, global_value(sc->hash_table_ref_symbol), hash_table_ref_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->hash_table_set_symbol), hash_table_set_p_ppp); - - s7_set_p_ii_function(sc, global_value(sc->complex_symbol), complex_p_ii); - s7_set_p_dd_function(sc, global_value(sc->complex_symbol), complex_p_dd); - s7_set_p_i_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_i); - s7_set_p_p_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_p); - s7_set_p_pp_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_pp); - s7_set_p_p_function(sc, global_value(sc->string_to_number_symbol), string_to_number_p_p); - s7_set_p_pp_function(sc, global_value(sc->string_to_number_symbol), string_to_number_p_pp); - - s7_set_p_p_function(sc, global_value(sc->car_symbol), car_p_p); - s7_set_p_pp_function(sc, global_value(sc->set_car_symbol), set_car_p_pp); - s7_set_p_p_function(sc, global_value(sc->cdr_symbol), cdr_p_p); - s7_set_p_pp_function(sc, global_value(sc->set_cdr_symbol), set_cdr_p_pp); - s7_set_p_p_function(sc, global_value(sc->caar_symbol), caar_p_p); - s7_set_p_p_function(sc, global_value(sc->cadr_symbol), cadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cdar_symbol), cdar_p_p); - s7_set_p_p_function(sc, global_value(sc->cddr_symbol), cddr_p_p); - s7_set_p_p_function(sc, global_value(sc->caddr_symbol), caddr_p_p); - s7_set_p_p_function(sc, global_value(sc->caadr_symbol), caadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cadar_symbol), cadar_p_p); - s7_set_p_p_function(sc, global_value(sc->cdddr_symbol), cdddr_p_p); - s7_set_p_p_function(sc, global_value(sc->cdadr_symbol), cdadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cddar_symbol), cddar_p_p); - s7_set_p_p_function(sc, global_value(sc->cdaar_symbol), cdaar_p_p); - s7_set_p_p_function(sc, global_value(sc->caaar_symbol), caaar_p_p); - s7_set_p_p_function(sc, global_value(sc->caddar_symbol), caddar_p_p); - s7_set_p_p_function(sc, global_value(sc->caaddr_symbol), caaddr_p_p); - s7_set_p_p_function(sc, global_value(sc->cadddr_symbol), cadddr_p_p); - s7_set_p_p_function(sc, global_value(sc->cadadr_symbol), cadadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cddadr_symbol), cddadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cdddar_symbol), cdddar_p_p); - s7_set_p_p_function(sc, global_value(sc->cddddr_symbol), cddddr_p_p); - - s7_set_p_p_function(sc, global_value(sc->string_symbol), string_p_p); - s7_set_p_p_function(sc, global_value(sc->string_to_symbol_symbol), string_to_symbol_p_p); - s7_set_p_p_function(sc, global_value(sc->symbol_to_string_symbol), symbol_to_string_p_p); - s7_set_p_p_function(sc, global_value(sc->symbol_symbol), string_to_symbol_p_p); - s7_set_p_pp_function(sc, global_value(sc->symbol_symbol), symbol_p_pp); - s7_set_p_function(sc, global_value(sc->newline_symbol), newline_p); - s7_set_p_p_function(sc, global_value(sc->newline_symbol), newline_p_p); - s7_set_p_p_function(sc, global_value(sc->display_symbol), display_p_p); - s7_set_p_pp_function(sc, global_value(sc->display_symbol), display_p_pp); - s7_set_p_p_function(sc, global_value(sc->write_symbol), write_p_p); - s7_set_p_pp_function(sc, global_value(sc->write_symbol), write_p_pp); - s7_set_p_p_function(sc, global_value(sc->write_char_symbol), write_char_p_p); - s7_set_p_pp_function(sc, global_value(sc->write_char_symbol), write_char_p_pp); - s7_set_p_pp_function(sc, global_value(sc->write_string_symbol), write_string_p_pp); - s7_set_p_pp_function(sc, global_value(sc->read_line_symbol), read_line_p_pp); - s7_set_p_p_function(sc, global_value(sc->read_line_symbol), read_line_p_p); - s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp); - s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol), s7_port_line_number); - s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp); - s7_set_p_function(sc, global_value(sc->open_output_string_symbol), s7_open_output_string); - s7_set_p_ppi_function(sc, global_value(sc->char_position_symbol), char_position_p_ppi); - s7_set_p_pp_function(sc, global_value(sc->append_symbol), s7_append); - s7_set_p_pp_function(sc, global_value(sc->string_append_symbol), string_append_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->append_symbol), append_p_ppp); - s7_set_p_function(sc, global_value(sc->values_symbol), values_p); - s7_set_p_p_function(sc, global_value(sc->values_symbol), values_p_p); - s7_set_p_pp_function(sc, global_value(sc->member_symbol), member_p_pp); - s7_set_p_pp_function(sc, global_value(sc->assoc_symbol), assoc_p_pp); - - s7_set_i_i_function(sc, global_value(sc->abs_symbol), abs_i_i); - s7_set_d_d_function(sc, global_value(sc->abs_symbol), abs_d_d); - s7_set_p_p_function(sc, global_value(sc->abs_symbol), abs_p_p); - s7_set_i_i_function(sc, global_value(sc->magnitude_symbol), magnitude_i_i); - s7_set_d_d_function(sc, global_value(sc->magnitude_symbol), magnitude_d_d); - s7_set_p_p_function(sc, global_value(sc->magnitude_symbol), magnitude_p_p); - - s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d); - s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p); - s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d); - s7_set_p_p_function(sc, global_value(sc->cos_symbol), cos_p_p); - s7_set_p_p_function(sc, global_value(sc->tan_symbol), tan_p_p); - s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p); - s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p); - s7_set_p_p_function(sc, global_value(sc->sinh_symbol), sinh_p_p); - s7_set_p_p_function(sc, global_value(sc->cosh_symbol), cosh_p_p); - s7_set_p_p_function(sc, global_value(sc->asinh_symbol), asinh_p_p); - s7_set_p_p_function(sc, global_value(sc->acosh_symbol), acosh_p_p); - s7_set_p_p_function(sc, global_value(sc->atanh_symbol), atanh_p_p); - s7_set_p_p_function(sc, global_value(sc->tanh_symbol), tanh_p_p); - s7_set_d_d_function(sc, global_value(sc->sin_symbol), sin_d_d); - s7_set_d_d_function(sc, global_value(sc->cos_symbol), cos_d_d); - s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d); - s7_set_p_d_function(sc, global_value(sc->sinh_symbol), sinh_p_d); - s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d); - s7_set_p_d_function(sc, global_value(sc->cosh_symbol), cosh_p_d); - s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d); - s7_set_p_d_function(sc, global_value(sc->exp_symbol), exp_p_d); - - s7_set_p_d_function(sc, global_value(sc->rationalize_symbol), rationalize_p_d); - s7_set_p_i_function(sc, global_value(sc->rationalize_symbol), rationalize_p_i); - s7_set_i_i_function(sc, global_value(sc->rationalize_symbol), rationalize_i_i); - s7_set_p_p_function(sc, global_value(sc->truncate_symbol), truncate_p_p); - s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p); - s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p); - s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p); - s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp); - s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp); - s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p); -#if (!WITH_GMP) - s7_set_p_pp_function(sc, global_value(sc->expt_symbol), expt_p_pp); - /* same problem affects big_log|logior|logand|logxor|lcm|gcd|rationalize|remainder|modulo -- *_p_* will fail in gmp s7 */ - s7_set_p_d_function(sc, global_value(sc->ceiling_symbol), ceiling_p_d); - s7_set_p_d_function(sc, global_value(sc->floor_symbol), floor_p_d); - s7_set_p_d_function(sc, global_value(sc->truncate_symbol), truncate_p_d); - s7_set_p_d_function(sc, global_value(sc->round_symbol), round_p_d); -#endif - s7_set_d_7dd_function(sc, global_value(sc->remainder_symbol), remainder_d_7dd); - s7_set_i_7ii_function(sc, global_value(sc->remainder_symbol), remainder_i_7ii); - s7_set_i_7ii_function(sc, global_value(sc->quotient_symbol), quotient_i_7ii); - s7_set_d_7dd_function(sc, global_value(sc->modulo_symbol), modulo_d_7dd); - s7_set_i_ii_function(sc, global_value(sc->modulo_symbol), modulo_i_ii); - s7_set_p_dd_function(sc, global_value(sc->multiply_symbol), mul_p_dd); - s7_set_p_dd_function(sc, global_value(sc->add_symbol), add_p_dd); - s7_set_p_ii_function(sc, global_value(sc->add_symbol), add_p_ii); - s7_set_p_dd_function(sc, global_value(sc->subtract_symbol), subtract_p_dd); - s7_set_p_ii_function(sc, global_value(sc->subtract_symbol), subtract_p_ii); - - s7_set_p_pp_function(sc, global_value(sc->modulo_symbol), modulo_p_pp); - s7_set_p_pi_function(sc, global_value(sc->modulo_symbol), modulo_p_pi); - s7_set_p_pp_function(sc, global_value(sc->remainder_symbol), remainder_p_pp); - s7_set_p_pi_function(sc, global_value(sc->remainder_symbol), remainder_p_pi); - s7_set_p_pp_function(sc, global_value(sc->quotient_symbol), quotient_p_pp); - s7_set_p_pi_function(sc, global_value(sc->quotient_symbol), quotient_p_pi); - s7_set_p_pp_function(sc, global_value(sc->subtract_symbol), subtract_p_pp); - s7_set_p_pp_function(sc, global_value(sc->add_symbol), add_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->add_symbol), add_p_ppp); - s7_set_p_pp_function(sc, global_value(sc->multiply_symbol), multiply_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->multiply_symbol), multiply_p_ppp); - s7_set_p_pp_function(sc, global_value(sc->divide_symbol), divide_p_pp); - s7_set_p_p_function(sc, global_value(sc->divide_symbol), invert_p_p); - s7_set_p_p_function(sc, global_value(sc->subtract_symbol), negate_p_p); - s7_set_p_p_function(sc, global_value(sc->is_even_symbol), is_even_p_p); - s7_set_p_p_function(sc, global_value(sc->is_odd_symbol), is_odd_p_p); - - s7_set_p_p_function(sc, global_value(sc->random_symbol), random_p_p); - s7_set_d_7d_function(sc, global_value(sc->random_symbol), random_d_7d); - s7_set_i_7i_function(sc, global_value(sc->random_symbol), random_i_7i); - - s7_set_p_d_function(sc, global_value(sc->float_vector_symbol), float_vector_p_d); - s7_set_p_i_function(sc, global_value(sc->int_vector_symbol), int_vector_p_i); - s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i); - s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i); - s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i); - s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i); - - s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d); - s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd); - s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d); - s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p); -#if (!WITH_GMP) - s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii); - s7_set_i_7d_function(sc, global_value(sc->round_symbol), round_i_7d); - s7_set_i_7d_function(sc, global_value(sc->floor_symbol), floor_i_7d); - s7_set_i_7d_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7d); - s7_set_i_7p_function(sc, global_value(sc->floor_symbol), floor_i_7p); - s7_set_i_7p_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7p); - s7_set_i_7d_function(sc, global_value(sc->truncate_symbol), truncate_i_7d); -#endif - - s7_set_d_d_function(sc, global_value(sc->add_symbol), add_d_d); - s7_set_d_d_function(sc, global_value(sc->subtract_symbol), subtract_d_d); - s7_set_d_d_function(sc, global_value(sc->multiply_symbol), multiply_d_d); - s7_set_d_7d_function(sc, global_value(sc->divide_symbol), divide_d_7d); - s7_set_d_dd_function(sc, global_value(sc->add_symbol), add_d_dd); - s7_set_d_dd_function(sc, global_value(sc->subtract_symbol), subtract_d_dd); - s7_set_d_dd_function(sc, global_value(sc->multiply_symbol), multiply_d_dd); - s7_set_d_7dd_function(sc, global_value(sc->divide_symbol), divide_d_7dd); - s7_set_d_ddd_function(sc, global_value(sc->add_symbol), add_d_ddd); - s7_set_d_ddd_function(sc, global_value(sc->subtract_symbol), subtract_d_ddd); - s7_set_d_ddd_function(sc, global_value(sc->multiply_symbol), multiply_d_ddd); - s7_set_d_dddd_function(sc, global_value(sc->add_symbol), add_d_dddd); - s7_set_d_dddd_function(sc, global_value(sc->subtract_symbol), subtract_d_dddd); - s7_set_d_dddd_function(sc, global_value(sc->multiply_symbol), multiply_d_dddd); - s7_set_p_i_function(sc, global_value(sc->divide_symbol), divide_p_i); - s7_set_p_ii_function(sc, global_value(sc->divide_symbol), divide_p_ii); - s7_set_d_dd_function(sc, global_value(sc->max_symbol), max_d_dd); - s7_set_d_dd_function(sc, global_value(sc->min_symbol), min_d_dd); - s7_set_d_ddd_function(sc, global_value(sc->max_symbol), max_d_ddd); - s7_set_d_ddd_function(sc, global_value(sc->min_symbol), min_d_ddd); - s7_set_d_dddd_function(sc, global_value(sc->max_symbol), max_d_dddd); - s7_set_d_dddd_function(sc, global_value(sc->min_symbol), min_d_dddd); - s7_set_i_ii_function(sc, global_value(sc->max_symbol), max_i_ii); - s7_set_i_ii_function(sc, global_value(sc->min_symbol), min_i_ii); - s7_set_i_iii_function(sc, global_value(sc->max_symbol), max_i_iii); - s7_set_i_iii_function(sc, global_value(sc->min_symbol), min_i_iii); - s7_set_i_i_function(sc, global_value(sc->subtract_symbol), subtract_i_i); - s7_set_i_ii_function(sc, global_value(sc->add_symbol), add_i_ii); - s7_set_i_iii_function(sc, global_value(sc->add_symbol), add_i_iii); - s7_set_i_ii_function(sc, global_value(sc->subtract_symbol), subtract_i_ii); - s7_set_i_iii_function(sc, global_value(sc->subtract_symbol), subtract_i_iii); - s7_set_i_ii_function(sc, global_value(sc->multiply_symbol), multiply_i_ii); - s7_set_i_iii_function(sc, global_value(sc->multiply_symbol), multiply_i_iii); - - s7_set_i_i_function(sc, global_value(sc->lognot_symbol), lognot_i_i); - s7_set_i_ii_function(sc, global_value(sc->logior_symbol), logior_i_ii); - s7_set_i_ii_function(sc, global_value(sc->logxor_symbol), logxor_i_ii); - s7_set_i_ii_function(sc, global_value(sc->logand_symbol), logand_i_ii); - s7_set_i_iii_function(sc, global_value(sc->logior_symbol), logior_i_iii); - s7_set_i_iii_function(sc, global_value(sc->logxor_symbol), logxor_i_iii); - s7_set_i_iii_function(sc, global_value(sc->logand_symbol), logand_i_iii); - s7_set_b_7ii_function(sc, global_value(sc->logbit_symbol), logbit_b_7ii); - s7_set_b_7pp_function(sc, global_value(sc->logbit_symbol), logbit_b_7pp); - - s7_set_i_7p_function(sc, global_value(sc->numerator_symbol), numerator_i_7p); - s7_set_i_7p_function(sc, global_value(sc->denominator_symbol), denominator_i_7p); - s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_i_7p); - s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol), hash_table_entries_i_7p); - s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_i_7p); - s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_p_p); - - s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol), s7_is_boolean); - s7_set_b_p_function(sc, global_value(sc->is_byte_symbol), is_byte); - s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), is_byte_vector_b_p); - s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol), s7_is_c_object); - s7_set_b_p_function(sc, global_value(sc->is_char_symbol), s7_is_character); - s7_set_b_p_function(sc, global_value(sc->is_complex_symbol), s7_is_complex); - s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), is_continuation_b_p); - s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol), s7_is_c_pointer); - s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol), s7_is_dilambda); - s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), is_eof_object_b_p); - s7_set_b_7p_function(sc, global_value(sc->is_even_symbol), is_even_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p); - s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b); - s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol), s7_is_float_vector); - s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), is_gensym_b_p); - s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol), s7_is_hash_table); - s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol), is_infinite_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p); - s7_set_b_p_function(sc, global_value(sc->is_input_port_symbol), is_input_port_b); - s7_set_b_p_function(sc, global_value(sc->is_integer_symbol), s7_is_integer); - s7_set_b_p_function(sc, global_value(sc->is_int_vector_symbol), s7_is_int_vector); - s7_set_b_p_function(sc, global_value(sc->is_keyword_symbol), s7_is_keyword); - s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let); - s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b); - s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b); - s7_set_b_p_function(sc, global_value(sc->is_number_symbol), s7_is_number); - s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol), is_output_port_b); - s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair); - s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p); - s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol), is_port_closed_b_7p); - s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol), s7_is_procedure); - s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol), s7_is_proper_list); - s7_set_b_p_function(sc, global_value(sc->is_random_state_symbol), s7_is_random_state); - s7_set_b_p_function(sc, global_value(sc->is_rational_symbol), s7_is_rational); - s7_set_b_p_function(sc, global_value(sc->is_real_symbol), s7_is_real); - s7_set_b_p_function(sc, global_value(sc->is_sequence_symbol), is_sequence_b); - s7_set_b_p_function(sc, global_value(sc->is_string_symbol), s7_is_string); - s7_set_b_p_function(sc, global_value(sc->is_symbol_symbol), s7_is_symbol); - s7_set_b_p_function(sc, global_value(sc->is_syntax_symbol), s7_is_syntax); - s7_set_b_p_function(sc, global_value(sc->is_vector_symbol), s7_is_vector); - s7_set_b_7p_function(sc, global_value(sc->is_iterator_symbol), is_iterator_b_7p); - - s7_set_b_7p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_lower_case_symbol), is_char_lower_case_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_upper_case_symbol), is_char_upper_case_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_b_7p); - - s7_set_b_p_function(sc, global_value(sc->is_openlet_symbol), s7_is_openlet); - s7_set_b_7p_function(sc, global_value(sc->iterator_is_at_end_symbol), iterator_is_at_end_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_zero_symbol), is_zero_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), is_negative_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), is_positive_b_7p); - s7_set_b_7p_function(sc, global_value(sc->not_symbol), not_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_provided_symbol), is_provided_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7p); - s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol), s7_tree_memq); - s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol), tree_is_cyclic); - s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_b_7pp); - s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_p_pp); - s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol), s7_is_immutable); - - s7_set_p_p_function(sc, global_value(sc->is_proper_list_symbol), is_proper_list_p_p); - s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p); - s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), is_constant_p_p); - s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), is_constant_b_7p); - s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of); - s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_i); - s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_p); - s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p); - s7_set_p_p_function(sc, global_value(sc->list_symbol), list_p_p); - s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp); - s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol), list_tail_p_pp); - s7_set_p_pp_function(sc, global_value(sc->make_list_symbol), make_list_p_pp); - s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp); - s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->memv_symbol), memv_p_pp); - s7_set_p_p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_p_p); - s7_set_p_p_function(sc, global_value(sc->length_symbol), s7_length); - s7_set_p_p_function(sc, global_value(sc->pair_line_number_symbol), pair_line_number_p_p); - s7_set_p_p_function(sc, global_value(sc->port_line_number_symbol), port_line_number_p_p); - s7_set_p_p_function(sc, global_value(sc->port_filename_symbol), port_filename_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_info_symbol), c_pointer_info_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_type_symbol), c_pointer_type_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_weak1_symbol), c_pointer_weak1_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol), c_pointer_weak2_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_p_p); - s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol), char_upcase_p_p); - s7_set_p_p_function(sc, global_value(sc->read_char_symbol), read_char_p_p); - s7_set_p_i_function(sc, global_value(sc->make_string_symbol), make_string_p_i); - s7_set_p_ii_function(sc, global_value(sc->make_int_vector_symbol), make_int_vector_p_ii); - s7_set_p_ii_function(sc, global_value(sc->make_byte_vector_symbol), make_byte_vector_p_ii); - s7_set_p_pp_function(sc, global_value(sc->vector_symbol), vector_p_pp); - s7_set_p_p_function(sc, global_value(sc->signature_symbol), s7_signature); - s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p); - s7_set_p_p_function(sc, global_value(sc->reverse_symbol), reverse_p_p); - s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol), object_to_let_p_p); - s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p); - s7_set_p_p_function(sc, global_value(sc->make_iterator_symbol), s7_make_iterator); - -#if WITH_SYSTEM_EXTRAS - s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol), is_directory_b_7p); - s7_set_b_7p_function(sc, global_value(sc->file_exists_symbol), file_exists_b_7p); -#endif - - s7_set_b_i_function(sc, global_value(sc->is_even_symbol), is_even_i); - s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), is_odd_i); - s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), is_zero_i); - s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), is_zero_d); - s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), is_zero_p_p); - s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), is_positive_p_p); - s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), is_negative_p_p); - s7_set_p_p_function(sc, global_value(sc->real_part_symbol), real_part_p_p); - s7_set_p_p_function(sc, global_value(sc->imag_part_symbol), imag_part_p_p); - s7_set_b_i_function(sc, global_value(sc->is_positive_symbol), is_positive_i); - s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), is_positive_d); - s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), is_negative_i); - s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), is_negative_d); - - s7_set_p_pi_function(sc, global_value(sc->lt_symbol), lt_p_pi); - s7_set_b_pi_function(sc, global_value(sc->lt_symbol), lt_b_pi); - s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi); - s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi); - s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi); - s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi); - s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi); - s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi); - /* no ip pd dp! */ - s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi); - s7_set_p_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pi); - s7_set_p_pi_function(sc, global_value(sc->add_symbol), add_p_pi); - s7_set_p_pi_function(sc, global_value(sc->subtract_symbol), g_sub_xi); - s7_set_p_pi_function(sc, global_value(sc->multiply_symbol), multiply_p_pi); - - s7_set_p_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_p_ii); - s7_set_p_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_p_dd); - s7_set_p_pp_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->num_eq_symbol), num_eq_b_7pp); - s7_set_b_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_b_ii); - s7_set_b_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_b_dd); - - s7_set_p_ii_function(sc, global_value(sc->lt_symbol), lt_p_ii); - s7_set_p_dd_function(sc, global_value(sc->lt_symbol), lt_p_dd); - s7_set_p_pp_function(sc, global_value(sc->lt_symbol), lt_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->lt_symbol), lt_b_7pp); - s7_set_b_ii_function(sc, global_value(sc->lt_symbol), lt_b_ii); - s7_set_b_dd_function(sc, global_value(sc->lt_symbol), lt_b_dd); - - s7_set_b_ii_function(sc, global_value(sc->leq_symbol), leq_b_ii); - s7_set_p_dd_function(sc, global_value(sc->leq_symbol), leq_p_dd); - s7_set_p_ii_function(sc, global_value(sc->leq_symbol), leq_p_ii); - s7_set_b_dd_function(sc, global_value(sc->leq_symbol), leq_b_dd); - s7_set_p_pp_function(sc, global_value(sc->leq_symbol), leq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->leq_symbol), leq_b_7pp); - - s7_set_b_ii_function(sc, global_value(sc->gt_symbol), gt_b_ii); - s7_set_b_dd_function(sc, global_value(sc->gt_symbol), gt_b_dd); - s7_set_p_dd_function(sc, global_value(sc->gt_symbol), gt_p_dd); - s7_set_p_ii_function(sc, global_value(sc->gt_symbol), gt_p_ii); - s7_set_p_pp_function(sc, global_value(sc->gt_symbol), gt_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->gt_symbol), gt_b_7pp); - - s7_set_b_ii_function(sc, global_value(sc->geq_symbol), geq_b_ii); - s7_set_b_dd_function(sc, global_value(sc->geq_symbol), geq_b_dd); - s7_set_p_ii_function(sc, global_value(sc->geq_symbol), geq_p_ii); - s7_set_p_dd_function(sc, global_value(sc->geq_symbol), geq_p_dd); - s7_set_p_pp_function(sc, global_value(sc->geq_symbol), geq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->geq_symbol), geq_b_7pp); - - s7_set_b_pp_function(sc, global_value(sc->is_eq_symbol), s7_is_eq); - s7_set_p_pp_function(sc, global_value(sc->is_eq_symbol), is_eq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->is_eqv_symbol), s7_is_eqv); - s7_set_p_pp_function(sc, global_value(sc->is_eqv_symbol), is_eqv_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->is_equal_symbol), s7_is_equal); - s7_set_b_7pp_function(sc, global_value(sc->is_equivalent_symbol), s7_is_equivalent); - s7_set_p_pp_function(sc, global_value(sc->is_equal_symbol), is_equal_p_pp); - s7_set_p_pp_function(sc, global_value(sc->is_equivalent_symbol), is_equivalent_p_pp); - s7_set_p_pp_function(sc, global_value(sc->char_eq_symbol), char_eq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->make_float_vector_symbol), make_float_vector_p_pp); - s7_set_p_pp_function(sc, global_value(sc->setter_symbol), setter_p_pp); - s7_set_p_pp_function(sc, global_value(sc->complex_symbol), complex_p_pp); - s7_set_p_pp_function(sc, global_value(sc->string_eq_symbol), string_eq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->string_lt_symbol), string_lt_p_pp); - s7_set_p_pp_function(sc, global_value(sc->string_gt_symbol), string_gt_p_pp); - - s7_set_b_7pp_function(sc, global_value(sc->char_lt_symbol), char_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_leq_symbol), char_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_gt_symbol), char_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_geq_symbol), char_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_eq_symbol), char_eq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_lt_symbol), string_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_leq_symbol), string_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_gt_symbol), string_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_geq_symbol), string_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_eq_symbol), string_eq_b_7pp); - - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_lt_symbol), char_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_leq_symbol), char_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_gt_symbol), char_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_geq_symbol), char_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_eq_symbol), char_eq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_lt_symbol), string_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_leq_symbol), string_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_gt_symbol), string_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_geq_symbol), string_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_eq_symbol), string_eq_b_unchecked); - - s7_set_b_7pp_function(sc, global_value(sc->is_aritable_symbol), is_aritable_b_7pp); -} - -static void init_features(s7_scheme *sc) -{ - s7_provide(sc, "s7"); - s7_provide(sc, "s7-" S7_VERSION); - s7_provide(sc, "ratio"); - -#if WITH_PURE_S7 - s7_provide(sc, "pure-s7"); -#endif -#if WITH_EXTRA_EXPONENT_MARKERS - s7_provide(sc, "dfls-exponents"); -#endif -#if HAVE_OVERFLOW_CHECKS - s7_provide(sc, "overflow-checks"); -#endif -#if WITH_SYSTEM_EXTRAS - s7_provide(sc, "system-extras"); -#endif -#if WITH_IMMUTABLE_UNQUOTE - s7_provide(sc, "immutable-unquote"); -#endif -#if S7_DEBUGGING - s7_provide(sc, "debugging"); -#endif -#if HAVE_COMPLEX_NUMBERS - s7_provide(sc, "complex-numbers"); -#endif -#if WITH_NUMBER_SEPARATOR - s7_provide(sc, "number-separator"); -#endif -#if WITH_HISTORY - s7_provide(sc, "history"); -#endif -#if WITH_C_LOADER - s7_provide(sc, "dlopen"); -#endif -#if (!DISABLE_AUTOLOAD) - s7_provide(sc, "autoload"); -#endif -#if S7_ALIGNED - s7_provide(sc, "aligned"); -#endif -#if POINTER_32 - s7_provide(sc, "32-bit"); -#endif - -#ifdef __APPLE__ - s7_provide(sc, "osx"); -#endif -#ifdef __linux__ - s7_provide(sc, "linux"); -#endif -#ifdef __OpenBSD__ - s7_provide(sc, "openbsd"); -#endif -#ifdef __NetBSD__ - s7_provide(sc, "netbsd"); -#endif -#ifdef __FreeBSD__ - s7_provide(sc, "freebsd"); -#endif -#if MS_WINDOWS - s7_provide(sc, "windows"); -#endif -#ifdef __bfin__ - s7_provide(sc, "blackfin"); -#endif -#ifdef __ANDROID__ - s7_provide(sc, "android"); -#endif -#ifdef __MSYS__ - s7_provide(sc, "msys2"); /* from chai xiaoxiang */ -#endif -#ifdef __MINGW32__ /* this is also defined in mingw64 */ - s7_provide(sc, "mingw"); -#endif -#ifdef __CYGWIN__ - s7_provide(sc, "cygwin"); /* this is also defined in msys2 */ -#endif -#ifdef __hpux - s7_provide(sc, "hpux"); -#endif -#if defined(__sun) && defined(__SVR4) - s7_provide(sc, "solaris"); -#endif - -#ifdef __SUNPRO_C - s7_provide(sc, "sunpro_c"); -#endif -#ifdef __clang__ - s7_provide(sc, "clang"); -#endif -#ifdef __GNUC__ - s7_provide(sc, "gcc"); -#endif -#ifdef __TINYC__ - s7_provide(sc, "tcc"); /* appears to be 3-4 times slower than gcc (compilation is at least 10 times faster however) */ -#endif -#ifdef __EMSCRIPTEN__ - s7_provide(sc, "emscripten"); -#endif -#ifdef _MSC_VER - s7_provide(sc, "msvc"); -#endif -} - -static void init_wrappers(s7_scheme *sc) -{ - s7_pointer cp, qp; - #define NUM_INTEGER_WRAPPERS 4 - #define NUM_REAL_WRAPPERS 4 - - sc->integer_wrappers = semipermanent_list(sc, NUM_INTEGER_WRAPPERS); - for (cp = sc->integer_wrappers, qp = sc->integer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) - { - s7_pointer p = alloc_pointer(sc); - car(cp) = p; - full_type(p) = T_INTEGER | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; /* mutable to turn off set_has_number_name */ - integer(p) = 0; - } - cdr(qp) = sc->integer_wrappers; - - sc->real_wrappers = semipermanent_list(sc, NUM_REAL_WRAPPERS); - for (cp = sc->real_wrappers, qp = sc->real_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) - { - s7_pointer p = alloc_pointer(sc); - car(cp) = p; - full_type(p) = T_REAL | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; - real(p) = 0.0; - } - cdr(qp) = sc->real_wrappers; - - sc->string_wrappers = semipermanent_list(sc, NUM_STRING_WRAPPERS); - for (cp = sc->string_wrappers, qp = sc->string_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) - { - s7_pointer p = alloc_pointer(sc); - car(cp) = p; - full_type(p) = T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE | T_UNHEAP; - string_block(p) = NULL; - string_value(p) = NULL; - string_length(p) = 0; - string_hash(p) = 0; - } - cdr(qp) = sc->string_wrappers; -} - -static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - uint64_t hash = raw_string_hash((const uint8_t *)name, safe_strlen(name)); - uint32_t loc = hash % SYMBOL_TABLE_SIZE; - s7_pointer x = new_symbol(sc, name, safe_strlen(name), hash, loc); - s7_pointer syn = alloc_pointer(sc); - - set_full_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_GLOBAL | T_UNHEAP); - syntax_opcode(syn) = op; - syntax_set_symbol(syn, x); - syntax_min_args(syn) = integer(min_args); - syntax_max_args(syn) = ((max_args == max_arity) ? -1 : integer(max_args)); - syntax_documentation(syn) = doc; - set_global_slot(x, make_semipermanent_slot(sc, x, syn)); - set_initial_slot(x, make_semipermanent_slot(sc, x, syn)); /* set_local_slot(x, global_slot(x)); */ - set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP); - symbol_set_local_slot_unchecked(x, 0LL, sc->nil); - symbol_clear_ctr(x); - return(x); -} - -static s7_pointer definer_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - s7_pointer x = syntax(sc, name, op, min_args, max_args, doc); - set_syntax_is_definer(x); - return(x); -} - -static s7_pointer binder_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - s7_pointer x = syntax(sc, name, op, min_args, max_args, doc); - set_syntax_is_binder(x); - return(x); -} - -static s7_pointer copy_args_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - s7_pointer x = syntax(sc, name, op, min_args, max_args, doc); - s7_pointer p = global_value(x); - full_type(p) |= T_COPY_ARGS; - return(x); -} - -static s7_pointer make_unique(s7_scheme *sc, const char* name, uint64_t typ) -{ - s7_pointer p = alloc_pointer(sc); - set_full_type(p, typ | T_IMMUTABLE | T_UNHEAP); - if (typ != T_UNUSED) set_optimize_op(p, OP_CONSTANT); - if (typ == T_UNDEFINED) /* sc->undefined here to avoid the undefined_constant_warning */ - { - undefined_set_name_length(p, safe_strlen(name)); - undefined_name(p) = copy_string_with_length(name, undefined_name_length(p)); - } - else - { - unique_name_length(p) = safe_strlen(name); - unique_name(p) = copy_string_with_length(name, unique_name_length(p)); - add_saved_pointer(sc, (void *)unique_name(p)); - } - return(p); -} - -static s7_pointer symbol_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - s7_pointer slot = lookup_slot_from(sym, sc->curlet); - if (!is_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "set!: '~S, is unbound", 21), sym)); - if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->symbol_symbol, sym)); - slot_set_value(slot, val); - return(val); -} - -static s7_pointer g_symbol_set(s7_scheme *sc, s7_pointer args) /* (set! (symbol ) ) */ -{ - s7_int i = 0, len; - s7_pointer lst, val; - if (is_null(cddr(args))) - return(symbol_set_1(sc, g_symbol(sc, set_plist_1(sc, car(args))), cadr(args))); - len = proper_list_length(args) - 1; - lst = safe_list_if_possible(sc, len); - if (in_heap(lst)) gc_protect_via_stack(sc, lst); - for (s7_pointer ap = args, lp = lst; i < len; ap = cdr(ap), lp = cdr(lp), i++) car(lp) = car(ap); - val = symbol_set_1(sc, g_symbol(sc, lst), s7_list_ref(sc, args, len)); - if (in_heap(lst)) unstack(sc); else clear_list_in_use(lst); - return(val); -} - -static void init_setters(s7_scheme *sc) -{ - sc->vector_set_function = global_value(sc->vector_set_symbol); - set_is_setter(sc->vector_set_symbol); - /* not float-vector-set! here */ - - sc->list_set_function = global_value(sc->list_set_symbol); - set_is_setter(sc->list_set_symbol); - - sc->hash_table_set_function = global_value(sc->hash_table_set_symbol); - set_is_setter(sc->hash_table_set_symbol); - - sc->let_set_function = global_value(sc->let_set_symbol); - set_is_setter(sc->let_set_symbol); - - sc->string_set_function = global_value(sc->string_set_symbol); - set_is_setter(sc->string_set_symbol); - - set_is_setter(sc->byte_vector_set_symbol); - set_is_setter(sc->set_car_symbol); - set_is_setter(sc->set_cdr_symbol); - set_is_safe_setter(sc->byte_vector_set_symbol); - set_is_safe_setter(sc->int_vector_set_symbol); - set_is_safe_setter(sc->float_vector_set_symbol); - set_is_safe_setter(sc->string_set_symbol); - -#if (WITH_PURE_S7) - /* we need to be able at least to set (current-output-port) to #f */ - c_function_set_setter(global_value(sc->current_input_port_symbol), - s7_make_safe_function(sc, "#", g_set_current_input_port, 1, 0, false, "*stdin* setter")); - c_function_set_setter(global_value(sc->current_output_port_symbol), - s7_make_safe_function(sc, "#", g_set_current_output_port, 1, 0, false, "*stdout* setter")); -#else - set_is_setter(sc->set_current_input_port_symbol); - set_is_setter(sc->set_current_output_port_symbol); - s7_function_set_setter(sc, sc->current_input_port_symbol, sc->set_current_input_port_symbol); - s7_function_set_setter(sc, sc->current_output_port_symbol, sc->set_current_output_port_symbol); -#endif - - set_is_setter(sc->set_current_error_port_symbol); - s7_function_set_setter(sc, sc->current_error_port_symbol, sc->set_current_error_port_symbol); - /* despite the similar names, current-error-port is different from the other two, and a setter is needed - * in scheme because error and warn send output to it by default. It is not a "dynamic variable". - */ - - s7_function_set_setter(sc, sc->car_symbol, sc->set_car_symbol); - s7_function_set_setter(sc, sc->cdr_symbol, sc->set_cdr_symbol); - s7_function_set_setter(sc, sc->hash_table_ref_symbol, sc->hash_table_set_symbol); - s7_function_set_setter(sc, sc->vector_ref_symbol, sc->vector_set_symbol); - s7_function_set_setter(sc, sc->float_vector_ref_symbol, sc->float_vector_set_symbol); - s7_function_set_setter(sc, sc->int_vector_ref_symbol, sc->int_vector_set_symbol); - s7_function_set_setter(sc, sc->byte_vector_ref_symbol, sc->byte_vector_set_symbol); - s7_function_set_setter(sc, sc->list_ref_symbol, sc->list_set_symbol); - s7_function_set_setter(sc, sc->let_ref_symbol, sc->let_set_symbol); - s7_function_set_setter(sc, sc->string_ref_symbol, sc->string_set_symbol); - c_function_set_setter(global_value(sc->outlet_symbol), - s7_make_safe_function(sc, "#", g_set_outlet, 2, 0, false, "outlet setter")); - c_function_set_setter(global_value(sc->port_line_number_symbol), - s7_make_safe_function(sc, "#", g_set_port_line_number, 1, 1, false, "port-line setter")); - c_function_set_setter(global_value(sc->port_position_symbol), - s7_make_safe_function(sc, "#", g_set_port_position, 2, 0, false, "port-position setter")); - c_function_set_setter(global_value(sc->vector_typer_symbol), - s7_make_safe_function(sc, "#", g_set_vector_typer, 2, 0, false, "vector-typer setter")); - c_function_set_setter(global_value(sc->hash_table_key_typer_symbol), - s7_make_safe_function(sc, "#", g_set_hash_table_key_typer, 2, 0, false, "hash-table-key-typer setter")); - c_function_set_setter(global_value(sc->hash_table_value_typer_symbol), - s7_make_safe_function(sc, "#", g_set_hash_table_value_typer, 2, 0, false, "hash-table-value-typer setter")); - c_function_set_setter(global_value(sc->symbol_symbol), s7_make_safe_function(sc, "symbol-set", g_symbol_set, 2, 0, true, "symbol setter")); -} - -static void init_syntax(s7_scheme *sc) -{ - #define H_quote "(quote obj) returns obj unevaluated. 'obj is an abbreviation for (quote obj)." - #define H_if "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \ -if optional-false-stuff exists, it is evaluated." - #define H_when "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last" - #define H_unless "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last" - #define H_begin "(begin ...) evaluates each form in its body, returning the value of the last one" - #define H_set "(set! variable value) sets the value of variable to value." - #define H_let "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\ -returning the value of the last form. The let variables are local to it, and are not available for use until all have been initialized." - #define H_let_star "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \ -returning the value of the last form. The let* variables are local to it, and are available immediately." - #define H_letrec "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \ -(i.e. you can define local recursive functions)" - #define H_letrec_star "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*" - #define H_cond "(cond (expr clause...)...) is like if..then. Each expr is evaluated in order, and if one is not #f, \ -the associated clauses are evaluated, whereupon cond returns." - #define H_and "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \ -as soon as one of them returns #f. If all are non-#f, it returns the last value." - #define H_or "(or expr expr ...) evaluates each of its arguments in order, quitting as soon as one of them is not #f. \ -If all are #f, or returns #f." - #define H_case "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \ -match is found (via eqv?), the associated clauses are evaluated, and case returns." - #define H_do "(do (vars...) (loop control and return value) ...) is a do-loop." - #define H_lambda "(lambda args ...) returns a function." - #define H_lambda_star "(lambda* args ...) returns a function; the args list can have default values, \ -the parameters themselves can be accessed via keywords." - #define H_define "(define var val) assigns val to the variable (symbol) var. (define (func args) ...) is \ -shorthand for (define func (lambda args ...))" - #define H_define_star "(define* (func args) ...) defines a function with optional/keyword arguments." - #define H_define_constant "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val." - #define H_define_macro "(define-macro (mac args) ...) defines mac to be a macro." - #define H_define_macro_star "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments." - #define H_macro "(macro args ...) defines an unnamed macro." - #define H_macro_star "(macro* args ...) defines an unnamed macro with optional/keyword arguments." - #define H_define_expansion "(define-expansion (mac args) ...) defines mac to be a read-time macro." - #define H_define_expansion_star "(define-expansion* (mac args) ...) defines mac to be a read-time macro*." - #define H_define_bacro "(define-bacro (mac args) ...) defines mac to be a bacro." - #define H_define_bacro_star "(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments." - #define H_bacro "(bacro args ...) defines an unnamed bacro." - #define H_bacro_star "(bacro* args ...) defines an unnamed bacro with optional/keyword arguments." - #define H_with_baffle "(with-baffle ...) evaluates its body in a context that blocks re-entry via call/cc." - #define H_macroexpand "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call." - #define H_with_let "(with-let let ...) evaluates its body in the environment let." - #define H_let_temporarily "(let-temporarily ((var value)...) . body) sets each var to its new value, evals body, \ -then returns each var to its original value." - - sc->quote_symbol = syntax(sc, "quote", OP_QUOTE, int_one, int_one, H_quote); - sc->if_symbol = syntax(sc, "if", OP_IF, int_two, int_three, H_if); - sc->when_symbol = syntax(sc, "when", OP_WHEN, int_two, max_arity, H_when); - sc->unless_symbol = syntax(sc, "unless", OP_UNLESS, int_two, max_arity, H_unless); - sc->begin_symbol = syntax(sc, "begin", OP_BEGIN, int_zero, max_arity, H_begin); /* (begin) is () */ - sc->set_symbol = syntax(sc, "set!", OP_SET, int_two, int_two, H_set); - sc->cond_symbol = copy_args_syntax(sc, "cond", OP_COND, int_one, max_arity, H_cond); - sc->and_symbol = copy_args_syntax(sc, "and", OP_AND, int_zero, max_arity, H_and); - sc->or_symbol = copy_args_syntax(sc, "or", OP_OR, int_zero, max_arity, H_or); - sc->case_symbol = syntax(sc, "case", OP_CASE, int_two, max_arity, H_case); - sc->macroexpand_symbol = syntax(sc, "macroexpand", OP_MACROEXPAND, int_one, int_one, H_macroexpand); - sc->let_temporarily_symbol = syntax(sc, "let-temporarily", OP_LET_TEMPORARILY, int_two, max_arity, H_let_temporarily); - sc->define_symbol = definer_syntax(sc, "define", OP_DEFINE, int_two, max_arity, H_define); - sc->define_star_symbol = definer_syntax(sc, "define*", OP_DEFINE_STAR, int_two, max_arity, H_define_star); - sc->define_constant_symbol = definer_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, int_two, max_arity, H_define_constant); - sc->define_macro_symbol = definer_syntax(sc, "define-macro", OP_DEFINE_MACRO, int_two, max_arity, H_define_macro); - sc->define_macro_star_symbol = definer_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, int_two, max_arity, H_define_macro_star); - sc->define_expansion_symbol = definer_syntax(sc, "define-expansion",OP_DEFINE_EXPANSION, int_two, max_arity, H_define_expansion); - sc->define_expansion_star_symbol = definer_syntax(sc, "define-expansion*",OP_DEFINE_EXPANSION_STAR, int_two, max_arity, H_define_expansion_star); - sc->define_bacro_symbol = definer_syntax(sc, "define-bacro", OP_DEFINE_BACRO, int_two, max_arity, H_define_bacro); - sc->define_bacro_star_symbol = definer_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, int_two, max_arity, H_define_bacro_star); - sc->let_symbol = binder_syntax(sc, "let", OP_LET, int_two, max_arity, H_let); - sc->let_star_symbol = binder_syntax(sc, "let*", OP_LET_STAR, int_two, max_arity, H_let_star); - sc->letrec_symbol = binder_syntax(sc, "letrec", OP_LETREC, int_two, max_arity, H_letrec); - sc->letrec_star_symbol = binder_syntax(sc, "letrec*", OP_LETREC_STAR, int_two, max_arity, H_letrec_star); - sc->do_symbol = binder_syntax(sc, "do", OP_DO, int_two, max_arity, H_do); /* 2 because body can be null */ - sc->lambda_symbol = binder_syntax(sc, "lambda", OP_LAMBDA, int_two, max_arity, H_lambda); - sc->lambda_star_symbol = binder_syntax(sc, "lambda*", OP_LAMBDA_STAR, int_two, max_arity, H_lambda_star); - sc->macro_symbol = binder_syntax(sc, "macro", OP_MACRO, int_two, max_arity, H_macro); - sc->macro_star_symbol = binder_syntax(sc, "macro*", OP_MACRO_STAR, int_two, max_arity, H_macro_star); - sc->bacro_symbol = binder_syntax(sc, "bacro", OP_BACRO, int_two, max_arity, H_bacro); - sc->bacro_star_symbol = binder_syntax(sc, "bacro*", OP_BACRO_STAR, int_two, max_arity, H_bacro_star); - sc->with_let_symbol = binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, H_with_let); - sc->with_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ - set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */ - set_immutable(sc->with_let_symbol); - set_immutable_slot(global_slot(sc->with_let_symbol)); - sc->setter_symbol = make_symbol(sc, "setter", 6); - -#if WITH_IMMUTABLE_UNQUOTE - /* this code solves the various unquote redefinition troubles - * if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,'1) -> 5 - */ - sc->unquote_symbol = make_symbol(sc, ",", 1); - set_immutable(sc->unquote_symbol); -#else - sc->unquote_symbol = make_symbol(sc, "unquote", 7); -#endif - - sc->feed_to_symbol = make_symbol(sc, "=>", 2); - sc->body_symbol = make_symbol(sc, "body", 4); - sc->read_error_symbol = make_symbol(sc, "read-error", 10); - sc->string_read_error_symbol = make_symbol(sc, "string-read-error", 17); - sc->syntax_error_symbol = make_symbol(sc, "syntax-error", 12); - sc->unbound_variable_symbol = make_symbol(sc, "unbound-variable", 16); - sc->wrong_type_arg_symbol = make_symbol(sc, "wrong-type-arg", 14); - sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args", 20); - sc->format_error_symbol = make_symbol(sc, "format-error", 12); - sc->autoload_error_symbol = make_symbol(sc, "autoload-error", 14); - sc->out_of_range_symbol = make_symbol(sc, "out-of-range", 12); - sc->out_of_memory_symbol = make_symbol(sc, "out-of-memory", 13); - sc->io_error_symbol = make_symbol(sc, "io-error", 8); - sc->missing_method_symbol = make_symbol(sc, "missing-method", 14); - sc->number_to_real_symbol = make_symbol(sc, "number_to_real", 14); - sc->invalid_escape_function_symbol = make_symbol(sc, "invalid-escape-function", 23); - sc->immutable_error_symbol = make_symbol(sc, "immutable-error", 15); - sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero", 16); - sc->bad_result_symbol = make_symbol(sc, "bad-result", 10); - sc->no_setter_symbol = make_symbol(sc, "no-setter", 9); - sc->baffled_symbol = make_symbol(sc, "baffled!", 8); - sc->value_symbol = make_symbol(sc, "value", 5); - sc->type_symbol = make_symbol(sc, "type", 4); - sc->position_symbol = make_symbol(sc, "position", 8); - sc->file_symbol = make_symbol(sc, "file", 4); - sc->line_symbol = make_symbol(sc, "line", 4); - sc->function_symbol = make_symbol(sc, "function", 8); - sc->else_symbol = make_symbol(sc, "else", 4); - s7_make_slot(sc, sc->nil, sc->else_symbol, sc->else_symbol); - slot_set_value(initial_slot(sc->else_symbol), sc->T); - /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) */ - - sc->allow_other_keys_keyword = s7_make_keyword(sc, "allow-other-keys"); - sc->rest_keyword = s7_make_keyword(sc, "rest"); - sc->if_keyword = s7_make_keyword(sc, "if"); /* internal optimizer local-let marker */ - sc->readable_keyword = s7_make_keyword(sc, "readable"); - sc->display_keyword = s7_make_keyword(sc, "display"); - sc->write_keyword = s7_make_keyword(sc, "write"); -} - -static void init_rootlet(s7_scheme *sc) -{ - /* most of init_rootlet (the built-in functions for example), could be shared by all s7 instances. - * currently, each s7_init call allocates room for them, then s7_free frees it -- kinda wasteful. - * allocate separately filling unlet then set symbols in init_rootlet by running through unlet and calling s7_define for each? - * need pre-unlet separate from thread-local unlet (dynamic loads). - * but currently the init_unlet run through the symbol table is wasting lots of time. - * unlet has only c_functions/syntax but should we support #_gsl* etc? - * split init_unlet, add load to defun macros - */ - s7_pointer sym; - init_syntax(sc); - - sc->owlet = init_owlet(sc); - - sc->wrong_type_arg_info = semipermanent_list(sc, 6); - set_car(sc->wrong_type_arg_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is ~A but should be ~A")); - - sc->sole_arg_wrong_type_info = semipermanent_list(sc, 5); - set_car(sc->sole_arg_wrong_type_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is ~A but should be ~A")); - - sc->out_of_range_info = semipermanent_list(sc, 5); - set_car(sc->out_of_range_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is out of range (~A)")); - - sc->sole_arg_out_of_range_info = semipermanent_list(sc, 4); - set_car(sc->sole_arg_out_of_range_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is out of range (~A)")); - - sc->gc_off = false; - - #define defun(Scheme_Name, C_Name, Req, Opt, Rst) \ - s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) - - #define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \ - s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) - - #define semisafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \ - s7_define_semisafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) - - #define b_defun(Scheme_Name, C_Name, Opt, SymId, Marker, Simple) \ - define_bool_function(sc, Scheme_Name, g_ ## C_Name, Opt, H_ ## C_Name, Q_ ## C_Name, SymId, Marker, Simple, b_ ## C_Name ## _setter) - - /* we need the sc->is_* symbols first for the procedure signature lists */ - sc->is_boolean_symbol = make_symbol(sc, "boolean?", 8); - sc->pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T); - - sc->is_symbol_symbol = b_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, true); - sc->is_syntax_symbol = b_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); - sc->is_gensym_symbol = b_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); - sc->is_keyword_symbol = b_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); - sc->is_let_symbol = b_defun("let?", is_let, 0, T_LET, mark_vector_1, false); - sc->is_openlet_symbol = b_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); - sc->is_iterator_symbol = b_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1, false); - sc->is_macro_symbol = b_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false); - sc->is_c_pointer_symbol = b_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1, false); - sc->is_input_port_symbol = b_defun("input-port?", is_input_port, 0, T_INPUT_PORT, mark_vector_1, true); - sc->is_output_port_symbol = b_defun("output-port?", is_output_port, 0, T_OUTPUT_PORT, mark_simple_vector, true); - sc->is_eof_object_symbol = b_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector, true); - sc->is_integer_symbol = b_defun("integer?", is_integer, 0, (WITH_GMP) ? T_FREE : T_INTEGER, mark_simple_vector, true); - sc->is_byte_symbol = b_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); - sc->is_number_symbol = b_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true); - sc->is_real_symbol = b_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true); - sc->is_float_symbol = b_defun("float?", is_float, 0, T_FREE, mark_simple_vector, true); - sc->is_complex_symbol = b_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector, true); - sc->is_rational_symbol = b_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector, true); - sc->is_random_state_symbol = b_defun("random-state?", is_random_state, 0, T_RANDOM_STATE, mark_simple_vector, true); - sc->is_char_symbol = b_defun("char?", is_char, 0, T_CHARACTER, just_mark_vector, true); - sc->is_string_symbol = b_defun("string?", is_string, 0, T_STRING, mark_simple_vector, true); - sc->is_list_symbol = b_defun("list?", is_list, 0, T_FREE, mark_vector_1, false); - sc->is_pair_symbol = b_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); - sc->is_vector_symbol = b_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); - sc->is_float_vector_symbol = b_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, mark_simple_vector, true); - sc->is_int_vector_symbol = b_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, mark_simple_vector, true); - sc->is_byte_vector_symbol = b_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, mark_simple_vector, true); - sc->is_hash_table_symbol = b_defun("hash-table?", is_hash_table, 0, T_HASH_TABLE, mark_vector_1, false); - sc->is_continuation_symbol = b_defun("continuation?", is_continuation, 0, T_CONTINUATION, mark_vector_1, false); - sc->is_procedure_symbol = b_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1, false); - sc->is_dilambda_symbol = b_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); - /* set above */ b_defun("boolean?", is_boolean, 0, T_BOOLEAN, just_mark_vector, true); - sc->is_proper_list_symbol = b_defun("proper-list?", is_proper_list, 0, T_FREE, mark_vector_1, false); - sc->is_sequence_symbol = b_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); - sc->is_null_symbol = b_defun("null?", is_null, 0, T_NIL, just_mark_vector, true); - sc->is_undefined_symbol = b_defun("undefined?", is_undefined, 0, T_UNDEFINED, just_mark_vector, true); - sc->is_unspecified_symbol = b_defun("unspecified?", is_unspecified, 0, T_UNSPECIFIED, just_mark_vector, true); - sc->is_c_object_symbol = b_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1, false); - sc->is_subvector_symbol = b_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); - sc->is_weak_hash_table_symbol = b_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE, mark_vector_1, false); - sc->is_goto_symbol = b_defun("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); - - /* these are for signatures */ - sc->not_symbol = defun("not", not, 1, 0, false); - sc->is_integer_or_real_at_end_symbol = make_symbol(sc, "integer:real?", 13); - sc->is_integer_or_any_at_end_symbol = make_symbol(sc, "integer:any?", 12); - - sc->pl_p = s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol); - sc->pl_tl = s7_make_signature(sc, 3, - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */ - sc->pl_bc = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_char_symbol); - sc->pl_bn = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol); - sc->pl_nn = s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol); - sc->pl_sf = s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)); - sc->pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T); - sc->pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol); - sc->pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_string_symbol); - sc->pcl_i = s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol); - sc->pcl_r = s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol); - sc->pcl_f = s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol); - sc->pcl_n = s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol); - sc->pcl_s = s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol); - sc->pcl_v = s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol); - sc->pcl_c = s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol); - sc->pcl_e = s7_make_circular_signature(sc, 0, 1, - s7_make_signature(sc, 4, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_c_object_symbol)); - - sc->values_symbol = make_symbol(sc, "values", 6); - - sc->is_bignum_symbol = defun("bignum?", is_bignum, 1, 0, false); - sc->bignum_symbol = defun("bignum", bignum, 1, 1, false); - - sc->gensym_symbol = defun("gensym", gensym, 0, 1, false); - sc->symbol_table_symbol = defun("symbol-table", symbol_table, 0, 0, false); - sc->symbol_to_string_symbol = defun("symbol->string", symbol_to_string, 1, 0, false); - sc->string_to_symbol_symbol = defun("string->symbol", string_to_symbol, 1, 0, false); - sc->symbol_symbol = defun("symbol", symbol, 1, 0, true); - sc->symbol_to_value_symbol = defun("symbol->value", symbol_to_value, 1, 1, false); - sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false); - sc->immutable_symbol = defun("immutable!", immutable, 1, 0, false); - sc->is_immutable_symbol = defun("immutable?", is_immutable, 1, 0, false); - sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false); - sc->string_to_keyword_symbol = defun("string->keyword", string_to_keyword, 1, 0, false); - sc->symbol_to_keyword_symbol = defun("symbol->keyword", symbol_to_keyword, 1, 0, false); - sc->keyword_to_symbol_symbol = defun("keyword->symbol", keyword_to_symbol, 1, 0, false); - - sc->outlet_symbol = unsafe_defun("outlet", outlet, 1, 0, false); - sc->rootlet_symbol = unsafe_defun("rootlet", rootlet, 0, 0, false); /* unsafe else unbound var in g_is_defined_in_rootlet? */ - sc->curlet_symbol = unsafe_defun("curlet", curlet, 0, 0, false); /* (define (f a) (curlet)) exports the funclet */ - set_func_is_definer(sc->curlet_symbol); - sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); - set_local_slot(sc->unlet_symbol, global_slot(sc->unlet_symbol)); /* for set_locals */ - set_immutable(sc->unlet_symbol); - set_immutable_slot(global_slot(sc->unlet_symbol)); - /* unlet (and with-let) don't actually need to be immutable, but s7.html says they are... */ - sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); - sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); - sc->varlet_symbol = semisafe_defun("varlet", varlet, 2, 0, true); /* was 1,0 13-Aug-22 */ - set_func_is_definer(sc->varlet_symbol); - sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 2, 0, true); /* was 1,0 13-Aug-22 */ - set_func_is_definer(sc->cutlet_symbol); - sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); - sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); - sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); - sc->openlet_symbol = defun("openlet", openlet, 1, 0, false); - sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); - set_immutable(sc->let_ref_symbol); /* 16-Sep-19 */ - set_immutable_slot(global_slot(sc->let_ref_symbol)); - sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false); - set_immutable(sc->let_set_symbol); - set_immutable_slot(global_slot(sc->let_set_symbol)); - sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback", 16); - sc->let_set_fallback_symbol = make_symbol(sc, "let-set-fallback", 16); /* was let-set!-fallback until 9-Oct-17 */ - - sc->make_iterator_symbol = defun("make-iterator", make_iterator, 1, 1, false); - sc->iterate_symbol = defun("iterate", iterate, 1, 0, false); - sc->iterator_sequence_symbol = defun("iterator-sequence", iterator_sequence, 1, 0, false); - sc->iterator_is_at_end_symbol = defun("iterator-at-end?", iterator_is_at_end, 1, 0, false); - - sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false); - sc->provide_symbol = semisafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */ - set_func_is_definer(sc->provide_symbol); - sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false); - - sc->c_object_type_symbol = defun("c-object-type", c_object_type, 1, 0, false); - sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 4, false); - sc->c_pointer_info_symbol = defun("c-pointer-info", c_pointer_info, 1, 0, false); - sc->c_pointer_type_symbol = defun("c-pointer-type", c_pointer_type, 1, 0, false); - sc->c_pointer_weak1_symbol = defun("c-pointer-weak1", c_pointer_weak1, 1, 0, false); - sc->c_pointer_weak2_symbol = defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false); - sc->c_pointer_to_list_symbol = defun("c-pointer->list", c_pointer_to_list, 1, 0, false); - - sc->port_file_symbol = defun("port-file", port_file, 1, 0, false); - sc->port_position_symbol = defun("port-position", port_position, 1, 0, false); - sc->port_line_number_symbol = defun("port-line-number", port_line_number, 0, 1, false); - sc->port_filename_symbol = defun("port-filename", port_filename, 0, 1, false); - sc->pair_line_number_symbol = defun("pair-line-number", pair_line_number, 1, 0, false); - sc->pair_filename_symbol = defun("pair-filename", pair_filename, 1, 0, false); - sc->is_port_closed_symbol = defun("port-closed?", is_port_closed, 1, 0, false); - - sc->current_input_port_symbol = defun("current-input-port", current_input_port, 0, 0, false); - sc->current_output_port_symbol = defun("current-output-port", current_output_port, 0, 0, false); - sc->current_error_port_symbol = defun("current-error-port", current_error_port, 0, 0, false); - sc->set_current_error_port_symbol = defun("set-current-error-port", set_current_error_port, 1, 0, false); -#if (!WITH_PURE_S7) - sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false); - sc->set_current_input_port_symbol = defun("set-current-input-port", set_current_input_port, 1, 0, false); - sc->set_current_output_port_symbol = defun("set-current-output-port", set_current_output_port, 1, 0, false); - sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */ -#endif - - sc->close_input_port_symbol = defun("close-input-port", close_input_port, 1, 0, false); - sc->close_output_port_symbol = defun("close-output-port", close_output_port, 1, 0, false); - sc->flush_output_port_symbol = defun("flush-output-port", flush_output_port, 0, 1, false); - sc->open_input_file_symbol = defun("open-input-file", open_input_file, 1, 1, false); - sc->open_output_file_symbol = defun("open-output-file", open_output_file, 1, 1, false); - sc->open_input_string_symbol = defun("open-input-string", open_input_string, 1, 0, false); - sc->open_output_string_symbol = defun("open-output-string", open_output_string, 0, 0, false); - sc->get_output_string_symbol = defun("get-output-string", get_output_string, 1, 1, false); - sc->get_output_string_uncopied = s7_make_safe_function(sc, "get-output-string", g_get_output_string_uncopied, 1, 1, false, NULL); - sc->open_input_function_symbol = defun("open-input-function",open_input_function, 1, 0, false); - sc->open_output_function_symbol = defun("open-output-function",open_output_function, 1, 0, false); - - sc->closed_input_function = s7_make_safe_function(sc, "closed-input-function", g_closed_input_function_port, 2, 0, false, "input-function error"), - sc->closed_output_function = s7_make_safe_function(sc, "closed-output-function", g_closed_output_function_port, 1, 0, false, "output-function error"), - - sc->newline_symbol = defun("newline", newline, 0, 1, false); - sc->write_symbol = defun("write", write, 1, 1, false); - sc->display_symbol = defun("display", display, 1, 1, false); - sc->read_char_symbol = defun("read-char", read_char, 0, 1, false); - sc->peek_char_symbol = defun("peek-char", peek_char, 0, 1, false); - sc->write_char_symbol = defun("write-char", write_char, 1, 1, false); - sc->write_string_symbol = defun("write-string", write_string, 1, 3, false); - sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); - sc->write_byte_symbol = defun("write-byte", write_byte, 1, 1, false); - sc->read_line_symbol = defun("read-line", read_line, 0, 2, false); - sc->read_string_symbol = defun("read-string", read_string, 1, 1, false); - sc->read_symbol = semisafe_defun("read", read, 0, 1, false); - /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence - * (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns - * expecting continue (goto top-of-eval-loop), which would be nonsense if arg=fn|x_proc(read) -> fn|x_proc(arg). - * a safe procedure leaves its argument list alone, does not push anything on the stack, - * and leaves sc->code|args unscathed (fx_call assumes that is the case). The stack part can - * be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens) - * then is called with args that use fx*, and the lambda func does the same, the two calls - * can step on each other. - */ - - sc->call_with_input_string_symbol = semisafe_defun("call-with-input-string", call_with_input_string, 2, 0, false); /* body unsafe if func=read */ - sc->call_with_input_file_symbol = semisafe_defun("call-with-input-file", call_with_input_file, 2, 0, false); - sc->with_input_from_string_symbol = semisafe_defun("with-input-from-string", with_input_from_string, 2, 0, false); - sc->with_input_from_file_symbol = semisafe_defun("with-input-from-file", with_input_from_file, 2, 0, false); - - sc->call_with_output_string_symbol = semisafe_defun("call-with-output-string", call_with_output_string, 1, 0, false); - sc->call_with_output_file_symbol = semisafe_defun("call-with-output-file", call_with_output_file, 2, 0, false); - sc->with_output_to_string_symbol = semisafe_defun("with-output-to-string", with_output_to_string, 1, 0, false); - sc->with_output_to_file_symbol = semisafe_defun("with-output-to-file", with_output_to_file, 2, 0, false); - -#if WITH_SYSTEM_EXTRAS - sc->is_directory_symbol = defun("directory?", is_directory, 1, 0, false); - sc->file_exists_symbol = defun("file-exists?", file_exists, 1, 0, false); - sc->delete_file_symbol = defun("delete-file", delete_file, 1, 0, false); - sc->getenv_symbol = defun("getenv", getenv, 1, 0, false); - sc->system_symbol = defun("system", system, 1, 1, false); -#if (!MS_WINDOWS) - sc->directory_to_list_symbol = defun("directory->list", directory_to_list, 1, 0, false); - sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false); -#endif -#endif - - sc->real_part_symbol = defun("real-part", real_part, 1, 0, false); - sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false); - sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); - sc->denominator_symbol = defun("denominator", denominator, 1, 0, false); - sc->is_even_symbol = defun("even?", is_even, 1, 0, false); - sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false); - sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false); - sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false); - sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false); - sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false); - sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false); - sc->complex_symbol = defun("complex", complex, 2, 0, false); - - sc->add_symbol = defun("+", add, 0, 0, true); set_all_integer_and_float(sc->add_symbol); - sc->subtract_symbol = defun("-", subtract, 1, 0, true); set_all_integer_and_float(sc->subtract_symbol); - sc->multiply_symbol = defun("*", multiply, 0, 0, true); set_all_integer_and_float(sc->multiply_symbol); - sc->divide_symbol = defun("/", divide, 1, 0, true); set_all_float(sc->divide_symbol); - sc->min_symbol = defun("min", min, 1, 0, true); set_all_integer_and_float(sc->min_symbol); - sc->max_symbol = defun("max", max, 1, 0, true); set_all_integer_and_float(sc->max_symbol); - - sc->quotient_symbol = defun("quotient", quotient, 2, 0, false); set_all_integer(sc->quotient_symbol); - sc->remainder_symbol = defun("remainder", remainder, 2, 0, false); set_all_integer(sc->remainder_symbol); - sc->modulo_symbol = defun("modulo", modulo, 2, 0, false); set_all_integer(sc->modulo_symbol); - sc->num_eq_symbol = defun("=", num_eq, 2, 0, true); - sc->lt_symbol = defun("<", less, 2, 0, true); - sc->gt_symbol = defun(">", greater, 2, 0, true); - sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true); - sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true); - sc->gcd_symbol = defun("gcd", gcd, 0, 0, true); - sc->lcm_symbol = defun("lcm", lcm, 0, 0, true); - sc->rationalize_symbol = defun("rationalize", rationalize, 1, 1, false); - sc->random_symbol = defun("random", random, 1, 1, false); set_all_integer_and_float(sc->random_symbol); - sc->random_state_symbol = defun("random-state", random_state, 0, (WITH_GMP) ? 1 : 2, false); - sc->expt_symbol = defun("expt", expt, 2, 0, false); - sc->log_symbol = defun("log", log, 1, 1, false); - sc->ash_symbol = defun("ash", ash, 2, 0, false); - sc->exp_symbol = defun("exp", exp, 1, 0, false); set_all_float(sc->exp_symbol); - sc->abs_symbol = defun("abs", abs, 1, 0, false); set_all_integer_and_float(sc->abs_symbol); - sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false); set_all_integer_and_float(sc->magnitude_symbol); - sc->angle_symbol = defun("angle", angle, 1, 0, false); - sc->sin_symbol = defun("sin", sin, 1, 0, false); set_all_float(sc->sin_symbol); - sc->cos_symbol = defun("cos", cos, 1, 0, false); set_all_float(sc->cos_symbol); - sc->tan_symbol = defun("tan", tan, 1, 0, false); set_all_float(sc->tan_symbol); - sc->sinh_symbol = defun("sinh", sinh, 1, 0, false); set_all_float(sc->sinh_symbol); - sc->cosh_symbol = defun("cosh", cosh, 1, 0, false); set_all_float(sc->cosh_symbol); - sc->tanh_symbol = defun("tanh", tanh, 1, 0, false); set_all_float(sc->tanh_symbol); - sc->asin_symbol = defun("asin", asin, 1, 0, false); - sc->acos_symbol = defun("acos", acos, 1, 0, false); - sc->atan_symbol = defun("atan", atan, 1, 1, false); - sc->asinh_symbol = defun("asinh", asinh, 1, 0, false); - sc->acosh_symbol = defun("acosh", acosh, 1, 0, false); - sc->atanh_symbol = defun("atanh", atanh, 1, 0, false); - sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false); - sc->floor_symbol = defun("floor", floor, 1, 0, false); - sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); - sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); - sc->round_symbol = defun("round", round, 1, 0, false); - sc->logand_symbol = defun("logand", logand, 0, 0, true); - sc->logior_symbol = defun("logior", logior, 0, 0, true); - sc->logxor_symbol = defun("logxor", logxor, 0, 0, true); - sc->lognot_symbol = defun("lognot", lognot, 1, 0, false); - sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false); - sc->integer_decode_float_symbol = defun("integer-decode-float", integer_decode_float, 1, 0, false); - sc->nan_symbol = defun("nan", nan, 0, 1, false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */ - sc->nan_payload_symbol = defun("nan-payload", nan_payload, 1, 0, false); - -#if (!WITH_PURE_S7) - sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); - sc->inexact_to_exact_symbol = defun("inexact->exact", inexact_to_exact, 1, 0, false); - sc->exact_to_inexact_symbol = defun("exact->inexact", exact_to_inexact, 1, 0, false); - sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false); - sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false); -#endif - sc->random_state_to_list_symbol = defun("random-state->list", random_state_to_list, 0, 1, false); - sc->number_to_string_symbol = defun("number->string", number_to_string, 1, 1, false); - sc->string_to_number_symbol = defun("string->number", string_to_number, 1, 1, false); - - sc->char_upcase_symbol = defun("char-upcase", char_upcase, 1, 0, false); - sc->char_downcase_symbol = defun("char-downcase", char_downcase, 1, 0, false); - sc->char_to_integer_symbol = defun("char->integer", char_to_integer, 1, 0, false); - sc->integer_to_char_symbol = defun("integer->char", integer_to_char, 1, 0, false); - - sc->is_char_upper_case_symbol = defun("char-upper-case?", is_char_upper_case, 1, 0, false); - sc->is_char_lower_case_symbol = defun("char-lower-case?", is_char_lower_case, 1, 0, false); - sc->is_char_alphabetic_symbol = defun("char-alphabetic?", is_char_alphabetic, 1, 0, false); - sc->is_char_numeric_symbol = defun("char-numeric?", is_char_numeric, 1, 0, false); - sc->is_char_whitespace_symbol = defun("char-whitespace?", is_char_whitespace, 1, 0, false); - - sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true); - sc->char_lt_symbol = defun("charchar_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true); - sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true); - sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true); - sc->char_position_symbol = defun("char-position", char_position, 2, 1, false); - sc->string_position_symbol = defun("string-position", string_position, 2, 1, false); - - sc->make_string_symbol = defun("make-string", make_string, 1, 1, false); - sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false); - sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false); - - sc->string_eq_symbol = defun("string=?", strings_are_equal, 2, 0, true); - sc->string_lt_symbol = defun("stringstring_gt_symbol = defun("string>?", strings_are_greater, 2, 0, true); - sc->string_leq_symbol = defun("string<=?", strings_are_leq, 2, 0, true); - sc->string_geq_symbol = defun("string>=?", strings_are_geq, 2, 0, true); - -#if (!WITH_PURE_S7) - sc->char_ci_eq_symbol = defun("char-ci=?", chars_are_ci_equal, 2, 0, true); - sc->char_ci_lt_symbol = defun("char-cichar_ci_gt_symbol = defun("char-ci>?", chars_are_ci_greater, 2, 0, true); - sc->char_ci_leq_symbol = defun("char-ci<=?", chars_are_ci_leq, 2, 0, true); - sc->char_ci_geq_symbol = defun("char-ci>=?", chars_are_ci_geq, 2, 0, true); - sc->string_ci_eq_symbol = defun("string-ci=?", strings_are_ci_equal, 2, 0, true); - sc->string_ci_lt_symbol = defun("string-cistring_ci_gt_symbol = defun("string-ci>?", strings_are_ci_greater, 2, 0, true); - sc->string_ci_leq_symbol = defun("string-ci<=?", strings_are_ci_leq, 2, 0, true); - sc->string_ci_geq_symbol = defun("string-ci>=?", strings_are_ci_geq, 2, 0, true); - sc->string_fill_symbol = defun("string-fill!", string_fill, 2, 2, false); - sc->list_to_string_symbol = defun("list->string", list_to_string, 1, 0, false); - sc->string_length_symbol = defun("string-length", string_length, 1, 0, false); - sc->string_to_list_symbol = defun("string->list", string_to_list, 1, 2, false); -#endif - sc->string_copy_symbol = defun("string-copy", string_copy, 1, 3, false); - - sc->string_downcase_symbol = defun("string-downcase", string_downcase, 1, 0, false); - sc->string_upcase_symbol = defun("string-upcase", string_upcase, 1, 0, false); - sc->string_append_symbol = defun("string-append", string_append, 0, 0, true); - sc->substring_symbol = defun("substring", substring, 2, 1, false); - sc->string_symbol = defun("string", string, 0, 0, true); - sc->object_to_string_symbol = defun("object->string", object_to_string, 1, 2, false); - sc->format_symbol = defun("format", format, 2, 0, true); - sc->object_to_let_symbol = defun("object->let", object_to_let, 1, 0, false); - - sc->cons_symbol = defun("cons", cons, 2, 0, false); - sc->car_symbol = defun("car", car, 1, 0, false); - sc->cdr_symbol = defun("cdr", cdr, 1, 0, false); - sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false); - sc->set_cdr_symbol = defun("set-cdr!", set_cdr, 2, 0, false); - sc->caar_symbol = defun("caar", caar, 1, 0, false); - sc->cadr_symbol = defun("cadr", cadr, 1, 0, false); - sc->cdar_symbol = defun("cdar", cdar, 1, 0, false); - sc->cddr_symbol = defun("cddr", cddr, 1, 0, false); - sc->caaar_symbol = defun("caaar", caaar, 1, 0, false); - sc->caadr_symbol = defun("caadr", caadr, 1, 0, false); - sc->cadar_symbol = defun("cadar", cadar, 1, 0, false); - sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false); - sc->caddr_symbol = defun("caddr", caddr, 1, 0, false); - sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false); - sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false); - sc->cddar_symbol = defun("cddar", cddar, 1, 0, false); - sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false); - sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false); - sc->caadar_symbol = defun("caadar", caadar, 1, 0, false); - sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false); - sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false); - sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false); - sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false); - sc->caddar_symbol = defun("caddar", caddar, 1, 0, false); - sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false); - sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false); - sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false); - sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false); - sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false); - sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false); - sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false); - sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false); - - sc->assq_symbol = defun("assq", assq, 2, 0, false); - sc->assv_symbol = defun("assv", assv, 2, 0, false); - sc->assoc_symbol = semisafe_defun("assoc", assoc, 2, 1, false); - sc->memq_symbol = defun("memq", memq, 2, 0, false); - sc->memv_symbol = defun("memv", memv, 2, 0, false); - sc->member_symbol = semisafe_defun("member", member, 2, 1, false); - - sc->list_symbol = defun("list", list, 0, 0, true); - sc->list_ref_symbol = defun("list-ref", list_ref, 2, 0, true); - sc->list_set_symbol = defun("list-set!", list_set, 3, 0, true); - sc->list_tail_symbol = defun("list-tail", list_tail, 2, 0, false); - sc->make_list_symbol = defun("make-list", make_list, 1, 1, false); - - sc->length_symbol = defun("length", length, 1, 0, false); - sc->copy_symbol = defun("copy", copy, 1, 3, false); - /* set_is_definer(sc->copy_symbol); */ /* (copy (inlet 'a 1) (curlet)), but this check needs to be smarter */ - sc->fill_symbol = defun("fill!", fill, 2, 2, false); - sc->reverse_symbol = defun("reverse", reverse, 1, 0, false); - sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false); - sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false); /* not semisafe! */ - sc->append_symbol = defun("append", append, 0, 0, true); - sc->qq_append_symbol = defun("[list*]", qq_append, 2, 0, false); - -#if (!WITH_PURE_S7) - sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true); - sc->list_to_vector_symbol = defun("list->vector", list_to_vector, 1, 0, false); - sc->vector_fill_symbol = defun("vector-fill!", vector_fill, 2, 2, false); - sc->vector_length_symbol = defun("vector-length", vector_length, 1, 0, false); - sc->vector_to_list_symbol = defun("vector->list", vector_to_list, 1, 2, false); -#else - sc->vector_append_symbol = sc->append_symbol; - sc->vector_fill_symbol = sc->fill_symbol; - sc->string_fill_symbol = sc->fill_symbol; -#endif - sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); - sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); - sc->vector_dimension_symbol = defun("vector-dimension", vector_dimension, 2, 0, false); - sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false); - sc->vector_rank_symbol = defun("vector-rank", vector_rank, 1, 0, false); - sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false); - sc->vector_symbol = defun("vector", vector, 0, 0, true); - set_is_setter(sc->vector_symbol); /* like cons, I guess */ - sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, false); - - sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); - sc->subvector_position_symbol = defun("subvector-position", subvector_position, 1, 0, false); - sc->subvector_vector_symbol = defun("subvector-vector", subvector_vector, 1, 0, false); - - sc->float_vector_symbol = defun("float-vector", float_vector, 0, 0, true); - sc->make_float_vector_symbol = defun("make-float-vector", make_float_vector, 1, 1, false); - sc->float_vector_set_symbol = defun("float-vector-set!", float_vector_set, 3, 0, true); - sc->float_vector_ref_symbol = defun("float-vector-ref", float_vector_ref, 2, 0, true); - - sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true); - sc->make_int_vector_symbol = defun("make-int-vector", make_int_vector, 1, 1, false); - sc->int_vector_set_symbol = defun("int-vector-set!", int_vector_set, 3, 0, true); - sc->int_vector_ref_symbol = defun("int-vector-ref", int_vector_ref, 2, 0, true); - - sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true); - sc->make_byte_vector_symbol = defun("make-byte-vector", make_byte_vector, 1, 1, false); - sc->byte_vector_ref_symbol = defun("byte-vector-ref", byte_vector_ref, 2, 0, true); - sc->byte_vector_set_symbol = defun("byte-vector-set!", byte_vector_set, 3, 0, true); - sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false); - sc->byte_vector_to_string_symbol = defun("byte-vector->string", byte_vector_to_string, 1, 0, false); - - sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true); - sc->make_hash_table_symbol = defun("make-hash-table", make_hash_table, 0, 3, false); - sc->make_weak_hash_table_symbol = defun("make-weak-hash-table", make_weak_hash_table,0, 3, false); - sc->weak_hash_table_symbol = defun("weak-hash-table", weak_hash_table, 0, 0, true); - sc->hash_table_ref_symbol = defun("hash-table-ref", hash_table_ref, 2, 0, true); - sc->hash_table_set_symbol = defun("hash-table-set!", hash_table_set, 3, 0, false); - sc->hash_table_entries_symbol = defun("hash-table-entries", hash_table_entries, 1, 0, false); - sc->hash_code_symbol = defun("hash-code", hash_code, 1, 1, false); - sc->dummy_equal_hash_table = make_dummy_hash_table(sc); - sc->hash_table_key_typer_symbol = defun("hash-table-key-typer", hash_table_key_typer, 1, 0, false); - sc->hash_table_value_typer_symbol = defun("hash-table-value-typer", hash_table_value_typer, 1, 0, false); - - sc->cyclic_sequences_symbol = defun("cyclic-sequences", cyclic_sequences, 1, 0, false); - sc->call_cc_symbol = semisafe_defun("call/cc", call_cc, 1, 0, false); - sc->call_with_current_continuation_symbol = unsafe_defun("call-with-current-continuation", call_cc, 1, 0, false); - sc->call_with_exit_symbol = semisafe_defun("call-with-exit", call_with_exit, 1, 0, false); - - sc->load_symbol = semisafe_defun("load", load, 1, 1, false); - sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); - sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); - set_func_is_definer(sc->eval_symbol); - sc->eval_string_symbol = semisafe_defun("eval-string", eval_string, 1, 1, false); - set_func_is_definer(sc->eval_string_symbol); - sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); /* not semisafe (note that type is reset below) */ - set_func_is_definer(sc->apply_symbol); - /* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply - * perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof - */ - - sc->for_each_symbol = semisafe_defun("for-each", for_each, 2, 0, true); - sc->map_symbol = semisafe_defun("map", map, 2, 0, true); - sc->dynamic_wind_symbol = semisafe_defun("dynamic-wind", dynamic_wind, 3, 0, false); - sc->dynamic_unwind_symbol = semisafe_defun("dynamic-unwind", dynamic_unwind, 2, 0, false); - sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); - sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); - sc->error_symbol = unsafe_defun("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ - /* not safe in catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */ - sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); - - /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* values_symbol set above for signatures, not semisafe! */ - sc->apply_values_symbol = unsafe_defun("apply-values", apply_values, 0, 1, false); - set_immutable(sc->apply_values_symbol); - set_immutable_slot(global_slot(sc->apply_values_symbol)); - sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); - set_immutable(sc->list_values_symbol); - set_immutable_slot(global_slot(sc->list_values_symbol)); - - sc->documentation_symbol = defun("documentation", documentation, 1, 0, false); - sc->signature_symbol = defun("signature", signature, 1, 0, false); - sc->help_symbol = defun("help", help, 1, 0, false); - sc->procedure_source_symbol = defun("procedure-source", procedure_source, 1, 0, false); - sc->funclet_symbol = defun("funclet", funclet, 1, 0, false); - sc->_function__symbol = defun("*function*", function, 0, 2, false); - sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false); - s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); - sc->arity_symbol = defun("arity", arity, 1, 0, false); - sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); - - sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false); - sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false); - sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false); - sc->is_equivalent_symbol = defun("equivalent?", is_equivalent, 2, 0, false); - sc->type_of_symbol = defun("type-of", type_of, 1, 0, false); - - sc->gc_symbol = semisafe_defun("gc", gc, 0, 1, false); - defun("emergency-exit", emergency_exit, 0, 1, false); - sc->exit_symbol = defun("exit", exit, 0, 1, false); - -#if WITH_GCC - s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope"); -#endif -#if S7_DEBUGGING - defun("heap-scan", heap_scan, 1, 0, false); - defun("heap-analyze", heap_analyze, 0, 0, false); - defun("heap-holder", heap_holder, 1, 0, false); - defun("heap-holders", heap_holders, 1, 0, false); - - defun("show-stack", show_stack, 0, 0, false); - defun("show-op-stack", show_op_stack, 0, 0, false); - defun("op-stack?", is_op_stack, 0, 0, false); -#endif - s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false, "short-term debugging aid"); - sc->c_object_set_function = s7_make_safe_function(sc, "#", g_c_object_set, 1, 0, true, "c-object setter"); - /* c_function_signature(sc->c_object_set_function) = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); */ - - set_scope_safe(global_value(sc->call_with_input_string_symbol)); - set_scope_safe(global_value(sc->call_with_input_file_symbol)); - set_scope_safe(global_value(sc->call_with_output_string_symbol)); - set_scope_safe(global_value(sc->call_with_output_file_symbol)); - set_scope_safe(global_value(sc->with_input_from_string_symbol)); - set_scope_safe(global_value(sc->with_input_from_file_symbol)); - set_scope_safe(global_value(sc->with_output_to_string_symbol)); - set_scope_safe(global_value(sc->with_output_to_file_symbol)); - set_maybe_safe(global_value(sc->assoc_symbol)); - set_scope_safe(global_value(sc->assoc_symbol)); - set_maybe_safe(global_value(sc->member_symbol)); - set_scope_safe(global_value(sc->member_symbol)); - set_scope_safe(global_value(sc->sort_symbol)); - set_scope_safe(global_value(sc->call_with_exit_symbol)); - set_scope_safe(global_value(sc->for_each_symbol)); - set_maybe_safe(global_value(sc->for_each_symbol)); - set_scope_safe(global_value(sc->map_symbol)); - set_maybe_safe(global_value(sc->map_symbol)); - set_scope_safe(global_value(sc->dynamic_wind_symbol)); - set_scope_safe(global_value(sc->catch_symbol)); - set_scope_safe(global_value(sc->throw_symbol)); - set_scope_safe(global_value(sc->error_symbol)); - set_scope_safe(global_value(sc->apply_values_symbol)); - - sc->tree_leaves_symbol = defun("tree-leaves", tree_leaves, 1, 0, false); - sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false); - sc->tree_set_memq_symbol = defun("tree-set-memq", tree_set_memq, 2, 0, false); - sc->tree_count_symbol = defun("tree-count", tree_count, 2, 1, false); - sc->tree_is_cyclic_symbol = defun("tree-cyclic?", tree_is_cyclic, 1, 0, false); - - sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); /* is this considered syntax? r7rs says yes; also unquote */ - sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 0, false); /* calls dynamic-unwind */ - sc->profile_out = NULL; - - /* -------- *features* -------- */ - sc->features_symbol = s7_define_variable_with_documentation(sc, "*features*", sc->nil, "list of currently available features ('complex-numbers, etc)"); - s7_set_setter(sc, sc->features_symbol, s7_make_safe_function(sc, "#", g_features_set, 2, 0, false, "*features* setter")); - - /* -------- *load-path* -------- */ - sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", list_1(sc, make_string_with_length(sc, ".", 1)), /* not plist! */ - "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name"); - s7_set_setter(sc, sc->load_path_symbol, s7_make_safe_function(sc, "#", g_load_path_set, 2, 0, false, "*load-path* setter")); - -#ifdef CLOAD_DIR - sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", s7_make_string(sc, (char *)CLOAD_DIR)); - s7_add_to_load_path(sc, (const char *)CLOAD_DIR); -#else - sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", nil_string); -#endif - s7_set_setter(sc, sc->cload_directory_symbol, - s7_make_safe_function(sc, "#", g_cload_directory_set, 2, 0, false, "*cload-directory* setter")); - - /* -------- *autoload* -------- this pretends to be a hash-table or environment, but it's actually a function */ - sc->autoloader_symbol = s7_define_typed_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader, Q_autoloader); - c_function_set_setter(global_value(sc->autoloader_symbol), global_value(sc->autoload_symbol)); /* (set! (*autoload* x) y) */ - - sc->libraries_symbol = s7_define_variable_with_documentation(sc, "*libraries*", sc->nil, "list of currently loaded libraries (libc.scm, etc)"); - s7_set_setter(sc, sc->libraries_symbol, s7_make_safe_function(sc, "#", g_libraries_set, 2, 0, false, "*libraries* setter")); - - s7_autoload(sc, make_symbol(sc, "cload.scm", 9), s7_make_semipermanent_string(sc, "cload.scm")); - s7_autoload(sc, make_symbol(sc, "lint.scm", 8), s7_make_semipermanent_string(sc, "lint.scm")); - s7_autoload(sc, make_symbol(sc, "stuff.scm", 9), s7_make_semipermanent_string(sc, "stuff.scm")); - s7_autoload(sc, make_symbol(sc, "mockery.scm", 11), s7_make_semipermanent_string(sc, "mockery.scm")); - s7_autoload(sc, make_symbol(sc, "write.scm", 9), s7_make_semipermanent_string(sc, "write.scm")); - s7_autoload(sc, make_symbol(sc, "reactive.scm", 12), s7_make_semipermanent_string(sc, "reactive.scm")); - s7_autoload(sc, make_symbol(sc, "repl.scm", 8), s7_make_semipermanent_string(sc, "repl.scm")); - s7_autoload(sc, make_symbol(sc, "r7rs.scm", 8), s7_make_semipermanent_string(sc, "r7rs.scm")); - s7_autoload(sc, make_symbol(sc, "profile.scm", 11), s7_make_semipermanent_string(sc, "profile.scm")); - s7_autoload(sc, make_symbol(sc, "debug.scm", 9), s7_make_semipermanent_string(sc, "debug.scm")); - s7_autoload(sc, make_symbol(sc, "case.scm", 8), s7_make_semipermanent_string(sc, "case.scm")); - - s7_autoload(sc, make_symbol(sc, "libc.scm", 8), s7_make_semipermanent_string(sc, "libc.scm")); - s7_autoload(sc, make_symbol(sc, "libm.scm", 8), s7_make_semipermanent_string(sc, "libm.scm")); /* repl.scm adds *libm* */ - s7_autoload(sc, make_symbol(sc, "libdl.scm", 9), s7_make_semipermanent_string(sc, "libdl.scm")); - s7_autoload(sc, make_symbol(sc, "libgsl.scm", 10), s7_make_semipermanent_string(sc, "libgsl.scm")); /* repl.scm adds *libgsl* */ - s7_autoload(sc, make_symbol(sc, "libgdbm.scm", 11), s7_make_semipermanent_string(sc, "libgdbm.scm")); - s7_autoload(sc, make_symbol(sc, "libutf8proc.scm", 15), s7_make_semipermanent_string(sc, "libutf8proc.scm")); - - sc->require_symbol = s7_define_macro(sc, "require", g_require, 1, 0, true, H_require); - sc->stacktrace_defaults = s7_list(sc, 5, int_three, small_int(45), small_int(80), small_int(45), sc->T); /* assume NUM_SMALL_INTS >= NUM_CHARS == 256 */ - - /* -------- *#readers* -------- */ - sym = s7_define_variable_with_documentation(sc, "*#readers*", sc->nil, "list of current reader macros"); - sc->sharp_readers = global_slot(sym); - s7_set_setter(sc, sym, s7_make_safe_function(sc, "#", g_sharp_readers_set, 2, 0, false, "*#readers* setter")); - - sc->local_documentation_symbol = make_symbol(sc, "+documentation+", 15); - sc->local_signature_symbol = make_symbol(sc, "+signature+", 11); - sc->local_setter_symbol = make_symbol(sc, "+setter+", 8); - sc->local_iterator_symbol = make_symbol(sc, "+iterator+", 10); - - init_features(sc); - init_setters(sc); -} - -#if (!MS_WINDOWS) -static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER; -#endif - -s7_scheme *s7_init(void) -{ - int32_t i; - s7_scheme *sc; - static bool already_inited = false; - -#if (!MS_WINDOWS) - setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */ - pthread_mutex_lock(&init_lock); -#endif - - if (!already_inited) - { - init_types(); - init_ctables(); - init_mark_functions(); - init_display_functions(); - init_length_functions(); - init_equals(); - init_hash_maps(); - init_pows(); - init_int_limits(); - init_small_ints(); - init_uppers(); - init_chars(); - init_strings(); - init_fx_function(); - init_catchers(); - init_s7_starlet_immutable_field(); - already_inited = true; - } - -#if (!MS_WINDOWS) - pthread_mutex_unlock(&init_lock); -#endif - sc = (s7_scheme *)Calloc(1, sizeof(s7_scheme)); /* not malloc! */ -#if S7_DEBUGGING || POINTER_32 || WITH_WARNINGS - cur_sc = sc; /* for gdb/debugging */ -#endif - sc->gc_off = true; /* sc->args and so on are not set yet, so a gc during init -> segfault */ - sc->gc_in_progress = false; - sc->gc_stats = 0; - - sc->saved_pointers = (void **)Malloc(INITIAL_SAVED_POINTERS_SIZE * sizeof(void *)); - sc->saved_pointers_loc = 0; - sc->saved_pointers_size = INITIAL_SAVED_POINTERS_SIZE; - - init_gc_caches(sc); - sc->semipermanent_cells = 0; - sc->alloc_pointer_k = ALLOC_POINTER_SIZE; - sc->alloc_pointer_cells = NULL; - sc->alloc_big_pointer_k = ALLOC_BIG_POINTER_SIZE; - sc->alloc_big_pointer_cells = NULL; - sc->alloc_function_k = ALLOC_FUNCTION_SIZE; - sc->alloc_function_cells = NULL; - sc->alloc_symbol_k = ALLOC_SYMBOL_SIZE; - sc->alloc_symbol_cells = NULL; - sc->num_to_str_size = -1; - sc->num_to_str = NULL; - init_block_lists(sc); - sc->alloc_string_k = ALLOC_STRING_SIZE; - sc->alloc_string_cells = NULL; - sc->alloc_opt_func_cells = NULL; - sc->alloc_opt_func_k = ALLOC_FUNCTION_SIZE; - sc->longjmp_ok = false; - sc->setjmp_loc = NO_SET_JUMP; - sc->max_vector_length = (1LL << 32); - sc->max_string_length = 1073741824; /* 1 << 30 */ - sc->max_format_length = 10000; - sc->max_list_length = 1073741824; - sc->max_vector_dimensions = 512; - sc->strbuf_size = INITIAL_STRBUF_SIZE; - sc->strbuf = (char *)Calloc(sc->strbuf_size, 1); - sc->print_width = sc->max_string_length; - sc->short_print = false; - sc->in_with_let = false; - sc->object_out_locked = false; - sc->has_openlets = true; - sc->is_expanding = true; - sc->accept_all_keyword_arguments = false; - sc->muffle_warnings = false; - sc->initial_string_port_length = 128; - sc->format_depth = -1; - sc->singletons = (s7_pointer *)Calloc(256, sizeof(s7_pointer)); - add_saved_pointer(sc, sc->singletons); - sc->read_line_buf = NULL; - sc->read_line_buf_size = 0; - sc->stop_at_error = true; - - sc->nil = make_unique(sc, "()", T_NIL); - sc->unused = make_unique(sc, "#", T_UNUSED); - sc->T = make_unique(sc, "#t", T_BOOLEAN); - sc->F = make_unique(sc, "#f", T_BOOLEAN); - sc->undefined = make_unique(sc, "#", T_UNDEFINED); - sc->unspecified = make_unique(sc, "#", T_UNSPECIFIED); - sc->no_value = make_unique(sc, "#", T_UNSPECIFIED); - - unique_car(sc->nil) = sc->unspecified; - unique_cdr(sc->nil) = sc->unspecified; - /* this is mixing two different s7_cell structs, cons and envr, but luckily envr has two initial s7_pointer fields, equivalent to car and cdr, so - * let_id which is the same as opt1 is unaffected. To get the names built-in, I'll append unique_name and unique_name_length fields to the envr struct. - */ - let_set_id(sc->nil, -1); - unique_cdr(sc->unspecified) = sc->unspecified; - - sc->t1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t2_2 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t2_1 = semipermanent_cons(sc, sc->unused, sc->t2_2, T_PAIR | T_IMMUTABLE); - sc->t3_3 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t3_2 = semipermanent_cons(sc, sc->unused, sc->t3_3, T_PAIR | T_IMMUTABLE); - sc->t3_1 = semipermanent_cons(sc, sc->unused, sc->t3_2, T_PAIR | T_IMMUTABLE); - sc->t4_1 = semipermanent_cons(sc, sc->unused, sc->t3_1, T_PAIR | T_IMMUTABLE); - sc->u1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); /* ulist */ - - sc->safe_lists[0] = sc->nil; - for (i = 1; i < NUM_SAFE_PRELISTS; i++) - sc->safe_lists[i] = semipermanent_list(sc, i); - for (i = NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++) - sc->safe_lists[i] = sc->nil; - sc->current_safe_list = 0; - - sc->input_port_stack_size = INPUT_PORT_STACK_INITIAL_SIZE; - sc->input_port_stack = (s7_pointer *)Malloc(sc->input_port_stack_size * sizeof(s7_pointer)); - sc->input_port_stack_loc = 0; - - sc->code = sc->nil; -#if WITH_HISTORY - sc->eval_history1 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); - sc->eval_history2 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); - sc->history_pairs = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); - sc->history_sink = semipermanent_list(sc, 1); - cdr(sc->history_sink) = sc->history_sink; - { - s7_pointer p1, p2, p3; - for (p3 = sc->history_pairs; is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); - set_car(p3, semipermanent_list(sc, 1)); - set_cdr(p3, sc->history_pairs); - for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); - set_cdr(p1, sc->eval_history1); - set_cdr(p2, sc->eval_history2); - sc->cur_code = sc->eval_history1; - sc->using_history1 = true; - sc->old_cur_code = sc->cur_code; - } -#else - sc->cur_code = sc->F; -#endif - sc->args = sc->nil; - sc->value = sc->nil; - sc->w = sc->unused; - sc->x = sc->unused; - sc->y = sc->unused; - sc->z = sc->unused; - sc->temp1 = sc->unused; - sc->temp2 = sc->unused; - sc->temp3 = sc->unused; - sc->temp4 = sc->unused; - sc->temp5 = sc->unused; - sc->temp7 = sc->unused; - sc->temp8 = sc->unused; - sc->temp9 = sc->unused; - sc->temp10 = sc->unused; - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - - sc->begin_hook = NULL; - sc->autoload_table = sc->nil; - sc->autoload_names = NULL; - sc->autoload_names_sizes = NULL; - sc->autoloaded_already = NULL; - sc->autoload_names_loc = 0; -#if DISABLE_AUTOLOAD - sc->is_autoloading = false; -#else - sc->is_autoloading = true; -#endif - sc->rec_stack = NULL; - - sc->heap_size = INITIAL_HEAP_SIZE; - if ((sc->heap_size % 32) != 0) - sc->heap_size = 32 * (int64_t)ceil((double)(sc->heap_size) / 32.0); - sc->heap = (s7_pointer *)Malloc(sc->heap_size * sizeof(s7_pointer)); - sc->free_heap = (s7_cell **)Malloc(sc->heap_size * sizeof(s7_cell *)); - sc->free_heap_top = (s7_cell **)(sc->free_heap + INITIAL_HEAP_SIZE); - sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE); - sc->previous_free_heap_top = sc->free_heap_top; - { - s7_cell *cells = (s7_cell *)Malloc(INITIAL_HEAP_SIZE * sizeof(s7_cell)); /* was calloc 14-Apr-22 */ - add_saved_pointer(sc, (void *)cells); - for (i = 0; i < INITIAL_HEAP_SIZE; i++) /* LOOP_4 here is slower! */ - { - sc->heap[i] = &cells[i]; - sc->free_heap[i] = sc->heap[i]; -#if S7_DEBUGGING - sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; -#endif - clear_type(sc->heap[i]); - i++; - sc->heap[i] = &cells[i]; - sc->free_heap[i] = sc->heap[i]; -#if S7_DEBUGGING - sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; -#endif - clear_type(sc->heap[i]); - } - sc->heap_blocks = (heap_block_t *)Malloc(sizeof(heap_block_t)); - sc->heap_blocks->start = (intptr_t)cells; - sc->heap_blocks->end = (intptr_t)cells + (sc->heap_size * sizeof(s7_cell)); - sc->heap_blocks->offset = 0; - sc->heap_blocks->next = NULL; - } - sc->gc_temps_size = GC_TEMPS_SIZE; - sc->gc_resize_heap_fraction = GC_RESIZE_HEAP_FRACTION; - sc->gc_resize_heap_by_4_fraction = GC_RESIZE_HEAP_BY_4_FRACTION; - sc->max_heap_size = (1LL << 62); - sc->gc_calls = 0; - sc->gc_total_time = 0; - - sc->max_port_data_size = (1LL << 62); -#ifndef OUTPUT_PORT_DATA_SIZE - #define OUTPUT_PORT_DATA_SIZE 2048 -#endif - sc->output_port_data_size = OUTPUT_PORT_DATA_SIZE; - - /* this has to precede s7_make_* allocations */ - sc->protected_setters_size = INITIAL_PROTECTED_OBJECTS_SIZE; - sc->protected_setters_loc = 0; - sc->protected_setters = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR); - sc->protected_setter_symbols = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR); - - sc->protected_objects_size = INITIAL_PROTECTED_OBJECTS_SIZE; - sc->protected_objects_free_list = (s7_int *)Malloc(INITIAL_PROTECTED_OBJECTS_SIZE * sizeof(s7_int)); - sc->protected_objects_free_list_loc = INITIAL_PROTECTED_OBJECTS_SIZE - 1; - sc->protected_objects = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR); - for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++) /* using # as the not-set indicator here lets that value leak out! */ - { - vector_element(sc->protected_objects, i) = sc->unused; - vector_element(sc->protected_setters, i) = sc->unused; - vector_element(sc->protected_setter_symbols, i) = sc->unused; - sc->protected_objects_free_list[i] = i; - } - - sc->stack = make_vector_1(sc, INITIAL_STACK_SIZE, FILLED, T_VECTOR); - /* if not_filled, segfault in gc_mark in mark_stack_1 after size check? probably unfilled OP_BARRIER etc? */ - sc->stack_start = vector_elements(sc->stack); /* stack type set below */ - sc->stack_end = sc->stack_start; - sc->stack_size = INITIAL_STACK_SIZE; - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (INITIAL_STACK_SIZE - STACK_RESIZE_TRIGGER)); - set_full_type(sc->stack, T_STACK); - sc->max_stack_size = (1 << 30); - stack_clear_flags(sc->stack); - initialize_op_stack(sc); - - /* keep the symbol table out of the heap */ - sc->symbol_table = (s7_pointer)Malloc(sizeof(s7_cell)); /* was calloc 14-Apr-22 */ - full_type(sc->symbol_table) = T_VECTOR | T_UNHEAP; - vector_length(sc->symbol_table) = SYMBOL_TABLE_SIZE; - vector_elements(sc->symbol_table) = (s7_pointer *)Malloc(SYMBOL_TABLE_SIZE * sizeof(s7_pointer)); - vector_getter(sc->symbol_table) = normal_vector_getter; - vector_setter(sc->symbol_table) = normal_vector_setter; - normal_vector_fill(sc->symbol_table, sc->nil); - - { /* sc->opts */ - opt_info *os = (opt_info *)Malloc(OPTS_SIZE * sizeof(opt_info)); /* was calloc, 17-Oct-21 */ - add_saved_pointer(sc, os); - for (i = 0; i < OPTS_SIZE; i++) - { - opt_info *o = &os[i]; - sc->opts[i] = o; - o->sc = sc; - }} - - for (i = 0; i < NUM_TYPES; i++) - sc->type_names[i] = s7_make_semipermanent_string(sc, (const char *)type_name_from_type(i, INDEFINITE_ARTICLE)); - -#if WITH_MULTITHREAD_CHECKS - sc->lock_count = 0; - { - pthread_mutexattr_t attr; - pthread_mutexattr_init(&attr); - pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); - pthread_mutex_init(&sc->lock, &attr); - } -#endif - - sc->c_object_types = NULL; - sc->c_object_types_size = 0; - sc->num_c_object_types = 0; - sc->typnam = NULL; - sc->typnam_len = 0; - sc->default_rationalize_error = 1.0e-12; - sc->hash_table_float_epsilon = 1.0e-12; - sc->equivalent_float_epsilon = 1.0e-15; - sc->float_format_precision = WRITE_REAL_PRECISION; - sc->number_separator = '\0'; - sc->default_hash_table_length = 8; - sc->gensym_counter = 0; - sc->capture_let_counter = 0; - sc->continuation_counter = 0; - sc->f_class = 0; - sc->add_class = 0; - sc->num_eq_class = 0; - sc->let_number = 0; - sc->format_column = 0; - sc->format_ports = NULL; - sc->file_names = NULL; - sc->file_names_size = 0; - sc->file_names_top = -1; - sc->s7_call_line = 0; - sc->s7_call_file = NULL; - sc->s7_call_name = NULL; - sc->safety = NO_SAFETY; - sc->debug = 0; - sc->profile = 0; - sc->profile_position = 0; - sc->debug_or_profile = false; - sc->profiling_gensyms = false; - sc->profile_data = NULL; - sc->profile_prefix = sc->F; - sc->print_length = DEFAULT_PRINT_LENGTH; - sc->history_size = DEFAULT_HISTORY_SIZE; - sc->true_history_size = DEFAULT_HISTORY_SIZE; - sc->baffle_ctr = 0; - sc->map_call_ctr = 0; - sc->syms_tag = 0; - sc->syms_tag2 = 0; - sc->class_name_symbol = make_symbol(sc, "class-name", 10); - sc->name_symbol = make_symbol(sc, "name", 4); - sc->trace_in_symbol = make_symbol(sc, "trace-in", 8); - sc->size_symbol = make_symbol(sc, "size", 4); - sc->mutable_symbol = make_symbol(sc, "mutable?", 8); - sc->file__symbol = make_symbol(sc, "FILE*", 5); - sc->circle_info = init_circle_info(sc); - sc->fdats = (format_data_t **)Calloc(8, sizeof(format_data_t *)); - sc->num_fdats = 8; - sc->mlist_1 = semipermanent_list(sc, 1); - sc->mlist_2 = semipermanent_list(sc, 2); - sc->plist_1 = semipermanent_list(sc, 1); - sc->plist_2 = semipermanent_list(sc, 2); - sc->plist_2_2 = cdr(sc->plist_2); - sc->plist_3 = semipermanent_list(sc, 3); - sc->qlist_2 = semipermanent_list(sc, 2); - sc->qlist_3 = semipermanent_cons(sc, sc->unused, sc->qlist_2, T_PAIR | T_IMMUTABLE); - sc->clist_1 = semipermanent_list(sc, 1); - sc->clist_2 = semipermanent_list(sc, 2); - sc->dlist_1 = semipermanent_list(sc, 1); - sc->elist_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_2 = semipermanent_list(sc, 2); set_is_elist(sc->elist_2); - sc->elist_3 = semipermanent_list(sc, 3); set_is_elist(sc->elist_3); - sc->elist_4 = semipermanent_cons(sc, sc->unused, sc->elist_3, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_5 = semipermanent_cons(sc, sc->unused, sc->elist_4, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_6 = semipermanent_cons(sc, sc->unused, sc->elist_5, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_7 = semipermanent_cons(sc, sc->unused, sc->elist_6, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->undefined_identifier_warnings = false; - sc->undefined_constant_warnings = false; - sc->wrap_only = make_wrap_only(sc); - sc->unentry = (hash_entry_t *)Malloc(sizeof(hash_entry_t)); - hash_entry_set_value(sc->unentry, sc->F); - sc->begin_op = OP_BEGIN_NO_HOOK; - /* we used to laboriously set various other fields to null, but the calloc takes care of that */ - sc->tree_pointers = NULL; - sc->tree_pointers_size = 0; - sc->tree_pointers_top = 0; - - sc->rootlet = make_vector_1(sc, INITIAL_ROOTLET_SIZE, FILLED, T_VECTOR); - set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE); - sc->rootlet_entries = 0; - for (i = 0; i < INITIAL_ROOTLET_SIZE; i++) rootlet_element(sc->rootlet, i) = sc->nil; - sc->curlet = sc->nil; - sc->shadow_rootlet = sc->nil; - sc->objstr_max_len = S7_INT64_MAX; - - init_wrappers(sc); - init_standard_ports(sc); - init_rootlet(sc); - init_open_input_function_choices(sc); - - { - s7_pointer p; - new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */ - sc->default_random_state = p; - - sc->bignum_precision = DEFAULT_BIGNUM_PRECISION; -#if WITH_GMP - sc->bigints = NULL; - sc->bigrats = NULL; - sc->bigflts = NULL; - sc->bigcmps = NULL; - - mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION); - mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION); - - mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); - mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); - mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); - mpc_init(sc->mpc_1); - mpc_init(sc->mpc_2); - - mpz_set_ui(sc->mpz_1, (uint64_t)my_clock()); - gmp_randinit_default(random_gmp_state(p)); - gmp_randseed(random_gmp_state(p), sc->mpz_1); - - sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); - set_initial_slot(sc->pi_symbol, make_semipermanent_slot(sc, sc->pi_symbol, big_pi(sc))); /* s7_make_slot does not handle this */ - s7_provide(sc, "gmp"); -#else - random_seed(p) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ - random_carry(p) = 1675393560; - sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); -#endif - } - for (i = 0; i < 10; i++) sc->singletons[(uint8_t)'0' + i] = small_int(i); - sc->singletons[(uint8_t)'+'] = sc->add_symbol; - sc->singletons[(uint8_t)'-'] = sc->subtract_symbol; - sc->singletons[(uint8_t)'*'] = sc->multiply_symbol; - sc->singletons[(uint8_t)'/'] = sc->divide_symbol; - sc->singletons[(uint8_t)'<'] = sc->lt_symbol; - sc->singletons[(uint8_t)'>'] = sc->gt_symbol; - sc->singletons[(uint8_t)'='] = sc->num_eq_symbol; - - init_choosers(sc); - init_typers(sc); - init_opt_functions(sc); - s7_set_history_enabled(sc, false); -#if S7_DEBUGGING - init_tc_rec(sc); -#endif - - init_unlet(sc); - init_signatures(sc); /* depends on procedure symbols */ - sc->s7_starlet = make_s7_starlet(sc); - s7_set_history_enabled(sc, true); - -#if (!WITH_PURE_S7) - s7_define_variable(sc, "make-rectangular", global_value(sc->complex_symbol)); - s7_eval_c_string(sc, "(define make-polar \n\ - (let ((+signature+ '(number? real? real?))) \n\ - (lambda (mag ang) \n\ - (if (and (real? mag) (real? ang)) \n\ - (complex (* mag (cos ang)) (* mag (sin ang))) \n\ - (error 'wrong-type-arg \"make-polar arguments should be real\")))))"); - - s7_eval_c_string(sc, "(define (call-with-values producer consumer) (apply consumer (list (producer))))"); - /* (consumer (producer)) will work in any "normal" context. If consumer is syntax and then subsequently not syntax, there is confusion */ - - s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) \n\ - (list (cons 'lambda (cons vars body)) expression))"); - - s7_eval_c_string(sc, "(define-macro (cond-expand . clauses) \n\ - (letrec ((traverse (lambda (tree) \n\ - (if (pair? tree) \n\ - (cons (traverse (car tree)) \n\ - (case (cdr tree) ((())) (else => traverse))) \n\ - (if (memq tree '(and or not else)) tree \n\ - (and (symbol? tree) (provided? tree))))))) \n\ - (cons 'cond (map (lambda (clause) \n\ - (if (pair? clause) \n\ - (cons (traverse (car clause)) \n\ - (case (cdr clause) ((()) '(#f)) (else))) \n\ - (error 'read-error \"cond-expand: bad clause\"))) \n\ - clauses))))"); -#endif - - s7_eval_c_string(sc, "(define-expansion (reader-cond . clauses) \n\ - (call-with-exit \n\ - (lambda (return) \n\ - (for-each \n\ - (lambda (clause) \n\ - (let ((val (eval (car clause)))) \n\ - (when val \n\ - (return \n\ - (cond ((null? (cdr clause)) val) \n\ - ((eq? (cadr clause) '=>) ((eval (caddr clause)) val)) \n\ - ((null? (cddr clause)) (cadr clause)) \n\ - (else (apply values (map quote (cdr clause))))))))) \n\ - clauses) \n\ - (values))))"); /* this is not redundant */ /* map above ignores trailing cdr if improper */ - - s7_eval_c_string(sc, "(define make-hook \n\ - (let ((+documentation+ \"(make-hook . pars) returns a new hook (a function) that passes the parameters to its function list.\")) \n\ - (lambda hook-args \n\ - (let ((body ())) \n\ - (apply lambda* hook-args \n\ - `((let ((result #)) \n\ - (let ((hook (openlet (sublet (curlet) 'let-ref-fallback (lambda (e sym) #))))) \n\ - (for-each (lambda (hook-function) (hook-function hook)) body) \n\ - result))))))))"); - /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result #)) ... result)), see stuff.scm for commentary */ - - s7_eval_c_string(sc, "(define hook-functions \n\ - (let ((+signature+ '(#t procedure?)) \n\ - (+documentation+ \"(hook-functions hook) gets or sets the list of functions associated with the hook\")) \n\ - (dilambda \n\ - (lambda (hook) \n\ - (when (or (not (procedure? hook)) (continuation? hook) (goto? hook)) \n\ - (error 'wrong-type-arg \"hook-functions hook must be a procedure created by make-hook: ~S\" hook)) \n\ - ((funclet hook) 'body)) \n\ - (lambda (hook lst) \n\ - (when (or (not (procedure? hook)) (continuation? hook) (goto? hook)) \n\ - (error 'wrong-type-arg \"hook-functions hook must be a procedure created by make-hook: ~S\" hook)) \n\ - (if (do ((p lst (cdr p))) \n\ - ((not (and (pair? p) \n\ - (procedure? (car p)) \n\ - (aritable? (car p) 1))) \n\ - (null? p))) \n\ - (set! ((funclet hook) 'body) lst) \n\ - (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst))))))"); - - /* -------- *unbound-variable-hook* -------- */ - sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)"); - s7_define_constant_with_documentation(sc, "*unbound-variable-hook*", sc->unbound_variable_hook, - "*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable)."); - - /* -------- *missing-close-paren-hook* -------- */ - sc->missing_close_paren_hook = s7_eval_c_string(sc, "(make-hook)"); - s7_define_constant_with_documentation(sc, "*missing-close-paren-hook*", sc->missing_close_paren_hook, - "*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing"); - - /* -------- *load-hook* -------- */ - sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)"); - s7_define_constant_with_documentation(sc, "*load-hook*", sc->load_hook, - "*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)"); - - /* -------- *autoload-hook* -------- */ - sc->autoload_hook = s7_eval_c_string(sc, "(make-hook 'name 'file)"); - s7_define_constant_with_documentation(sc, "*autoload-hook*", sc->autoload_hook, - "*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))"); - - /* -------- *error-hook* -------- */ - sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); - s7_define_constant_with_documentation(sc, "*error-hook*", sc->error_hook, - "*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data)."); - - /* -------- *read-error-hook* -------- */ - sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); - s7_define_constant_with_documentation(sc, "*read-error-hook*", sc->read_error_hook, - "*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data)."); - - /* -------- *rootlet-redefinition-hook* -------- */ - sc->rootlet_redefinition_hook = s7_eval_c_string(sc, "(make-hook 'name 'value)"); - s7_define_constant_with_documentation(sc, "*rootlet-redefinition-hook*", sc->rootlet_redefinition_hook, - "*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value)."); - - sc->let_temp_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); - -#if S7_DEBUGGING - s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, 0, false, NULL); - if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ - if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) - fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); - if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) - fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); - if (NUM_OPS != 924) - fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); - /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */ -#endif - - return(sc); -} - - -/* -------------------------------- s7_free -------------------------------- */ -static void gc_list_free(gc_list_t *g) -{ - free(g->list); - free(g); -} - -void s7_free(s7_scheme *sc) -{ - /* free the memory associated with sc - * most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly - * valgrind --leak-check=full --show-reachable=yes --suppressions=/home/bil/cl/free.supp repl s7test.scm - * valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm - */ - s7_int i; - gc_list_t *gp; - - /* g_gc(sc, sc->nil); */ /* probably not needed (my simple tests work fine if the gc call is omitted) */ /* removed 14-Apr-22 */ - /* s7_quit(sc); */ /* not always needed -- will clean up the C stack if we haven't returned to the top level */ - - gp = sc->c_objects; /* do this first since they might involve gc_unprotect etc */ - for (i = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (c_object_gc_free(sc, s1)) - (*(c_object_gc_free(sc, s1)))(sc, s1); - else (*(c_object_free(sc, s1)))(c_object_value(s1)); - } - gc_list_free(gp); - - gp = sc->vectors; - for (i = 0; i < gp->loc; i++) - if (block_index(unchecked_vector_block(gp->list[i])) == TOP_BLOCK_LIST) - free(block_data(unchecked_vector_block(gp->list[i]))); - gc_list_free(gp); - gc_list_free(sc->multivectors); /* I assume vector_dimension_info won't need 131072 bytes */ - - gp = sc->strings; - for (i = 0; i < gp->loc; i++) - if (block_index(unchecked_string_block(gp->list[i])) == TOP_BLOCK_LIST) - free(block_data(unchecked_string_block(gp->list[i]))); - gc_list_free(gp); - - gp = sc->output_ports; - for (i = 0; i < gp->loc; i++) - { - if ((unchecked_port_data_block(gp->list[i])) && - (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) - free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ - if ((is_file_port(gp->list[i])) && - (!port_is_closed(gp->list[i]))) - fclose(port_file(gp->list[i])); - } - gc_list_free(gp); - - gp = sc->input_ports; - for (i = 0; i < gp->loc; i++) - if ((unchecked_port_data_block(gp->list[i])) && - (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) - free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ - gc_list_free(gp); - gc_list_free(sc->input_string_ports); /* port_data_block is null, port_block is the const char* data, so I assume it is handled elsewhere */ - - gp = sc->hash_tables; - for (i = 0; i < gp->loc; i++) - if (block_index(unchecked_hash_table_block(gp->list[i])) == TOP_BLOCK_LIST) - free(block_data(unchecked_hash_table_block(gp->list[i]))); - gc_list_free(gp); - -#if WITH_GMP - /* free lists */ - {bigint *p, *np; for (p = sc->bigints; p; p = np) {mpz_clear(p->n); np = p->nxt; free(p);}} - {bigrat *p, *np; for (p = sc->bigrats; p; p = np) {mpq_clear(p->q); np = p->nxt; free(p);}} - {bigflt *p, *np; for (p = sc->bigflts; p; p = np) {mpfr_clear(p->x); np = p->nxt; free(p);}} - {bigcmp *p, *np; for (p = sc->bigcmps; p; p = np) {mpc_clear(p->z); np = p->nxt; free(p);}} - - gp = sc->big_integers; - for (i = 0; i < gp->loc; i++) {bigint *p; p = big_integer_bgi(gp->list[i]); mpz_clear(p->n); free(p);} - gc_list_free(gp); - - gp = sc->big_ratios; - for (i = 0; i < gp->loc; i++) {bigrat *p; p = big_ratio_bgr(gp->list[i]); mpq_clear(p->q); free(p);} - gc_list_free(gp); - - gp = sc->big_reals; - for (i = 0; i < gp->loc; i++) {bigflt *p; p = big_real_bgf(gp->list[i]); mpfr_clear(p->x); free(p);} - gc_list_free(gp); - - gp = sc->big_complexes; - for (i = 0; i < gp->loc; i++) {bigcmp *p; p = big_complex_bgc(gp->list[i]); mpc_clear(p->z); free(p);} - gc_list_free(gp); - - gp = sc->big_random_states; - for (i = 0; i < gp->loc; i++) gmp_randclear(random_gmp_state(gp->list[i])); - gc_list_free(gp); - - gmp_randclear(random_gmp_state(sc->default_random_state)); - - /* temps */ - if (sc->ratloc) free_rat_locals(sc); - mpz_clears(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); - mpq_clears(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); - mpfr_clears(sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); - mpc_clear(sc->mpc_1); - mpc_clear(sc->mpc_2); - /* I claim the leftovers (864 bytes, all from mpfr_cosh) are gmp's fault */ -#endif - - free(undefined_name(sc->undefined)); - gp = sc->undefineds; - for (i = 0; i < gp->loc; i++) - free(undefined_name(gp->list[i])); - gc_list_free(gp); - - gc_list_free(sc->gensyms); - gc_list_free(sc->continuations); /* stack is simple vector (handled above) */ - gc_list_free(sc->weak_refs); - gc_list_free(sc->weak_hash_iterators); - gc_list_free(sc->opt1_funcs); - - free(port_port(sc->standard_output)); - free(port_port(sc->standard_error)); - free(port_port(sc->standard_input)); - - if (sc->autoload_names) free(sc->autoload_names); - if (sc->autoload_names_sizes) free(sc->autoload_names_sizes); - if (sc->autoloaded_already) free(sc->autoloaded_already); - - for (block_t *top = sc->block_lists[TOP_BLOCK_LIST]; top; top = block_next(top)) - if (block_data(top)) - free(block_data(top)); - - for (i = 0; i < sc->saved_pointers_loc; i++) - free(sc->saved_pointers[i]); - free(sc->saved_pointers); - - { - gc_obj_t *g, *gnxt; - heap_block_t *hpnxt; - for (g = sc->semipermanent_lets; g; g = gnxt) {gnxt = g->nxt; free(g);} - for (g = sc->semipermanent_objects; g; g = gnxt) {gnxt = g->nxt; free(g);} - for (heap_block_t *hp = sc->heap_blocks; hp; hp = hpnxt) {hpnxt = hp->next; free(hp);} - } - - free(sc->heap); - free(sc->free_heap); - free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */ - free(sc->symbol_table); - free(sc->unlet); - free(sc->setters); - free(sc->op_stack); - if (sc->tree_pointers) free(sc->tree_pointers); - free(sc->num_to_str); - free(sc->protected_objects_free_list); - if (sc->read_line_buf) free(sc->read_line_buf); - free(sc->strbuf); - free(sc->circle_info->objs); - free(sc->circle_info->refs); - free(sc->circle_info->defined); - free(sc->circle_info); - if (sc->file_names) free(sc->file_names); - free(sc->unentry); - free(sc->input_port_stack); - if (sc->typnam) free(sc->typnam); - - for (i = 0; i < sc->num_fdats; i++) - if (sc->fdats[i]) /* init val is NULL */ - { - if (sc->fdats[i]->curly_str) - free(sc->fdats[i]->curly_str); - free(sc->fdats[i]); - } - free(sc->fdats); - - if (sc->profile_data) - { - free(sc->profile_data->funcs); - free(sc->profile_data->let_names); - free(sc->profile_data->files); - free(sc->profile_data->lines); - free(sc->profile_data->excl); - free(sc->profile_data->timing_data); - free(sc->profile_data); - } - if (sc->c_object_types) - { - for (i = 0; i < sc->num_c_object_types; i++) - free(sc->c_object_types[i]); - free(sc->c_object_types); - } - free(sc); -} - - -/* -------------------------------- repl -------------------------------- */ -#ifndef USE_SND - #define USE_SND 0 -#endif -#ifndef WITH_MAIN - #define WITH_MAIN 0 -#endif - -#if WITH_MAIN && WITH_NOTCURSES - #include "nrepl.c" - /* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core */ -#else - -static void dumb_repl(s7_scheme *sc) -{ - while (true) - { - char buffer[512]; - fprintf(stdout, "\n> "); - if (!fgets(buffer, 512, stdin)) break; /* error or ctrl-D */ - if (((buffer[0] != '\n') || (strlen(buffer) > 1))) - { - char response[1024]; - snprintf(response, 1024, "(write %s)", buffer); - s7_eval_c_string(sc, response); - }} - fprintf(stdout, "\n"); - if (ferror(stdin)) - fprintf(stderr, "read error on stdin\n"); -} - -void s7_repl(s7_scheme *sc) -{ -#if (!WITH_C_LOADER) - dumb_repl(sc); -#else -#if WITH_NOTCURSES - s7_load(sc, "nrepl.scm"); -#else - /* try to get lib_s7.so from the repl's directory, and set *libc*. - * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h - */ - bool repl_loaded = false; - s7_pointer e = s7_inlet(sc, set_clist_2(sc, make_symbol(sc, "init_func", 9), make_symbol(sc, "libc_s7_init", 12))); - s7_int gc_loc = s7_gc_protect(sc, e); - s7_pointer old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */ - s7_pointer val = s7_load_with_environment(sc, "libc_s7.so", e); - if (val) - { - s7_pointer libs = global_slot(sc->libraries_symbol); - uint64_t hash = raw_string_hash((const uint8_t *)"*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */ - s7_define(sc, sc->nil, new_symbol(sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), e); - slot_set_value(libs, cons(sc, cons(sc, s7_make_semipermanent_string(sc, "libc.scm"), e), slot_value(libs))); - } - - s7_set_curlet(sc, old_e); /* restore incoming (curlet) */ - s7_gc_unprotect_at(sc, gc_loc); - - if (!val) /* s7_load was unable to find/load libc_s7.so */ - dumb_repl(sc); - else - { -#if S7_DEBUGGING - s7_autoload(sc, make_symbol(sc, "compare-calls", 13), s7_make_string(sc, "compare-calls.scm")); - s7_autoload(sc, make_symbol(sc, "get-overheads", 13), s7_make_string(sc, "compare-calls.scm")); -#endif - s7_provide(sc, "libc.scm"); - if (!repl_loaded) s7_load(sc, "repl.scm"); - s7_eval_c_string(sc, "((*repl* 'run))"); - } -#endif -#endif -} - -#if WITH_MAIN && (!USE_SND) - -#if (!MS_WINDOWS) && WITH_C_LOADER -static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */ -{ - char *path; - char *p; - /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so - * directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to - * guess the libc_s7 directory from the command line program name. This can't work in general, but it works often - * enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead. - */ - if (!strchr(filename, '/')) - return(NULL); - - if (!(path = realpath(filename, NULL))) /* in Windows maybe GetModuleFileName(NULL, buffer, buffer_size) */ - { - fprintf(stderr, "%s: %s\n", strerror(errno), filename); - exit(2); - } - if (!(p = strrchr(path, '/'))) - { - free(path); - fprintf(stderr, "please provide the full pathname for %s\n", filename); - exit(2); - } - if (p > path) *p = '\0'; else p[1] = 0; - return(path); -} -#endif - -int main(int argc, char **argv) -{ - s7_scheme *sc = s7_init(); - fprintf(stderr, "s7: %s\n", S7_DATE); - - if (argc == 2) - { - fprintf(stderr, "load %s\n", argv[1]); - if (!s7_load(sc, argv[1])) - { - fprintf(stderr, "can't load %s\n", argv[1]); - return(2); - }} - else - { -#if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */ - dumb_repl(sc); -#else -#ifdef S7_LOAD_PATH - s7_add_to_load_path(sc, S7_LOAD_PATH); -#else - char *dir = realdir(argv[0]); - if (dir) - { - s7_add_to_load_path(sc, dir); - free(dir); - } -#endif - s7_repl(sc); -#endif - } - return(0); -} - -/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic ; also need libc.scm cload.scm repl.scm to get a decent repl - * in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic - * in OSX: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm - * (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC") - * in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib - * for tcc: tcc -o s7 s7.c -I. -lm -DWITH_MAIN -ldl -rdynamic -DWITH_C_LOADER - * - * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic - * - * (s7.c compile time 27-Oct-22 49 secs) - * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think - */ -#endif -#endif - -/* --------------------------------------------- - * 20.9 21.0 22.0 22.9 23.0 - * --------------------------------------------- - * tpeak 115 114 108 105 105 - * tref 691 687 463 459 459 - * index 1026 1016 973 966 967 - * tmock 1177 1165 1057 1019 1019 - * tvect 2519 2464 1772 1670 1669 - * timp 2637 2575 1930 1689 1694 - * texit ---- ---- 1778 1741 1741 - * s7test 1873 1831 1818 1826 1829 - * thook ---- ---- 2590 2030 2030 - * tauto ---- ---- 2562 2055 2048 - * lt 2187 2172 2150 2182 2185 - * dup 3805 3788 2492 2243 2239 - * tcopy 8035 5546 2539 2373 2375 - * tload ---- ---- 3046 2370 2408 - * tread 2440 2421 2419 2407 2408 - * fbench 2688 2583 2460 2428 2430 - * trclo 2735 2574 2454 2446 2445 - * titer 2865 2842 2641 2509 2509 - * tmat 3065 3042 2524 2567 2574 - * tb 2735 2681 2612 2603 2604 - * tsort 3105 3104 2856 2804 2804 - * teq 4068 4045 3536 3487 3486 - * tobj 4016 3970 3828 3570 3577 - * tio 3816 3752 3683 3620 3620 - * tmac 3950 3873 3033 3677 3677 - * tclo 4787 4735 4390 4389 4384 - * tcase 4960 4793 4439 4425 4430 - * tlet 7775 5640 4450 4431 4427 - * tstar 6139 5923 5519 4414 4451 - * tfft 7820 7729 4755 4465 4476 - * tmap 8869 8774 4489 4541 4541 - * tshoot 5525 5447 5183 5055 5055 - * tstr 6880 6342 5488 5161 5162 - * tform 5357 5348 5307 5304 5316 - * tnum 6348 6013 5433 5385 5396 - * tlamb 6423 6273 5720 5554 5560 - * tmisc 8869 7612 6435 6085 6076 - * tset ---- ---- ---- 6242 6260 - * tlist 7896 7546 6558 6244 6240 - * tgsl 8485 7802 6373 6281 6282 - * tari 13.0 12.7 6827 6543 6543 - * trec 6936 6922 6521 6588 6588 - * tleft 10.4 10.2 7657 7477 7479 - * tgc 11.9 11.1 8177 7868 7857 - * thash 11.8 11.7 9734 9483 9479 - * cb 11.2 11.0 9658 9551 9564 - * tgen 11.2 11.4 12.0 12.1 12.1 - * tall 15.6 15.6 15.6 15.6 15.6 - * calls 36.7 37.5 37.0 37.6 37.5 - * sg ---- ---- 55.9 55.8 55.8 - * lg ---- ---- 105.2 106.2 106.5 - * tbig 177.4 175.8 156.5 148.1 148.1 - * --------------------------------------------- - * - * (let-temporarily (((setter list) list)) (set! (list 1 2) (values 3 4 5))) should be an error? (any mv 3rd arg) - * se 79352 -- there is no way to treat this as an error consistently - * where are non-symbols->*s7* set? eval at op and g_s7... both could be checked - */ diff --git a/source/engine/s7.h b/source/engine/s7.h deleted file mode 100644 index aeacedf..0000000 --- a/source/engine/s7.h +++ /dev/null @@ -1,1239 +0,0 @@ -#ifndef S7_H -#define S7_H - -#define S7_VERSION "10.5" -#define S7_DATE "12-Dec-2022" -#define S7_MAJOR_VERSION 10 -#define S7_MINOR_VERSION 5 - -#include /* for int64_t */ - -typedef int64_t s7_int; -typedef double s7_double; - -#ifndef __cplusplus -#ifndef _MSC_VER - #include -#else -#ifndef true - #define bool unsigned char - #define true 1 - #define false 0 -#endif -#endif -#endif - -#if WITH_GMP - /* in g++ these includes need to be outside the extern "C" business */ - #include - #include - #include -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -typedef struct s7_scheme s7_scheme; -typedef struct s7_cell *s7_pointer; - -s7_scheme *s7_init(void); - /* s7_scheme is our interpreter - * s7_pointer is a Scheme object of any (Scheme) type - * s7_init creates the interpreter. - */ -void s7_free(s7_scheme *sc); - -typedef s7_pointer (*s7_function)(s7_scheme *sc, s7_pointer args); /* that is, obj = func(s7, args) -- args is a list of arguments */ -typedef s7_pointer (*s7_pfunc)(s7_scheme *sc); - -s7_pointer s7_f(s7_scheme *sc); /* #f */ -s7_pointer s7_t(s7_scheme *sc); /* #t */ -s7_pointer s7_nil(s7_scheme *sc); /* () */ -s7_pointer s7_undefined(s7_scheme *sc); /* # */ -s7_pointer s7_unspecified(s7_scheme *sc); /* # */ -bool s7_is_unspecified(s7_scheme *sc, s7_pointer val); /* returns true if val is # */ -s7_pointer s7_eof_object(s7_scheme *sc); /* # */ -bool s7_is_null(s7_scheme *sc, s7_pointer p); /* null? */ - - /* these are the Scheme constants; they do not change in value during a run, - * so they can be safely assigned to C global variables if desired. - */ - -bool s7_is_valid(s7_scheme *sc, s7_pointer arg); /* does 'arg' look like an s7 object? */ -bool s7_is_c_pointer(s7_pointer arg); /* (c-pointer? arg) */ -bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type); -void *s7_c_pointer(s7_pointer p); -void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum); -s7_pointer s7_c_pointer_type(s7_pointer p); -s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr); /* these are for passing uninterpreted C pointers through Scheme */ -s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info); - -s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str); /* (eval-string str) */ -s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e); -s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer arg, bool use_write); - /* (object->string obj) */ -char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj); /* same as object->string but returns a C char* directly */ - /* the returned value should be freed by the caller */ - -s7_pointer s7_load(s7_scheme *sc, const char *file); /* (load file) */ -s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e); -s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes); -s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e); -s7_pointer s7_load_path(s7_scheme *sc); /* *load-path* */ -s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir); /* (set! *load-path* (cons dir *load-path*)) */ -s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function); /* (autoload symbol file-or-function) */ -void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size); - - /* the load path is a list of directories to search if load can't find the file passed as its argument. - * - * s7_load and s7_load_with_environment can load shared object files as well as scheme code. - * The scheme (load "somelib.so" (inlet 'init_func 'somelib_init)) is equivalent to - * s7_load_with_environment(s7, "somelib.so", s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "init_func"), s7_make_symbol(s7, "somelib_init")))) - * s7_load_with_environment returns NULL if it can't load the file. - */ -void s7_quit(s7_scheme *sc); - /* this tries to break out of the current evaluation, leaving everything else intact */ - -void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val); -void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val)); - /* call "hook" at the start of any block; use NULL to cancel. - * s7_begin_hook returns the current begin_hook function or NULL. - */ - -s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e); /* (eval code e) -- e is the optional environment */ -s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line); -void s7_provide(s7_scheme *sc, const char *feature); /* add feature (as a symbol) to the *features* list */ -bool s7_is_provided(s7_scheme *sc, const char *feature); /* (provided? feature) */ -void s7_repl(s7_scheme *sc); - -s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info); -s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr); -s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr); - /* set arg_n to 0 to indicate that caller takes only one argument (so the argument number need not be reported */ -s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr); -s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args); - - /* these are equivalent to (error ...) in Scheme - * the first argument to s7_error is a symbol that can be caught (via (catch tag ...)) - * the rest of the arguments are passed to the error handler (if in catch) - * or printed out (in the default case). If the first element of the list - * of args ("info") is a string, the default error handler treats it as - * a format control string, and passes it to format with the rest of the - * info list as the format function arguments. - * - * s7_wrong_type_arg_error is equivalent to s7_error with a type of 'wrong-type-arg - * and similarly s7_out_of_range_error with type 'out-of-range. - * - * catch in Scheme is taken from Guile: - * - * (catch tag thunk handler) - * - * evaluates 'thunk'. If an error occurs, and the type matches 'tag' (or if 'tag' is #t), - * the handler is called, passing it the arguments (including the type) passed to the - * error function. If no handler is found, the default error handler is called, - * normally printing the error arguments to current-error-port. - */ - -s7_pointer s7_stacktrace(s7_scheme *sc); -s7_pointer s7_history(s7_scheme *sc); /* the current (circular backwards) history buffer */ -s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry); /* add entry to the history buffer */ -bool s7_history_enabled(s7_scheme *sc); -bool s7_set_history_enabled(s7_scheme *sc, bool enabled); - -s7_pointer s7_gc_on(s7_scheme *sc, bool on); /* (gc on) */ - -s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x); -void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc); -s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc); -s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x); -s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x); -s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc); -s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc); - - /* any s7_pointer object held in C (as a local variable for example) needs to be - * protected from garbage collection if there is any chance the GC may run without - * an existing Scheme-level reference to that object. s7_gc_protect places the - * object in a vector that the GC always checks, returning the object's location - * in that table. s7_gc_unprotect_at unprotects the object (removes it from the - * vector) using the location passed to it. s7_gc_protected_at returns the object - * at the given location. - * - * You can turn the GC on and off via s7_gc_on. - * - * There is a built-in lag between the creation of a new object and its first possible GC - * (the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about - * very short term temps such as the arguments to s7_cons in: - * - * s7_cons(s7, s7_make_real(s7, 3.14), - * s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7))); - */ - -bool s7_is_eq(s7_pointer a, s7_pointer b); /* (eq? a b) */ -bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (eqv? a b) */ -bool s7_is_equal(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (equal? a b) */ -bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y); /* (equivalent? x y) */ - -bool s7_is_boolean(s7_pointer x); /* (boolean? x) */ -bool s7_boolean(s7_scheme *sc, s7_pointer x); /* Scheme boolean -> C bool */ -s7_pointer s7_make_boolean(s7_scheme *sc, bool x); /* C bool -> Scheme boolean */ - - /* for each Scheme type (boolean, integer, string, etc), there are three - * functions: s7_(...), s7_make_(...), and s7_is_(...): - * - * s7_boolean(s7, obj) returns the C bool corresponding to the value of 'obj' (#f -> false) - * s7_make_boolean(s7, false|true) returns the s7 boolean corresponding to the C bool argument (false -> #f) - * s7_is_boolean(s7, obj) returns true if 'obj' has a boolean value (#f or #t). - */ - - -bool s7_is_pair(s7_pointer p); /* (pair? p) */ -s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (cons a b) */ - -s7_pointer s7_car(s7_pointer p); /* (car p) */ -s7_pointer s7_cdr(s7_pointer p); /* (cdr p) */ - -s7_pointer s7_set_car(s7_pointer p, s7_pointer q); /* (set-car! p q) */ -s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q); /* (set-cdr! p q) */ - -s7_pointer s7_cadr(s7_pointer p); /* (cadr p) */ -s7_pointer s7_cddr(s7_pointer p); /* (cddr p) */ -s7_pointer s7_cdar(s7_pointer p); /* (cdar p) */ -s7_pointer s7_caar(s7_pointer p); /* (caar p) */ - -s7_pointer s7_caadr(s7_pointer p); /* etc */ -s7_pointer s7_caddr(s7_pointer p); -s7_pointer s7_cadar(s7_pointer p); -s7_pointer s7_caaar(s7_pointer p); -s7_pointer s7_cdadr(s7_pointer p); -s7_pointer s7_cdddr(s7_pointer p); -s7_pointer s7_cddar(s7_pointer p); -s7_pointer s7_cdaar(s7_pointer p); - -s7_pointer s7_caaadr(s7_pointer p); -s7_pointer s7_caaddr(s7_pointer p); -s7_pointer s7_caadar(s7_pointer p); -s7_pointer s7_caaaar(s7_pointer p); -s7_pointer s7_cadadr(s7_pointer p); -s7_pointer s7_cadddr(s7_pointer p); -s7_pointer s7_caddar(s7_pointer p); -s7_pointer s7_cadaar(s7_pointer p); -s7_pointer s7_cdaadr(s7_pointer p); -s7_pointer s7_cdaddr(s7_pointer p); -s7_pointer s7_cdadar(s7_pointer p); -s7_pointer s7_cdaaar(s7_pointer p); -s7_pointer s7_cddadr(s7_pointer p); -s7_pointer s7_cddddr(s7_pointer p); -s7_pointer s7_cdddar(s7_pointer p); -s7_pointer s7_cddaar(s7_pointer p); - -bool s7_is_list(s7_scheme *sc, s7_pointer p); /* (list? p) -> (or (pair? p) (null? p)) */ -bool s7_is_proper_list(s7_scheme *sc, s7_pointer p); /* (proper-list? p) */ -s7_int s7_list_length(s7_scheme *sc, s7_pointer a); /* (length a) */ -s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init); /* (make-list len init) */ -s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...); /* (list ...) */ -s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...); /* (list ...) arglist should be NULL terminated (more error checks than s7_list) */ -s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array); /* array contents -> list */ -void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len); /* list -> array (intended for old code) */ -s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a); /* (reverse a) */ -s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (append a b) */ -s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num); /* (list-ref lst num) */ -s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val); /* (list-set! lst num val) */ -s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (assoc obj lst) */ -s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (assq obj lst) */ -s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (member obj lst) */ -s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (memq obj lst) */ -bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree); /* (tree-memq sym tree) */ - - -bool s7_is_string(s7_pointer p); /* (string? p) */ -const char *s7_string(s7_pointer p); /* Scheme string -> C string (do not free the string) */ -s7_pointer s7_make_string(s7_scheme *sc, const char *str); /* C string -> Scheme string (str is copied) */ -s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len); /* same as s7_make_string, but provides strlen */ -s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str); -s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len); -s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str); /* make a string that will never be GC'd */ -s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str); /* for (s7) string permanent within one s7 instance (freed upon s7_free) */ -s7_int s7_string_length(s7_pointer str); /* (string-length str) */ - - -bool s7_is_character(s7_pointer p); /* (character? p) */ -uint8_t s7_character(s7_pointer p); /* Scheme character -> unsigned C char */ -s7_pointer s7_make_character(s7_scheme *sc, uint8_t c); /* unsigned C char -> Scheme character */ - - -bool s7_is_number(s7_pointer p); /* (number? p) */ -bool s7_is_integer(s7_pointer p); /* (integer? p) */ -s7_int s7_integer(s7_pointer p); /* Scheme integer -> C integer (s7_int) */ -s7_pointer s7_make_integer(s7_scheme *sc, s7_int num); /* C s7_int -> Scheme integer */ - -bool s7_is_real(s7_pointer p); /* (real? p) */ -s7_double s7_real(s7_pointer p); /* Scheme real -> C double */ -s7_pointer s7_make_real(s7_scheme *sc, s7_double num); /* C double -> Scheme real */ -s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n); -s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x); /* x can be any kind of number */ -s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller); -s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller); -s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x); -s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller); - -bool s7_is_rational(s7_pointer arg); /* (rational? arg) -- integer or ratio */ -bool s7_is_ratio(s7_pointer arg); /* true if arg is a ratio, not an integer */ -s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b); /* returns the Scheme object a/b */ -s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error); /* (rationalize x error) */ -s7_int s7_numerator(s7_pointer x); /* (numerator x) */ -s7_int s7_denominator(s7_pointer x); /* (denominator x) */ -s7_double s7_random(s7_scheme *sc, s7_pointer state); /* (random x) */ -s7_pointer s7_random_state(s7_scheme *sc, s7_pointer seed); /* (random-state seed) */ -s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args); /* (random-state->list r) */ -void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry); -bool s7_is_random_state(s7_pointer p); /* (random-state? p) */ - -bool s7_is_complex(s7_pointer arg); /* (complex? arg) */ -s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b); /* returns the Scheme object a+bi */ -s7_double s7_real_part(s7_pointer z); /* (real-part z) */ -s7_double s7_imag_part(s7_pointer z); /* (imag-part z) */ -char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix); /* (number->string obj radix) */ - -bool s7_is_vector(s7_pointer p); /* (vector? p) */ -s7_int s7_vector_length(s7_pointer vec); /* (vector-length vec) */ -s7_int s7_vector_rank(s7_pointer vect); /* number of dimensions in vect */ -s7_int s7_vector_dimension(s7_pointer vec, s7_int dim); -s7_pointer *s7_vector_elements(s7_pointer vec); /* a pointer to the array of s7_pointers */ -s7_int *s7_int_vector_elements(s7_pointer vec); -uint8_t *s7_byte_vector_elements(s7_pointer vec); -s7_double *s7_float_vector_elements(s7_pointer vec); -bool s7_is_float_vector(s7_pointer p); /* (float-vector? p) */ -bool s7_is_int_vector(s7_pointer p); /* (int-vector? p) */ -bool s7_is_byte_vector(s7_pointer p); /* (byte-vector? p) */ - -s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index); /* (vector-ref vec index) */ -s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a); /* (vector-set! vec index a) */ -s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...); /* multidimensional vector-ref */ -s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...); /* multidimensional vector-set! */ -s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size); /* vector dimensions */ -s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size); - -s7_int s7_int_vector_ref(s7_pointer vec, s7_int index); -s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value); -uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index); -uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value); -s7_double s7_float_vector_ref(s7_pointer vec, s7_int index); -s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value); - -s7_pointer s7_make_vector(s7_scheme *sc, s7_int len); /* (make-vector len) */ -s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); -s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); -s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); -s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); /* make-vector but possibly multidimensional */ -s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data); -s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill); /* (make-vector len fill) */ - -void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj); /* (vector-fill! vec obj) */ -s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect); -s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect); /* (vector->list vec) */ - /* - * (vect i) is the same as (vector-ref vect i) - * (set! (vect i) x) is the same as (vector-set! vect i x) - * (vect i j k) accesses the 3-dimensional vect - * (set! (vect i j k) x) sets that element (vector-ref and vector-set! can also be used) - * (make-vector (list 2 3 4)) returns a 3-dimensional vector with the given dimension sizes - * (make-vector '(2 3) 1.0) returns a 2-dim vector with all elements set to 1.0 - */ - -bool s7_is_hash_table(s7_pointer p); /* (hash-table? p) */ -s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size); /* (make-hash-table size) */ -s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key); - /* (hash-table-ref table key) */ -s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value); - /* (hash-table-set! table key value) */ -s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer eqfunc); /* (hash-code obj [eqfunc]) */ - -s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook); /* (hook-functions hook) */ -s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions); /* (set! (hook-functions hook) ...) */ - - -bool s7_is_input_port(s7_scheme *sc, s7_pointer p); /* (input-port? p) */ -bool s7_is_output_port(s7_scheme *sc, s7_pointer p); /* (output-port? p) */ -const char *s7_port_filename(s7_scheme *sc, s7_pointer x); /* (port-filename p) */ -s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p); /* (port-line-number p) */ - -s7_pointer s7_current_input_port(s7_scheme *sc); /* (current-input-port) */ -s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer p); /* (set-current-input-port) */ -s7_pointer s7_current_output_port(s7_scheme *sc); /* (current-output-port) */ -s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer p); /* (set-current-output-port) */ -s7_pointer s7_current_error_port(s7_scheme *sc); /* (current-error-port) */ -s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port); /* (set-current-error-port port) */ -void s7_close_input_port(s7_scheme *sc, s7_pointer p); /* (close-input-port p) */ -void s7_close_output_port(s7_scheme *sc, s7_pointer p); /* (close-output-port p) */ -s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode); - /* (open-input-file name mode) */ -s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode); - /* (open-output-file name mode) */ - /* mode here is an optional C style flag, "a" for "alter", etc ("r" is the input default, "w" is the output default) */ -s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string); - /* (open-input-string str) */ -s7_pointer s7_open_output_string(s7_scheme *sc); /* (open-output-string) */ -const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port); /* (get-output-string port) -- current contents of output string */ - /* don't free the string */ -s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p); /* same but returns an s7 string */ -bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* (flush-output-port port) */ - -typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t; -s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)); -s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)); - -s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port); /* (read-char port) */ -s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port); /* (peek-char port) */ -s7_pointer s7_read(s7_scheme *sc, s7_pointer port); /* (read port) */ -void s7_newline(s7_scheme *sc, s7_pointer port); /* (newline port) */ -s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port); /* (write-char c port) */ -s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port); /* (write obj port) */ -s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port); /* (display obj port) */ -const char *s7_format(s7_scheme *sc, s7_pointer args); /* (format ... */ - - -bool s7_is_syntax(s7_pointer p); /* (syntax? p) */ -bool s7_is_symbol(s7_pointer p); /* (symbol? p) */ -const char *s7_symbol_name(s7_pointer p); /* (symbol->string p) -- don't free the string */ -s7_pointer s7_make_symbol(s7_scheme *sc, const char *name); /* (string->symbol name) */ -s7_pointer s7_gensym(s7_scheme *sc, const char *prefix); /* (gensym prefix) */ - -bool s7_is_keyword(s7_pointer obj); /* (keyword? obj) */ -s7_pointer s7_make_keyword(s7_scheme *sc, const char *key); /* (string->keyword key) */ -s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key); /* (keyword->symbol key) */ - -s7_pointer s7_rootlet(s7_scheme *sc); /* (rootlet) */ -s7_pointer s7_shadow_rootlet(s7_scheme *sc); -s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let); -s7_pointer s7_curlet(s7_scheme *sc); /* (curlet) */ -s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e); /* returns previous curlet */ -s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e); /* (outlet e) */ -s7_pointer s7_sublet(s7_scheme *sc, s7_pointer env, s7_pointer bindings); /* (sublet e ...) */ -s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings); /* (inlet ...) */ -s7_pointer s7_varlet(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); /* (varlet env symbol value) */ -s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env); /* (let->list env) */ -bool s7_is_let(s7_pointer e); /* )let? e) */ -s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer sym); /* (let-ref e sym) */ -s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer sym, s7_pointer val); /* (let-set! e sym val) */ -s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e); /* (openlet e) */ -bool s7_is_openlet(s7_pointer e); /* (openlet? e) */ -s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method); - -/* *s7* */ -/* these renamed because "s7_let_field" seems the same as "s7_let", but here we're referring to *s7*, not any let */ -s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym); /* (*s7* sym) */ -s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */ -/* new names */ -s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym); /* (*s7* sym) */ -s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */ - -s7_pointer s7_name_to_value(s7_scheme *sc, const char *name); /* name's value in the current environment (after turning name into a symbol) */ -s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name); -s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym); -s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val); -s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env); -bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data); -bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data); - - /* these access the current environment and symbol table, providing - * a symbol's current binding (s7_name_to_value takes the symbol name as a char*, - * s7_symbol_value takes the symbol itself, s7_symbol_set_value changes the - * current binding, and s7_symbol_local_value uses the environment passed - * as its third argument). - * - * To iterate over the complete symbol table, use s7_for_each_symbol_name, - * and s7_for_each_symbol. Both call 'symbol_func' on each symbol, passing it - * the symbol or symbol name, and the uninterpreted 'data' pointer. - * the current binding. The for-each loop stops if the symbol_func returns true, - * or at the end of the table. - */ - -s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish); - -bool s7_is_immutable(s7_pointer p); -s7_pointer s7_immutable(s7_pointer p); - -void s7_define(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); -bool s7_is_defined(s7_scheme *sc, const char *name); -s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value); -s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help); -s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value); -s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help); -s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value); - /* These functions add a symbol and its binding to either the top-level environment - * or the 'env' passed as the second argument to s7_define. Except for s7_define, they return - * the name as a symbol. - * - * s7_define_variable(sc, "*features*", s7_nil(sc)); - * - * in s7.c is equivalent to the top level form - * - * (define *features* ()) - * - * s7_define_variable is simply s7_define with string->symbol and the global environment. - * s7_define_constant is s7_define but makes its "definee" immutable. - * s7_define is equivalent to define in Scheme, except that it does not return the value. - */ - -bool s7_is_function(s7_pointer p); -bool s7_is_procedure(s7_pointer x); /* (procedure? x) */ -bool s7_is_macro(s7_scheme *sc, s7_pointer x); /* (macro? x) */ -s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p); -s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p); -s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p); -s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p); /* (funclet x) */ -bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args); /* (aritable? x args) */ -s7_pointer s7_arity(s7_scheme *sc, s7_pointer x); /* (arity x) */ -const char *s7_help(s7_scheme *sc, s7_pointer obj); /* (help obj) */ -s7_pointer s7_make_continuation(s7_scheme *sc); /* call/cc... (see example below) */ - -const char *s7_documentation(s7_scheme *sc, s7_pointer p); /* (documentation x) if any (don't free the string) */ -const char *s7_set_documentation(s7_scheme *sc, s7_pointer p, const char *new_doc); -s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj); /* (setter obj) */ -s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter); /* (set! (setter p) setter) */ -s7_pointer s7_signature(s7_scheme *sc, s7_pointer func); /* (signature obj) */ -s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...); /* procedure-signature data */ -s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...); - -/* possibly unsafe functions: */ -s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); - -/* safe functions: */ -s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); -s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature); - -/* arglist or body possibly unsafe: */ -s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); - -/* arglist and body safe: */ -s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); -s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature); - -/* arglist unsafe or body unsafe: */ -s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature); - -/* arglist safe, body possibly unsafe: */ -s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature); - -s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, s7_pointer signature); -s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); - - /* s7_make_function creates a Scheme function object from the s7_function 'fnc'. - * Its name (for s7_describe_object) is 'name', it requires 'required_args' arguments, - * can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts - * a "rest" argument (a list of all the trailing arguments). The function's documentation - * is 'doc'. The s7_make_functions return the new function, but the s7_define_function (and macro) - * procedures return the name as a symbol (a desire for backwards compatibility brought about this split). - * - * s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the - * global (top-level) environment, with the function as its value (and returns the symbol, not the function). - * For example, the Scheme function 'car' is essentially: - * - * s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));} - * - * then bound to the name "car": - * - * s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)"); - * ^ one required arg, no optional arg, no "rest" arg - * - * s7_is_function returns true if its argument is a function defined in this manner. - * s7_apply_function applies the function (the result of s7_make_function) to the arguments. - * - * s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function), - * but the macro's returned value (assumed to be some sort of Scheme expression) is evaluated. - * s7_define_macro returns the name as a symbol. - * - * Use the "unsafe" definer if the function might call the evaluator itself in some way (s7_apply_function for example), - * or messes with s7's stack. - */ - - /* In s7, (define* (name . args) body) or (define name (lambda* args body)) - * define a function that takes optional (keyword) named arguments. - * The "args" is a list that can contain either names (normal arguments), - * or lists of the form (name default-value), in any order. When called, - * the names are bound to their default values (or #f), then the function's - * current arglist is scanned. Any name that occurs as a keyword (":name") - * precedes that argument's new value. Otherwise, as values occur, they - * are plugged into the environment based on their position in the arglist - * (as normal for a function). So, - * - * (define* (hi a (b 32) (c "hi")) (list a b c)) - * (hi 1) -> '(1 32 "hi") - * (hi :b 2 :a 3) -> '(3 2 "hi") - * (hi 3 2 1) -> '(3 2 1) - * - * :rest causes its argument to be bound to the rest of the arguments at that point. - * - * The C connection to this takes the function name, the C function to call, the argument - * list as written in Scheme, and the documentation string. s7 makes sure the arguments - * are ordered correctly and have the specified defaults before calling the C function. - * s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*"); - * Now (a-func :arg1 2) calls the C function a_func(2, 32). See the example program in s7.html. - * - * In s7 Scheme, define* can be used just for its optional arguments feature, but that is - * included in s7_define_function. s7_define_function_star implements keyword arguments - * for C-level functions (as well as optional/rest arguments). - */ - -s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args); -s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args); - -s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args); -s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line); -s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler); - - /* s7_call takes a Scheme function and applies it to 'args' (a list of arguments) returning the result. - * s7_pointer kar; - * kar = s7_make_function(sc, "car", g_car, 1, 0, false, "(car obj)"); - * s7_integer(s7_call(sc, kar, s7_cons(sc, s7_cons(sc, s7_make_integer(sc, 123), s7_nil(sc)), s7_nil(sc)))); - * returns 123. - * - * s7_call_with_location passes some information to the error handler. - * s7_call makes sure some sort of catch exists if an error occurs during the call, but - * s7_apply_function does not -- it assumes the catch has been set up already. - * s7_call_with_catch wraps an explicit catch around a function call ("body" above); - * s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err). - */ - -bool s7_is_dilambda(s7_pointer obj); -s7_pointer s7_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), - s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), - s7_int set_req_args, s7_int set_opt_args, - const char *documentation); -s7_pointer s7_typed_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), - s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), - s7_int set_req_args, s7_int set_opt_args, - const char *documentation, - s7_pointer get_sig, s7_pointer set_sig); -s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), - s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), - s7_int set_req_args, s7_int set_opt_args, - const char *documentation); - -s7_pointer s7_values(s7_scheme *sc, s7_pointer args); /* (values ...) */ -bool s7_is_multiple_value(s7_pointer obj); /* is obj the results of (values ...) */ - -s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e); /* (make-iterator e) */ -bool s7_is_iterator(s7_pointer obj); /* (iterator? obj) */ -bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj); /* (iterator-at-end? obj) */ -s7_pointer s7_iterate(s7_scheme *sc, s7_pointer iter); /* (iterate iter) */ - -s7_pointer s7_copy(s7_scheme *sc, s7_pointer args); /* (copy ...) */ -s7_pointer s7_fill(s7_scheme *sc, s7_pointer args); /* (fill! ...) */ -s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg); /* (type-of arg) */ - - - -/* -------------------------------------------------------------------------------- */ -/* c types/objects */ - -void s7_mark(s7_pointer p); - -bool s7_is_c_object(s7_pointer p); -s7_int s7_c_object_type(s7_pointer obj); -void *s7_c_object_value(s7_pointer obj); -void *s7_c_object_value_checked(s7_pointer obj, s7_int type); -s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value); -s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let); -s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value); -s7_pointer s7_c_object_let(s7_pointer obj); -s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e); -/* the "let" in s7_make_c_object_with_let and s7_c_object_set_let needs to be GC protected by marking it in the c_object's mark function */ - -s7_int s7_make_c_type(s7_scheme *sc, const char *name); /* create a new c_object type */ - -/* old style free/mark/equal */ -void s7_c_type_set_free (s7_scheme *sc, s7_int tag, void (*gc_free)(void *value)); -void s7_c_type_set_mark (s7_scheme *sc, s7_int tag, void (*mark)(void *value)); -void s7_c_type_set_equal (s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2)); - -/* new style free/mark/equal and equivalent */ -void s7_c_type_set_gc_free (s7_scheme *sc, s7_int tag, s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer obj)); /* free c_object function, new style*/ -void s7_c_type_set_gc_mark (s7_scheme *sc, s7_int tag, s7_pointer (*mark) (s7_scheme *sc, s7_pointer obj)); /* mark function, new style */ -void s7_c_type_set_is_equal (s7_scheme *sc, s7_int tag, s7_pointer (*is_equal) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args)); - -void s7_c_type_set_ref (s7_scheme *sc, s7_int tag, s7_pointer (*ref) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_set (s7_scheme *sc, s7_int tag, s7_pointer (*set) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_length (s7_scheme *sc, s7_int tag, s7_pointer (*length) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_copy (s7_scheme *sc, s7_int tag, s7_pointer (*copy) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_fill (s7_scheme *sc, s7_int tag, s7_pointer (*fill) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_reverse (s7_scheme *sc, s7_int tag, s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_to_list (s7_scheme *sc, s7_int tag, s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_to_string (s7_scheme *sc, s7_int tag, s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_getter (s7_scheme *sc, s7_int tag, s7_pointer getter); -void s7_c_type_set_setter (s7_scheme *sc, s7_int tag, s7_pointer setter); -/* For the copy function, either the first or second argument can be a c-object of the given type. */ - - /* These functions create a new Scheme object type. There is a simple example in s7.html. - * - * s7_make_c_type creates a new C-based type for Scheme. It returns an s7_int "tag" used to indentify this type elsewhere. - * The functions associated with this type are set via s7_c_type_set*: - * - * free: the function called when an object of this type is about to be garbage collected - * mark: called during the GC mark pass -- you should call s7_mark - * on any embedded s7_pointer associated with the object (including its "let") to protect if from the GC. - * gc_mark and gc_free are new forms of mark and free, taking the c_object s7_pointer rather than its void* value - * equal: compare two objects of this type; (equal? obj1 obj2) -- this is the old form - * is_equal: compare objects as in equal? -- this is the new form of equal? - * is_equivalent: compare objects as in equivalent? - * ref: a function that is called whenever an object of this type - * occurs in the function position (at the car of a list; the rest of the list - * is passed to the ref function as the arguments: (obj ...)) - * set: a function that is called whenever an object of this type occurs as - * the target of a generalized set! (set! (obj ...) val) - * length: the function called when the object is asked what its length is. - * copy: the function called when a copy of the object is needed. - * fill: the function called to fill the object with some value. - * reverse: similarly... - * to_string: object->string for an object of this type - * getter/setter: these help the optimizer handle applicable c-objects (see s7test.scm for an example) - * - * s7_is_c_object returns true if 'p' is a c_object - * s7_c_object_type returns the c_object's type (the s7_int passed to s7_make_c_object) - * s7_c_object_value returns the value bound to that c_object (the void *value of s7_make_c_object) - * s7_make_c_object creates a new Scheme entity of the given type with the given (uninterpreted) value - * s7_mark marks any Scheme c_object as in-use (use this in the mark function to mark - * any embedded s7_pointer variables). - */ - -/* -------------------------------------------------------------------------------- */ -/* the new clm optimizer! this time for sure! - * d=double, i=integer, v=c_object, p=s7_pointer - * first return type, then arg types, d_vd -> returns double takes c_object and double (i.e. a standard clm generator) - * - * It is possible to tell s7 to call a foreign function directly, without any scheme-related - * overhead. The call needs to take the form of one of the s7_*_t functions in s7.h. For example, - * one way to call + is to pass it two s7_double arguments and get an s7_double back. This is the - * s7_d_dd_t function (the first letter gives the return type, the rest give successive argument types). - * We tell s7 about it via s7_set_d_dd_function. Whenever s7's optimizer encounters + with two arguments - * that it (the optimizer) knows are s7_doubles, in a context where an s7_double result is expected, - * s7 calls the s7_d_dd_t function directly without consing a list of arguments, and without - * wrapping up the result as a scheme cell. - */ - -s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr); - -typedef s7_double (*s7_float_function)(s7_scheme *sc); -s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr); - -typedef s7_double (*s7_d_t)(void); -void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df); -s7_d_t s7_d_function(s7_pointer f); - -typedef s7_double (*s7_d_d_t)(s7_double x); -void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df); -s7_d_d_t s7_d_d_function(s7_pointer f); - -typedef s7_double (*s7_d_dd_t)(s7_double x1, s7_double x2); -void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df); -s7_d_dd_t s7_d_dd_function(s7_pointer f); - -typedef s7_double (*s7_d_ddd_t)(s7_double x1, s7_double x2, s7_double x3); -void s7_set_d_ddd_function(s7_scheme *sc, s7_pointer f, s7_d_ddd_t df); -s7_d_ddd_t s7_d_ddd_function(s7_pointer f); - -typedef s7_double (*s7_d_dddd_t)(s7_double x1, s7_double x2, s7_double x3, s7_double x4); -void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df); -s7_d_dddd_t s7_d_dddd_function(s7_pointer f); - -typedef s7_double (*s7_d_v_t)(void *v); -void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df); -s7_d_v_t s7_d_v_function(s7_pointer f); - -typedef s7_double (*s7_d_vd_t)(void *v, s7_double d); -void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df); -s7_d_vd_t s7_d_vd_function(s7_pointer f); - -typedef s7_double (*s7_d_vdd_t)(void *v, s7_double x1, s7_double x2); -void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df); -s7_d_vdd_t s7_d_vdd_function(s7_pointer f); - -typedef s7_double (*s7_d_vid_t)(void *v, s7_int i, s7_double d); -void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df); -s7_d_vid_t s7_d_vid_function(s7_pointer f); - -typedef s7_double (*s7_d_p_t)(s7_pointer p); -void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df); -s7_d_p_t s7_d_p_function(s7_pointer f); - -typedef s7_double (*s7_d_pd_t)(s7_pointer v, s7_double x); -void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df); -s7_d_pd_t s7_d_pd_function(s7_pointer f); - -typedef s7_double (*s7_d_7pi_t)(s7_scheme *sc, s7_pointer v, s7_int i); -void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df); -s7_d_7pi_t s7_d_7pi_function(s7_pointer f); - -typedef s7_double (*s7_d_7pid_t)(s7_scheme *sc, s7_pointer v, s7_int i, s7_double d); -void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df); -s7_d_7pid_t s7_d_7pid_function(s7_pointer f); - -typedef s7_double (*s7_d_id_t)(s7_int i, s7_double d); -void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df); -s7_d_id_t s7_d_id_function(s7_pointer f); - -typedef s7_double (*s7_d_ip_t)(s7_int i, s7_pointer p); -void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df); -s7_d_ip_t s7_d_ip_function(s7_pointer f); - -typedef s7_int (*s7_i_i_t)(s7_int x); -void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df); -s7_i_i_t s7_i_i_function(s7_pointer f); - -typedef s7_int (*s7_i_7d_t)(s7_scheme *sc, s7_double x); -void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df); -s7_i_7d_t s7_i_7d_function(s7_pointer f); - -typedef s7_int (*s7_i_ii_t)(s7_int i1, s7_int i2); -void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df); -s7_i_ii_t s7_i_ii_function(s7_pointer f); - -typedef s7_int (*s7_i_7p_t)(s7_scheme *sc, s7_pointer p); -void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df); -s7_i_7p_t s7_i_7p_function(s7_pointer f); - -typedef bool (*s7_b_p_t)(s7_pointer p); -void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df); -s7_b_p_t s7_b_p_function(s7_pointer f); - -typedef s7_pointer (*s7_p_d_t)(s7_scheme *sc, s7_double x); -void s7_set_p_d_function(s7_scheme *sc, s7_pointer f, s7_p_d_t df); -s7_p_d_t s7_p_d_function(s7_pointer f); - -typedef s7_pointer (*s7_p_p_t)(s7_scheme *sc, s7_pointer p); -void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df); -s7_p_p_t s7_p_p_function(s7_pointer f); - -typedef s7_pointer (*s7_p_pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); -void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df); -s7_p_pp_t s7_p_pp_function(s7_pointer f); - -typedef s7_pointer (*s7_p_ppp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3); -void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df); -s7_p_ppp_t s7_p_ppp_function(s7_pointer f); - -/* Here is an example of using these functions; more extensive examples are in clm2xen.c in sndlib, and in s7.c. - * (This example comes from a HackerNews discussion): - * plus.c: - * -------- - * #include "s7.h" - * - * s7_pointer g_plusone(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));} - * s7_int plusone(s7_int x) {return(x + 1);} - * - * void plusone_init(s7_scheme *sc) - * { - * s7_define_safe_function(sc, "plusone", g_plusone, 1, 0, false, ""); - * s7_set_i_i_function(sc, s7_name_to_value(sc, "plusone"), plusone); - * } - * -------- - * gcc -c plus.c -fPIC -O2 -lm - * gcc plus.o -shared -o plus.so -ldl -lm -Wl,-export-dynamic - * repl - * <1> (load "plus.so" (inlet 'init_func 'plusone_init)) - * -------- - */ - -/* -------------------------------------------------------------------------------- */ - -/* maybe remove these? */ -s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol); -s7_pointer s7_slot_value(s7_pointer slot); -s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value); -s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); -void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value); - -/* -------------------------------------------------------------------------------- */ - -#if (!DISABLE_DEPRECATED) -typedef s7_int s7_Int; -typedef s7_double s7_Double; - -#define s7_is_object s7_is_c_object -#define s7_object_type s7_c_object_type -#define s7_object_value s7_c_object_value -#define s7_make_object s7_make_c_object -#define s7_mark_object s7_mark -#define s7_UNSPECIFIED(Sc) s7_unspecified(Sc) -#endif - - -#if WITH_GMP - mpfr_t *s7_big_real(s7_pointer x); - mpz_t *s7_big_integer(s7_pointer x); - mpq_t *s7_big_ratio(s7_pointer x); - mpc_t *s7_big_complex(s7_pointer x); - - bool s7_is_bignum(s7_pointer obj); - bool s7_is_big_real(s7_pointer x); - bool s7_is_big_integer(s7_pointer x); - bool s7_is_big_ratio(s7_pointer x); - bool s7_is_big_complex(s7_pointer x); - - s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val); - s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val); - s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val); - s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val); -#endif - - -/* -------------------------------------------------------------------------------- - * - * s7 changes - * - * -------- - * 9-Nov: nan, nan-payload, +nan.. - * 19-Oct: s7_let_field* synonyms: s7_starlet*. - * 16-Sep: s7_number_to_real_with_location. s7_wrong_type_error. s7_make_string_wrapper_with_length. s7_make_semipermanent_string. - * 21-Apr: s7_is_multiple_value. - * 11-Apr: removed s7_apply_*. - * 22-Mar: s7_eval_with_location. - * 16-Mar: s7_list_to_array for the s7_apply_* changes. - * 8-Mar-22: moved s7_apply_* to xen.h if DISABLE_DEPRECATED. - * -------- - * 24-Nov: moved s7_p_p_t and friends into s7.h. - * 23-Sep: s7_make_byte_vector, s7_is_byte_vector, s7_byte_vector_ref|set|elements. - * 25-Aug: s7_output_string (like s7_get_output_string, but returns an s7 string). - * 19-Jul: s7_is_random_state, s7_make_normal_vector. s7_array_to_list. - * 12-Apr: s7_optimize now returns an s7_pfunc, not an s7_function. - * 7-Apr: removed the "args" parameter from s7_float_function. added s7_make_c_object_without_gc. - * 31-Mar: vector-rank, vector-dimension. - * 17-Mar: removed deprecated nan.0 and inf.0 due to compiler stupidity. - * 25-Jan: s7_define_semisafe_typed_function. - * 6-Jan-21: s7_hash_code. - * -------- - * 14-Oct: s7_load_c_string and s7_load_c_string_with_environment. - * 10-Sep: s7_free. - * 5-Aug: s7_make_list. - * 31-July: s7_define_constant_with_environment and s7_dilambda_with_environment. - * 29-July: open-input|output-function. add S7_NUM_READ_CHOICES to s7_read_t enum and remove (unused) S7_READ_BYTE. - * 20-July: s7_c_pointer_with_type. notcurses_s7.c and nrepl.scm. *autoload-hook*. - * 8-July: s7_int|float_vector_ref|set. subvector parameter order changed. - * 17-June: removed deprecated *s7* accessors. - * 20-May: libarb_s7.c. - * 12-May: s7_is_big*. - * 6-May: added s7_scheme* initial arguments to s7_set_* opt_func calls (s7_set_d_d_function for example). - * 23-Apr: added s7_scheme* initial argument to s7_is_eqv. - * 9-Mar: move openlets to (*s7* 'openlets), s7-version to (*s7* 'version), deprecate nan.0 and inf.0. - * 17-Feb: s7_let_field_ref|set for *s7* access. *function* to replace __func__. - * deprecate __func__, s7_print_length, s7_float_format_precision, s7_set_gc_stats. - * 31-Jan: macro(*) and bacro(*) -- unnamed macros analogous to lambda(*). - * 20-Jan: debug.scm and (*s7* 'debug), trace-in, dynamic-unwind. - * remove coverlets (openlets is now a dilambda). - * 10-Jan: s7_c_type_set_gc_free and s7_c_type_set_gc_mark. - * 2-Jan-20: s7_c_type_set_is_equal and s7_c_type_set_is_equivalent. - * -------- - * 2-Nov: s7_repl. - * 30-Oct: change S7_DATE format, and start updating it to reflect s7.c. - * 30-Jul: define-expansion*. - * 12-Jul: s7_call_with_catch, s7_load now returns NULL if file not found (rather than raise an error). - * 8-July: most-positive-fixnum and most-negative-fixnum moved to *s7*. - * 23-May: added s7_scheme argument to s7_c_object_set_let. - * 19-May: s7_gc_stats renamed s7_set_gc_stats. - * 7-May: s7_gc_unprotect_via_stack and s7_gc_(un)protect_via_location. - * 22-Mar: s7_float_format_precision. port-position. port-file. - * 4-Jan-19: morally-equal? -> equivalent? - * -------- - * 29-Dec: s7_c_type_set_getter|setter (implicit c-object access). - * 23-Dec: remove hash-table, rename hash-table* to hash-table. add weak-hash-table. - * 3-Dec: deprecate s7_gc_unprotect (use s7_gc_unprotect_at). - * 21-Nov: added s7_history_enabled and s7_set_history_enabled. - * 3-Nov: removed the "value" argument from s7_for_each_symbol. - * 22-Sep: s7_list_nl. - * 12-Sep: byte-vectors can be multidimensional; homogenous vectors of any built-in type. typed hash-tables. - * 29-Jul: symbol-setter deprecated (use setter). s7_symbol_documentation (and setter) folded into s7_documentation. - * 12-Jul: changed s7_vector_dimensions|offsets. - * Added s7_scheme* arg to make_permanent_string and several of the optimizer functions. - * 3-Jul: changed make-shared-vector to subvector. - * 20-May: s7_keyword_to_symbol. - * 6-May: s7_mark_c_object -> s7_mark. - * 26-Apr: s7_c_type_set_to_list|string, s7_c_type_set_apply -> s7_c_type_set_ref, removed s7_c_type_set_set|apply_direct - * c_type length|set|ref are now s7_functions (args, not obj, etc). - * 23-Mar: s7_peek_char and s7_read_char now return s7_pointer, s7_write_char takes s7_pointer, not int32_t c - * s7_gc_protect and friends now return/take s7_int location, not uint32_t. - * removed s7_new_type_x. - * 19-Mar: int32_t -> s7_int in various functions. - * 17-Mar: deprecate s7_ulong and s7_ulong_long functions. - * 26-Jan-18: s7_set_setter. - * -------- - * 11-Dec: s7_gc_protect_via_stack - * 3-Oct: renamed procedure-signature -> signature, procedure-documentation -> documentation, and procedure-setter -> setter. - * 18-Sep: s7_immutable, s7_is_immutable. define-constant follows lexical scope now. - * s7_symbol_access -> s7_symbol_setter, symbol-access -> symbol-setter. - * 3-Aug: object->c_object name changes. - * 28-Jul: s7_make_c_pointer_with_type and s7_c_pointer_type. - * 24-Jul: int64_t rather than long long int, and various related changes. - * 18-Jul: s7_make_object_with_let. - * 8-July: s7_define_typed_function_star, s7_make_function_star. s7_apply_function_star. - * 27-June: s7_make_string_wrapper. - * 22-May: lambda* keyword arg handling changed slightly. - * 9-May: s7_history, s7_add_to_history. - * 20-Apr: s7_tree_memq (for Snd), s7_type_of, many changes for new clm optimizer. - * 10-Apr: added s7_scheme first argument to s7_iterator_is_at_end. - * 28-Mar: removed the "rf", "pf" and "if" clm optimization functions. - * s7_optimize, s7_float_optimize, s7_procedure_signature. - * 22-Feb: removed the "gf" clm optimization functions. - * 11-Feb: #e, #i, #d removed. #i(...) is an int-vector constant, #r(...) a float-vector. - * 2-Jan-17: {apply_values} -> apply-values, {list} -> list-values, and {append} -> append. - * -------- - * 23-Sep: make-keyword -> string->keyword. - * 9-Aug: s7_varlet. - * 29-Jul: s7_define_unsafe_typed_function. - * 30-May: symbol takes any number of args. make-vector no longer takes an optional fourth argument. - * 24-May: let-ref/set! check rootlet now if let is not an open let; setter for with-let. - * 20-Feb: removed last vestiges of quasiquoted vector support. - * 3-Feb: *cload-directory*. - * 14-Jan: profile.scm. Moved multiple-value-set! to stuff.scm. Setter for port-line-number. - * 7-Jan: s7_load_with_environment. - * s7_eval_c_string takes only one statement now (use begin to handle multiple statements) - * 4-Jan-16: remove s7_eval_form, change s7_eval to take its place. - * -------- - * 11-Dec: owlet error-history field if WITH_HISTORY=1 - * 6-Nov: removed :key and :optional. - * 16-Oct: s7_make_random_state -> s7_random_state. - * 16-Aug: remove s7_define_integer_function, s7_function_set_removes_temp, - * add s7_define_typed_function, s7_make_signature. - * 5-Aug: added s7_scheme* arg to s7_openlet and s7_outlet. - * 3-Jul: s7_Double -> s7_double, s7_Int -> s7_int. Removed function_chooser_data. - * 27-Jun: s7_rf_t, s7_rp_t etc. - * 19-Jun: removed the ex_parser stuff, set_step_safe, s7_ex_fallback. - * 5-May: s7_make_iterator and friends. - * 16-Apr: added s7_fill, changed arg interpretation of s7_copy, s7_dynamic_wind. - * 30-Mar: s7_eval_c_string_with_environment (repl experiment). - * 19-Mar: repl.scm. - * 28-Feb: s7_vector_print_length -> s7_print_length, set case also. - * 25-Feb: s7_closure_* funcs to replace clumsy (deprecated) s7_procedure_source. - * 29-Jan: changed args to s7_new_type_x (added s7_scheme arg, fill! takes s7_function). - * 14-Jan-15: make-iterator, iterator? - * -------- - * 26-Dec: s7_arity replaces s7_procedure_arity. s7_define_integer_function. deprecate s7_procedure_name. - * 5-Nov: s7_shadow_rootlet and s7_set_shadow_rootlet. - * 30-Aug: s7_make_safe_function (for cload.scm). - * 25-July: define and friends now return the value, not the symbol. - * procedure_with_setter -> dilambda. - * environment -> let. All the replaced names are deprecated. - * 30-June: s7_method. - * 16-June: remove unoptimize and s7_unoptimize. - * 14-May: s7_define_safe_function_star. Removed s7_catch_all. - * 22-Apr: remove s7_apply_n_10, s7_is_valid_pointer, s7_keyword_eq_p. - * 5-Mar-14: s7_heap_size, s7_gc_freed (subsequently removed). - * -------- - * 8-Nov: s7_symbol_documentation, s7_define_constant_with_documentation. - * 17-Oct: bignum-precision (procedure-with-setter) is now an integer variable named *bignum-precision*. - * 28-Aug: s7_int|float_vector_elements (homogeneous vectors), libc.scm. - * 16-Aug: ~W directive in format, make-shared-vector. - * 23-Jul: s7_autoload_set_names, libm.scm, libdl.scm, libgdbm.scm, r7rs.scm, s7libtest.scm. - * 21-Jul: s7_is_valid (replaces deprecated s7_is_valid_pointer). - * 24-Jun: some bool-related changes for Windows Visual C++, including change to s7_begin_hook. - * 3-June: s7_autoload. - * 28-May: export s7_is_provided. Added s7_scheme* arg to s7_procedure_environment. - * 21-May: equality predicate optional arg in make-hash-table. - * 14-May: glistener.c, glistener.h, s7_symbol_table_find_name (for glistener). - * 2-May: r7rs changes: flush-output-port, vector-append, read|write-string, boolean=?, symbol=?. - * start/end args for string-fill!, vector-fill!, string->list, vector->list, and copy. - * exit, emergency-exit. - * 7-Apr: removed s7_scheme* arg from s7_slot_value, added s7_is_local_variable. - * 25-Mar: char-position, string-position, environment-ref, environment-set! added to the scheme side. - * 9-Jan-13: s7_cos, s7_sin, other optimization changes. - * -------- - * 24-Dec: s7_set_object_array_info and other such changes. - * 20-Nov: removed s7_set_error_exiter and s7_error_and_exit which I think have never been used. - * 22-Oct: changed args to s7_function_class and s7_function_set_class. - * 22-Aug: symbol->dynamic-value. - * 10-Aug: exported s7_outer_environment. - * 6-Aug: removed WITH_OPTIMIZATION. - * 25-July: environment (in scheme). s7_vector_ref_n and s7_vector_set_n. s7_copy. - * added s7_scheme arg to s7_number_to_real|integer. - * 16-July: s7_function_returns_temp (an experiment). - * 2-July: s7_object_set_* functions. - * 11-June: throw. - * 4-June. s7_object_environment. - * 31-May: added s7_scheme argument to all the optimizer chooser functions. - * 24-May: open-environment? - * 17-May: arity, aritable? - * removed trace and untrace. - * 14-May: s7_list. s7_procedure_set_setter. Removed s7_procedure_getter. - * procedure-setter is settable: removed most of procedure-with-setter. - * make-type replaced by open-environment. - * 11-May: s7 2.0: hook implementation changed completely. - * s7_environment_ref|set. - * 4-May: *error-info* replaced by error-environment, and stacktrace has changed. - * 22-Apr: #_ = startup (built-in) value of name - * 17-Apr: with-baffle. - * 14-Apr: WITH_SYSTEM_EXTRAS (default 0) has additional OS and IO functions: - * directory? file-exists? delete-file getenv directory->list system - * 26-Mar: "@" as exponent, WITH_AT_SIGN_AS_EXPONENT switch (default is 1). - * 18-Mar: removed *trace-hook*. - * 6-Feb: random-state?, hash-table-iterator?, and morally-equal? - * 18-Jan: s7_environment_to_list and environment->list return just the local environment's bindings. - * outer-environment returns the environment enclosing its argument (an environment). - * environments are now applicable objects. - * added the object system example to s7.html. - * 12-Jan: added reverse argument to s7_new_type_x. This is needed because an object might implement - * the apply and set methods, but they might refer to different things. - * 6-Jan-12: added (scheme side) logbit?. - * -------- - * 21-Dec: s7_eval, s7_make_slot, s7_slot_set_value. - * changed s7_symbol_slot to s7_slot, and s7_symbol_slot_value to s7_slot_value. - * 26-Oct: s7_procedure_name. - * 6-Oct: changed s7_make_closure args: split the code argument in two (args and body). - * s7_make_closure(... code ...) is now s7_make_closure(... car(code), cdr(code) ...) - * s7_is_environment. - * 19-Aug: s7_function_chooser_data. - * 11-Aug: s7_symbol_accessor functions. s7_cxxxxr. - * 9-Aug: s7_function_chooser, s7_function_choice, s7_function_choice_set_direct. - * 20-Jul: s7_function_class, s7_function_set_class, and s7_function_set_chooser. - * 14-Jul: removed thread and profiling support. - * 5-June: s7_define_safe_function and s7_unoptimize exported; added unoptimize function in scheme. - * 30-May: environment->list and s7_environment_to_list since environments are no longer alists internally. - * 26-May: added s7_scheme argument to s7_procedure_setter and getter (old names had "with_setter_"). - * 28-Apr: s7_help. - * 5-Apr: pair-line-number. - * 14-Mar: s7_make_random_state, optional state argument to s7_random, random-state->list, s7_random_state_to_list. - * 10-Feb: s7_vector_print_length, s7_set_vector_print_length. - * 7-Feb: s7_begin_hook, s7_set_begin_hook. - * 25-Jan: s7_is_thread, s7_thread, s7_make_thread, s7_thread_s7, s7_thread_data. - * s7_is_lock, s7_make_lock, s7_lock. - * changed s7_thread_variable_value to s7_thread_variable. - * 23-Jan: removed (scheme-level) quit. - * 17-Jan-11: make-hash-table-iterator. - * map and for-each accept any applicable object as the first argument. - * format's ~{...~} directive can handle any applicable object. - * -------- - * 17-Dec: removed unquote-splicing; replaced by (unquote (apply values ...)). - * 12-Dec: environment? - * 7-Dec: member and assoc have an optional third arg, the comparison function. - * 1-Dec: *gc-stats* in Scheme, s7_gc_stats in C. - * gmp and gtk-repl examples in s7.html. - * 21-Nov: Load C module example in s7.html. - * 12-Nov: *trace-hook*, *load-hook*, *error-hook*, and *unbound-variable-hook* are now s7 hooks. - * 9-Nov: hooks: C side: s7_is_hook, s7_make_hook, s7_hook_apply, s7_hook_functions, s7_hook_arity, s7_hook_documentation. - * s7 side: hook?, make-hook, hook, hook-apply, hook-functions, hook-arity, hook-documentation. - * 8-Nov: Closure defined in C example in s7.html. - * 23-Oct: s7_call_with_location for better error reporting. - * 19-Oct: *stdin*, *stdout*, *stderr* for default IO ports (rather than nil which is ambiguous). - * 14-Oct: removed special variable support. - * 30-Sep: setters for current-input-port, current-output-port, and current-error-port. - * 30-Aug: :allow-other-keys in define*. - * 10-Aug: added boolean argument use_write to s7_object_to_string (true=write, false=display). - * 30-July: special macro for access to dynamic binding. - * s7_symbol_special_value for C-side access to dynamic bindings. - * s7_is_macro. - * port-closed? returns #t if its argument (a port) is closed. - * 22-July: s7_make_character takes uint32_t, rather than int. - * added symbol function for funny symbol names. - * 12-July: initial-environment. - * 7-July: removed force and delay: use slib. - * 3-July: new backquote implementation. - * 28-June: syntactic keywords (e.g. lambda) are applicable. - * 7-June: changed key arg in s7_hash_table_ref|set to be s7_pointer, not const char*. - * hash-tables can now handle any s7 object as the key. - * map and for-each now pass a hash-table entry to the function, rather than an internal alist. - * reverse of a hash-table reverses the keys and values (i.e. old value becomes new key, etc). - * 2-June: removed procedure-with-setter-setter-arity and folded that info into procedure-arity (use cdddr). - * 22-May: multidimensional vectors are no longer optional. - * 9-May: s7_read_char and s7_peek_char have to return an int, not a char (=-1, but 255 is a legit char). - * s7_write_char and s7_open_output_function have similar changes. - * 3-May: *#readers* to customize #... reading. Also nan? and infinite?. - * multidimensional vector constants using #nD(...): (#2D((1 2 3) (4 5 6)) 0 0) -> 1. - * 13-Apr: removed hash-table|vector|string-for-each -- these are handled by for-each. - * also removed vector-map -- map is generic, but always returns a list. - * 12-Apr: removed immutable constant checks -- see s7.html. - * 7-Apr: *unbound-variable-hook*. - * augment-environment and s7_augment_environment. - * 29-Mar: symbol-access, s7_symbol_access, s7_symbol_set_access. - * C example of notification in s7.html. - * 25-Mar: make-type. s7_is_equal now includes an s7_scheme pointer as its first argument. - * 24-Mar: s7_is_defined. - * 19-Mar: removed encapsulation mechanism and s7_define_set_function. - * 18-Mar: added macro?. - * 27-Feb: removed r4rs-style macro syntax. - * 17-Feb: s7_number_to_integer. - * 20-Jan-10: removed the stack function. - * -------- - * 16-Dec: hash-table-for-each. - * 1-Dec: mpc versions before 0.8.0 are no longer supported. - * 24-Nov: define-macro* and defmacro*. - * force and delay included only if WITH_FORCE set, promise? removed. - * 17-Nov: s7_is_boolean no longer takes the s7_scheme argument. - * 7-Nov: s7_vector_dimensions, s7_vector_offsets, example of use. - * 3-Nov: s7_vector_rank. - * 30-Oct: *trace-hook*. - * 12-Oct: s7_port_filename. - * 5-Oct: s7_c_pointer and friends. - * 14-Sep: s7_values, s7_make_continuation, and a better interrupt example. - * vector-for-each, vector-map, string-for-each. - * 7-Sep: s7_open_input_function. with-environment. receive. - * 3-Sep: s7.html, s7-slib-init.scm. - * s7_stacktrace in s7.h. - * 27-Aug: vector and hash-table sizes are now s7_ints, rather than ints. - * 20-Aug: s7_remove_from_heap. - * 17-Aug: *error-info*. - * 7-Aug: s7_define_function_with_setter. - * s7_quit and example of signal handling. - * 6-Aug: encapsulation. s7_define_set_function. s7_new_type_x. - * generic function: copy, and length is generic. - * 1-Aug: lower-case versions of s7_T and friends. - * s7_define_macro. macroexpand. - * strings are set-applicable (like vectors). - * 31-Jul: *error-hook*. - * 30-Jul: changed backtrace handling: removed backtrace stuff, added stacktrace. - * removed gc-verbose and load-verbose replaced by *load-hook*. - * 23-Jul: __func__. - * 20-Jul: trace and untrace. - * 14-Jul: replaced s7_make_closure_star with s7_define_function_star. - * 29-Jun: s7_format declaration. - * 12-May: s7_is_constant. - * 20-Apr: changed rationalize to be both r5rs-acceptable and fast. - * 6-Apr: added s7_make_permanent_string. - * 14-Mar: removed s7_local_gc_protect and s7_local_gc_unprotect. - * 4-Mar: multidimensional and applicable vectors. - * 1-Mar: s7_random added to s7.h. - * 29-Jan: s7_is_bignum and friends. - * 26-Jan: added s7_scheme arg to s7_vector_fill. - * 16-Jan: s7_is_ulong_long and friends for C pointers in 64-bit situations. - * 9-Jan-09 multiprecision arithmetic (gmp, mpfr, mpc) on the WITH_GMP switch - * -------- - * 29-Dec: "+" specialization example, s7_apply_function. - * 3-Dec: s7_open_output_function. - * 30-Nov: s7_wrong_number_of_args_error. - * 24-Nov: changed s7_make_counted_string to s7_make_string_with_length. - * also added built-in format and define* - * 10-Nov: s7_define_constant, - * built-in (scheme-side) pi, most-positive-fixnum, most-negative-fixnum - * 7-Nov: removed s7_is_immutable and friends, s7_reverse_in_place. - * removed the s7_pointer arg to s7_gc_on. - * added s7_UNSPECIFIED - * 25-Oct: added name arg to s7_make_procedure_with_setter, - * and s7_scheme arg to new_type print func. - * 1-Oct-08 version 1.0 - */ - - -#ifdef __cplusplus -} -#endif - -#endif diff --git a/source/engine/script.c b/source/engine/script.c index df49923..d4c306f 100644 --- a/source/engine/script.c +++ b/source/engine/script.c @@ -157,9 +157,9 @@ JSValue script_compile(const char *file) { const char *script = slurp_text(file); char strbuf[strlen(script)+50]; - sprintf(strbuf, "(function(){%s})", script); + sprintf(strbuf, "(function(){\n%s\n})", script); - JSValue fn = JS_Eval(js, strbuf, strlen(script), file, JS_EVAL_FLAGS); + JSValue fn = JS_Eval(js, strbuf, strlen(strbuf), file, JS_EVAL_FLAGS); free(script); return fn; diff --git a/source/engine/sound.c b/source/engine/sound.c index 6a7f16d..dc1e28a 100644 --- a/source/engine/sound.c +++ b/source/engine/sound.c @@ -16,7 +16,8 @@ #include "dsp.h" #include "mix.h" -#include "miniaudio.h" +#define SOKOL_AUDIO_IMPL +#include "sokol/sokol_audio.h" #define TSF_IMPLEMENTATION #include "tsf.h" @@ -97,17 +98,18 @@ void wav_norm_gain(struct wav *w, double lv) { } } -static ma_engine *engine; +void push_sound(float *buffer, int frames, int chan) +{ + bus_fill_buffers(buffer, frames*chan); +} void sound_init() { - ma_result result; - engine = malloc(sizeof(*engine)); - result = ma_engine_init(NULL, engine); - if (result != MA_SUCCESS) { - return; - } - return; - + saudio_setup(&(saudio_desc){ + .stream_cb = push_sound, + .sample_rate = SAMPLERATE, + .num_channels = CHANNELS, + .buffer_frames = BUF_FRAMES, + }); mixer_init(); } @@ -156,32 +158,31 @@ struct soundstream *soundstream_make() { } void mini_sound(char *path) { - ma_engine_play_sound(engine, path, NULL); + + //ma_engine_play_sound(engine, path, NULL); } -static ma_sound music_sound; - void mini_music_play(char *path) { - ma_sound_uninit(&music_sound); - int result = ma_sound_init_from_file(engine, path, MA_SOUND_FLAG_NO_SPATIALIZATION, NULL, NULL, &music_sound); +/* int result = ma_sound_init_from_file(engine, path, MA_SOUND_FLAG_NO_SPATIALIZATION, NULL, NULL, &music_sound); if (result != MA_SUCCESS) { YughInfo("Could not load music at path: %s", path); } YughInfo("Loading %s...", path); ma_sound_start(&music_sound); +*/ } void mini_music_pause() { - ma_sound_stop(&music_sound); +// ma_sound_stop(&music_sound); } void mini_music_stop() { - ma_sound_stop(&music_sound); +// ma_sound_stop(&music_sound); } void mini_master(float v) { - ma_engine_set_volume(engine, v); +// ma_engine_set_volume(engine, v); } void kill_oneshot(struct sound *s) { diff --git a/source/engine/sound.h b/source/engine/sound.h index 01837ce..9a70b24 100644 --- a/source/engine/sound.h +++ b/source/engine/sound.h @@ -3,6 +3,8 @@ struct circbuf; +typedef float soundbyte; + struct Mix_Chunk { int i; }; diff --git a/source/engine/sound/mix.c b/source/engine/sound/mix.c index 5433c11..9c0eb3e 100644 --- a/source/engine/sound/mix.c +++ b/source/engine/sound/mix.c @@ -12,9 +12,7 @@ static struct bus bus[256]; static int first = 0; /* First bus available */ static int first_on = -1; /* First bus to fill buffer with */ -short mastermix[BUF_FRAMES*CHANNELS]; - -static int initted = 0; +soundbyte mastermix[BUF_FRAMES*CHANNELS]; static float master_volume = 1.f; @@ -32,13 +30,9 @@ void mixer_init() { } bus[255].next = -1; - - initted = 1; } struct bus *first_free_bus(struct dsp_filter in) { -// assert(initted); - for (int i = 0; i < 255; i++) if (!bus[i].on) { bus[i].on = 1; @@ -79,10 +73,10 @@ void bus_free(struct bus *b) b->on = 0; } -void bus_fill_buffers(short *master, int n) { +void bus_fill_buffers(soundbyte *master, int n) { int curbus = first_on; // if (curbus == -1) return; - memset(master, 0, BUF_FRAMES*CHANNELS*sizeof(short)); + memset(master, 0, BUF_FRAMES*CHANNELS*sizeof(soundbyte)); for (int i = 0; i < 255; i++) { if (!bus[i].on) continue; diff --git a/source/engine/sound/mix.h b/source/engine/sound/mix.h index 7913a85..93bf025 100644 --- a/source/engine/sound/mix.h +++ b/source/engine/sound/mix.h @@ -2,13 +2,11 @@ #define MIX_H #include "dsp.h" - -struct sound; - +#include "sound.h" struct bus { struct dsp_filter in; - short buf[BUF_FRAMES*CHANNELS]; + soundbyte buf[BUF_FRAMES*CHANNELS]; float gain; int on; int next; /* Next available bus */ @@ -16,12 +14,12 @@ struct bus { int id; }; -extern short mastermix[BUF_FRAMES*CHANNELS]; +extern soundbyte mastermix[BUF_FRAMES*CHANNELS]; void mixer_init(); struct bus *first_free_bus(struct dsp_filter in); -void bus_fill_buffers(short *master, int n); +void bus_fill_buffers(soundbyte *master, int n); /* Set volume between 0 and 100% */ void mix_master_vol(float v); diff --git a/source/engine/sound/music.c b/source/engine/sound/music.c index edcfed6..7513cec 100644 --- a/source/engine/sound/music.c +++ b/source/engine/sound/music.c @@ -16,49 +16,43 @@ float music_pan = 0.f; void dsp_midi_fillbuf(struct dsp_midi_song *song, void *out, int n) { - short *o = (short*)out; - tml_message *midi = song->midi; + soundbyte *o = (soundbyte*)out; + tml_message *midi = song->midi; - for (int i = 0; i < n; i += TSF_BLOCK) { + for (int i = 0; i < n; i += TSF_BLOCK) { + while (midi && song->time >= midi->time) { + switch (midi->type) { + case TML_PROGRAM_CHANGE: + tsf_channel_set_presetnumber(song->sf, midi->channel, midi->program, (midi->channel == 9)); + break; - while (midi && song->time >= midi->time) { + case TML_NOTE_ON: + tsf_channel_note_on(song->sf, midi->channel, midi->key, midi->velocity / 127.f); + break; - switch (midi->type) - { - case TML_PROGRAM_CHANGE: - tsf_channel_set_presetnumber(song->sf, midi->channel, midi->program, (midi->channel == 9)); - break; + case TML_NOTE_OFF: + tsf_channel_note_off(song->sf, midi->channel, midi->key); + break; - case TML_NOTE_ON: - tsf_channel_note_on(song->sf, midi->channel, midi->key, midi->velocity / 127.f); - break; + case TML_PITCH_BEND: + tsf_channel_set_pitchwheel(song->sf, midi->channel, midi->pitch_bend); + break; - case TML_NOTE_OFF: - tsf_channel_note_off(song->sf, midi->channel, midi->key); - break; + case TML_CONTROL_CHANGE: + tsf_channel_midi_control(song->sf, midi->channel, midi->control, midi->control_value); + break; + } - case TML_PITCH_BEND: - tsf_channel_set_pitchwheel(song->sf, midi->channel, midi->pitch_bend); - break; - - case TML_CONTROL_CHANGE: - tsf_channel_midi_control(song->sf, midi->channel, midi->control, midi->control_value); - break; - } - - - midi = midi->next; - } - - - tsf_render_short(song->sf, o, TSF_BLOCK, 0); - o += TSF_BLOCK*CHANNELS; - song->time += TSF_BLOCK * (1000.f/SAMPLERATE); + midi = midi->next; } + tsf_render_float(song->sf, o, TSF_BLOCK, 0); + o += TSF_BLOCK*CHANNELS; + song->time += TSF_BLOCK * (1000.f/SAMPLERATE); + } - song->midi = midi; + song->midi = midi; - dsp_pan(&music_pan, out, n); +// dsp_pan(&music_pan, out, n); } struct bus *musicbus; @@ -88,9 +82,9 @@ void play_song(const char *midi, const char *sf) cursong.data = &gsong; cursong.filter = dsp_midi_fillbuf; musicbus = first_free_bus(cursong); + YughWarn("DID IT"); } - void music_play() { diff --git a/source/engine/yugine.c b/source/engine/yugine.c index c3741a9..964c316 100644 --- a/source/engine/yugine.c +++ b/source/engine/yugine.c @@ -48,7 +48,7 @@ double renderMS = 1 / 165.f; double physMS = 1 / 165.f; double updateMS = 1 / 165.f; -static int sim_play = 0; + double lastTick = 0.0; static int phys_step = 0; @@ -59,10 +59,11 @@ static double framems[FPSBUF]; int framei = 0; int fps; -#define SIM_STOP 0 -#define SIM_PLAY 1 -#define SIM_PAUSE 2 -#define SIM_STEP 3 +#define SIM_PLAY 0 +#define SIM_PAUSE 1 +#define SIM_STEP 2 + +static int sim_play = SIM_PLAY; #ifdef __TINYC__ int backtrace(void **buffer, int size) { @@ -282,7 +283,6 @@ int frame_fps() { int sim_playing() { return sim_play == SIM_PLAY; } int sim_paused() { return sim_play == SIM_PAUSE; } -int sim_stopped() { return sim_play == SIM_STOP; } void sim_start() { sim_play = SIM_PLAY; @@ -292,11 +292,6 @@ void sim_pause() { sim_play = SIM_PAUSE; } -void sim_stop() { - /* Revert starting state of everything from sim_start */ - sim_play = SIM_STOP; -} - int phys_stepping() { return sim_play == SIM_STEP; } void sim_step() { diff --git a/source/scripts/base.js b/source/scripts/base.js index e0b9816..19173bb 100644 --- a/source/scripts/base.js +++ b/source/scripts/base.js @@ -477,8 +477,7 @@ Object.defineProperty(Array.prototype, 'lerp', { } }); -Object.defineProperty(Object.prototype, 'lerp', { - value: function(to, t) { +Object.lerp = function(to, t) { var self = this; var obj = {}; @@ -487,8 +486,7 @@ Object.defineProperty(Object.prototype, 'lerp', { }); return obj; - } -}); +}; /* MATH EXTENSIONS */ Object.defineProperty(Number.prototype, 'lerp', { @@ -498,6 +496,12 @@ Object.defineProperty(Number.prototype, 'lerp', { } }); +Math.lerp = function(from, to, t) { + var v = (to - from) * t + from; + v = Math.clamp(v, from, to); + return v; +} + Math.clamp = function (x, l, h) { return x > h ? h : x < l ? l : x; } Math.random_range = function(min,max) { return Math.random() * (max-min) + min; }; @@ -521,6 +525,7 @@ Math.angledist = function (a1, a2) { return wrap; }; +Math.angledist.doc = "Find the shortest angle between two angles."; Math.deg2rad = function(deg) { return deg * 0.0174533; }; Math.rad2deg = function(rad) { return rad / 0.0174533; }; diff --git a/source/scripts/debug.js b/source/scripts/debug.js index 83cbfba..848720d 100644 --- a/source/scripts/debug.js +++ b/source/scripts/debug.js @@ -255,6 +255,18 @@ var Time = { set updateMS(x) { cmd(6, x); }, set physMS(x) { cmd(7, x); }, set renderMS(x) { cmd(5, x); }, + + pause() { + Time.timescale = 0; + }, + + play() { + if (!Time.stash) { + Log.warn("Tried to resume time without calling Time.pause first."); + return; + } + Time.timescale = Time.stash; + }, }; Player.players[0].control(DebugControls); diff --git a/source/scripts/engine.js b/source/scripts/engine.js index e635f57..86f9a1e 100644 --- a/source/scripts/engine.js +++ b/source/scripts/engine.js @@ -702,6 +702,10 @@ var animation = { }, }; +var Audio = { + +}; + var Music = { play(path) { Log.info("Playing " + path); @@ -721,12 +725,13 @@ var Music = { }; var Sound = { + sounds: [], play(file) { - var s = Object.create(sound); - s.path = file; - s.play(); - // this.id = cmd(14,file); - return s; +// var s = Object.create(Sound); +// s.path = file; +// s.play(); + this.id = cmd(14,file); + //return s; }, music(midi, sf) { @@ -1033,8 +1038,8 @@ var Register = { entries = entries.filter(function(f) { return fn === f; }); } - n.broadcast = function() { - entries.forEach(x => x[0].call(x[1])); + n.broadcast = function(...args) { + entries.forEach(x => x[0].call(x[1], ...args)); } n.clear = function() { @@ -1271,7 +1276,9 @@ var Game = { stop() { - sys_cmd(2); + Game.pause(); + /* And return to editor .. */ + Log.warn("Stopping not implemented. Paused, and go to editor."); }, step() @@ -1320,20 +1327,19 @@ var Level = { }, run() { - var objs = this.objects.slice(); var scene = {}; - var self = this; // TODO: If an object does not have a varname, give it one based on its parent - objs.forEach(function(x) { + this.objects.forEach(function(x) { if (x.hasOwn('varname')) { scene[x.varname] = x; this[x.varname] = x; } },this); - cmd(123, this.scriptfile, self); - + var fn = compile(this.scriptfile); + fn.call(this); + if (typeof this.update === 'function') Register.update.register(this.update, this); @@ -1801,6 +1807,7 @@ World.load = function(lvl) { World.loaded.kill(); World.loaded = World.spawn(lvl); + return World.loaded; }; var gameobjects = {};